diff --git a/Make.inc.in b/Make.inc.in index c8d0e5dc..0e75547f 100755 --- a/Make.inc.in +++ b/Make.inc.in @@ -35,7 +35,6 @@ LIBS=@LIBS@ # BLAS, BLACS and METIS libraries. BLAS=@BLAS_LIBS@ -BLACS=@BLACS_LIBS@ METIS_LIB=@METIS_LIBS@ LAPACK=@LAPACK_LIBS@ EXTRA_COBJS=@FAKEMPI@ diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index 2bb8f7e6..9c0d36e9 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -107,7 +107,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -115,13 +115,13 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -192,13 +192,13 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -355,7 +355,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_complex,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -378,7 +378,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag=psb_complex_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& @@ -411,7 +411,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -597,20 +597,20 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -844,7 +844,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & mpi_complex,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -866,7 +866,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_complex_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -898,7 +898,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 34f91911..b5a15542 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -197,13 +197,13 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,7 +363,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_complex,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -386,7 +386,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_complex_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & mpi_complex,prcid(i),& @@ -417,7 +417,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -601,7 +601,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -687,13 +687,13 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -852,7 +852,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_complex,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -875,7 +875,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_complex_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & mpi_complex,prcid(i),& @@ -905,7 +905,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_complex_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 2ba4b462..72fa9fbd 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -108,7 +108,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -116,13 +116,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -193,13 +193,13 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -356,7 +356,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_double_precision,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -379,7 +379,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag=psb_double_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& @@ -412,7 +412,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -597,20 +597,20 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -844,7 +844,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & mpi_double_precision,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -866,7 +866,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag=psb_double_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -898,7 +898,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag =psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 1d68c7e8..2feab115 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -197,13 +197,13 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,7 +363,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_double_precision,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -386,7 +386,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag=psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & mpi_double_precision,prcid(i),& @@ -417,7 +417,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -601,7 +601,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -849,7 +849,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_double_precision,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -872,7 +872,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag=psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & mpi_double_precision,prcid(i),& @@ -902,7 +902,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 8f6fbbba..f671b843 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -107,7 +107,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -115,13 +115,13 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -192,13 +192,13 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -355,7 +355,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_integer,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -378,7 +378,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_int_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& @@ -411,7 +411,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -597,20 +597,20 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -844,7 +844,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & mpi_integer,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -866,7 +866,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_int_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -898,7 +898,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index a88bd6ac..9665d622 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -197,13 +197,13 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,7 +363,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_integer,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -386,7 +386,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_int_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & mpi_integer,prcid(i),& @@ -417,7 +417,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -601,7 +601,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -687,13 +687,13 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -852,7 +852,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_integer,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -875,7 +875,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_int_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & mpi_integer,prcid(i),& @@ -905,7 +905,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_int_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index 7668b348..bed77607 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -108,7 +108,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -116,13 +116,13 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -193,13 +193,13 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -356,7 +356,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_real,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -379,7 +379,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_real_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& @@ -412,7 +412,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -597,20 +597,20 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -844,7 +844,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & mpi_real,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -866,7 +866,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_real_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -898,7 +898,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index 67c4617b..c05be959 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -197,13 +197,13 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,7 +363,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_real,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -386,7 +386,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_real_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & mpi_real,prcid(i),& @@ -417,7 +417,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -601,7 +601,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -849,7 +849,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_real,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -872,7 +872,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_real_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & mpi_real,prcid(i),& @@ -902,7 +902,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_real_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 3f8ad7ce..8e114fd7 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -107,7 +107,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -115,13 +115,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -192,13 +192,13 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -355,7 +355,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_double_complex,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -378,7 +378,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_dcomplex_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& @@ -411,7 +411,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -597,20 +597,20 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -684,13 +684,13 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -844,7 +844,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & mpi_double_complex,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -866,7 +866,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_dcomplex_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -898,7 +898,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 05670139..9902573f 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -197,13 +197,13 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,7 +363,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_double_complex,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -386,7 +386,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_dcomplex_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & mpi_double_complex,prcid(i),& @@ -417,7 +417,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -601,7 +601,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -687,13 +687,13 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = psb_success_ + info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -852,7 +852,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_double_complex,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -875,7 +875,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag=ksendid(ictxt,proc_to_comm,me) + p2ptag= psb_dcomplex_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & mpi_double_complex,prcid(i),& @@ -905,7 +905,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = krecvid(ictxt,proc_to_comm,me) + p2ptag = psb_dcomplex_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/modules/Makefile b/base/modules/Makefile index 5b2a2a36..fedc33e0 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -2,11 +2,11 @@ include ../../Make.inc BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o UTIL_MODS = psb_string_mod.o \ - psb_desc_type.o psb_sort_mod.o psb_penv_mod.o \ - psb_serial_mod.o \ + psb_desc_type.o psb_sort_mod.o psb_serial_mod.o \ psb_base_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\ psb_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.o \ - psb_blacs_mod.o \ + psi_comm_buffers_mod.o psi_penv_mod.o psi_bcast_mod.o \ + psi_reduce_mod.o psi_p2p_mod.o psb_error_impl.o \ psb_linmap_type_mod.o psb_linmap_mod.o psb_comm_mod.o\ psb_s_psblas_mod.o psb_c_psblas_mod.o \ psb_d_psblas_mod.o psb_z_psblas_mod.o psb_psblas_mod.o \ @@ -28,13 +28,17 @@ CINCLUDES=-I. FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). $(FIFLAG). -lib: $(BASIC_MODS) blacsmod $(UTIL_MODS) $(OBJS) $(LIBMOD) +lib: $(BASIC_MODS) penvmod $(UTIL_MODS) $(OBJS) $(LIBMOD) $(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) /bin/cp -p $(LIBMOD) $(LIBDIR) /bin/cp -p *$(.mod) $(LIBDIR) +psi_penv_mod.o: psi_comm_buffers_mod.o psb_const_mod.o psb_realloc_mod.o +psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o penvmod.o: psi_penv_mod.o +psb_penv_mod.o: psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o + psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o\ psb_error_mod.o psi_serial_mod.o psb_s_base_mat_mod.o psb_d_base_mat_mod.o psb_c_base_mat_mod.o psb_z_base_mat_mod.o: psb_base_mat_mod.o @@ -51,7 +55,6 @@ psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o psb_sort_mod.o psb_error_mod.o: psb_const_mod.o psb_ip_reord_mod.o: psb_const_mod.o -psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o psb_blacs_mod.o psb_blacs_mod.o: psb_const_mod.o psi_serial_mod.o: psb_const_mod.o psb_realloc_mod.o psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o psb_serial_mod.o @@ -75,8 +78,11 @@ psb_sparse_mod.o: $(MODULES) newmods: $(BASIC_MODS) (cd ../newserial; make lib LIBNAME=$(LIBNAME)) -blacsmod: - (make psb_blacs_mod.o psb_penv_mod.o F90COPT="$(F90COPT) $(EXTRA_OPT)") + + +penvmod: + (make psb_penv_mod.o F90COPT="$(F90COPT) $(EXTRA_OPT)") + clean: diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 886f56fd..df39e578 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -32,7 +32,11 @@ module psb_const_mod ! This is the default integer +#if defined(LONG_INTEGERS) + integer, parameter :: ndig=12 +#else integer, parameter :: ndig=8 +#endif integer, parameter :: psb_int_k_ = selected_int_kind(ndig) ! This is an 8-byte integer, and normally different from default integer. integer, parameter :: longndig=12 @@ -45,6 +49,7 @@ module psb_const_mod integer, parameter :: psb_spk_ = kind(1.e0) integer, save :: psb_sizeof_dp, psb_sizeof_sp integer, save :: psb_sizeof_int, psb_sizeof_long_int + integer, save :: psb_mpi_integer ! ! Handy & miscellaneous constants diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index f35b9f4b..0e952eaa 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -30,25 +30,38 @@ !!$ !!$ module psb_error_mod - + use psb_const_mod integer, parameter, public :: psb_act_ret_=0, psb_act_abort_=1, psb_no_err_=0 integer, parameter, public :: psb_debug_ext_=1, psb_debug_outer_=2 integer, parameter, public :: psb_debug_comp_=3, psb_debug_inner_=4 integer, parameter, public :: psb_debug_serial_=8, psb_debug_serial_comp_=9 + ! ! Error handling ! public psb_errpush, psb_error, psb_get_errstatus,& - & psb_get_errverbosity, psb_set_errverbosity,psb_errcomm, & + & psb_errpop, psb_errmsg, psb_errcomm, psb_get_numerr, & + & psb_get_errverbosity, psb_set_errverbosity, & & psb_erractionsave, psb_erractionrestore, & & psb_get_erraction, psb_set_erraction, & & psb_get_debug_level, psb_set_debug_level,& & psb_get_debug_unit, psb_set_debug_unit,& & psb_get_serial_debug_level, psb_set_serial_debug_level + interface psb_error - module procedure psb_serror - module procedure psb_perror + subroutine psb_serror() + end subroutine psb_serror + subroutine psb_perror(ictxt) + integer, intent(in) :: ictxt + end subroutine psb_perror + end interface + + interface + subroutine psb_errcomm(ictxt, err) + integer, intent(in) :: ictxt + integer, intent(inout):: err + end subroutine psb_errcomm end interface @@ -163,20 +176,6 @@ contains end subroutine psb_set_serial_debug_level - ! checks wether an error has occurred on one of the porecesses in the execution pool - subroutine psb_errcomm(ictxt, err) - integer, intent(in) :: ictxt - integer, intent(inout):: err - integer :: temp(2) - integer, parameter :: ione=1 - ! Cannot use psb_amx or otherwise we have a recursion in module usage -#if !defined(SERIAL_MPI) - call igamx2d(ictxt, 'A', ' ', ione, ione, err, ione,& - &temp ,temp,-ione ,-ione,-ione) -#endif - end subroutine psb_errcomm - - ! sets verbosity of the error message subroutine psb_set_errverbosity(v) @@ -186,6 +185,14 @@ contains + ! returns number of errors + function psb_get_numerr() + integer :: psb_get_numerr + + psb_get_numerr = error_stack%n_elems + end function psb_get_numerr + + ! returns verbosity of the error message function psb_get_errverbosity() integer :: psb_get_errverbosity @@ -259,97 +266,6 @@ contains - ! handles the occurence of an error in a parallel routine - subroutine psb_perror(ictxt) - - integer, intent(in) :: ictxt - integer :: err_c - character(len=20) :: r_name - character(len=40) :: a_e_d - integer :: i_e_d(5) - integer :: nprow, npcol, me, mypcol - integer, parameter :: ione=1, izero=0 - -#if defined(SERIAL_MPI) - me = -1 -#else - call blacs_gridinfo(ictxt,nprow,npcol,me,mypcol) -#endif - - - if(error_status > 0) then - if(verbosity_level > 1) then - - do while (error_stack%n_elems > izero) - write(0,'(50("="))') - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) - ! write(0,'(50("="))') - end do -#if defined(SERIAL_MPI) - stop -#else - call blacs_abort(ictxt,-1) -#endif - else - - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) - do while (error_stack%n_elems > 0) - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - end do -#if defined(SERIAL_MPI) - stop -#else - call blacs_abort(ictxt,-1) -#endif - end if - end if - - if(error_status > izero) then -#if defined(SERIAL_MPI) - stop -#else - call blacs_abort(ictxt,err_c) -#endif - end if - - - end subroutine psb_perror - - - ! handles the occurence of an error in a serial routine - subroutine psb_serror() - - integer :: err_c - character(len=20) :: r_name - character(len=40) :: a_e_d - integer :: i_e_d(5) - integer, parameter :: ione=1, izero=0 - - if(error_status > 0) then - if(verbosity_level > 1) then - - do while (error_stack%n_elems > izero) - write(0,'(50("="))') - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(err_c, r_name, i_e_d, a_e_d) - ! write(0,'(50("="))') - end do - - else - - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(err_c, r_name, i_e_d, a_e_d) - do while (error_stack%n_elems > 0) - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - end do - end if - end if - - end subroutine psb_serror - - ! prints the error msg associated to a specific error code subroutine psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) @@ -367,164 +283,147 @@ contains select case (err_c) - case(:0) + case(:psb_success_) write (0,'("error on calling sperror. err_c must be greater than 0")') - case(2) + case(psb_err_pivot_too_small_) write (0,'("pivot too small: ",i0,1x,a)')i_e_d(1),a_e_d - case(3) + case(psb_err_invalid_ovr_num_) write (0,'("Invalid number of ovr:",i0)')i_e_d(1) - case(5) + case(psb_err_invalid_input_) write (0,'("Invalid input")') - case(10) + case(psb_err_iarg_neg_) write (0,'("input argument n. ",i0," cannot be less than 0")')i_e_d(1) write (0,'("current value is ",i0)')i_e_d(2) - case(20) + case(psb_err_iarg_pos_) write (0,'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1) write (0,'("current value is ",i0)')i_e_d(2) - case(30) + case(psb_err_input_value_invalid_i_) write (0,'("input argument n. ",i0," has an invalid value")')i_e_d(1) write (0,'("current value is ",i0)')i_e_d(2) - case(31) - write (0,'("input argument n. ",i0," has an invalid value")')i_e_d(1) - write (0,'("current value is ",a)')a_e_d - case(35) + case(psb_err_input_asize_invalid_i_) write (0,'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1) write (0,'("Current value is ",i0)')i_e_d(2) - case(36) - write (0,'("Size of input array argument n. ",i0," must be ")')i_e_d(1) - write (0,'("at least ",i0)')i_e_d(2) - case(40) + case(psb_err_iarg_invalid_i_) write (0,'("input argument n. ",i0," has an invalid value")')i_e_d(1) write (0,'("current value is ",a)')a_e_d(2:2) - case(50) + case(psb_err_iarg_not_gtia_ii_) write (0,'("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') i_e_d(1), i_e_d(3) write (0,'("current values are ",i0," < ",i0)') i_e_d(2),i_e_d(5) - case(60) + case(psb_err_iarg_not_gteia_ii_) write (0,'("input argument n. ",i0," must be greater than or equal to ",i0)')i_e_d(1),i_e_d(2) write (0,'("current value is ",i0," < ",i0)')i_e_d(3), i_e_d(2) - case(70) + case(psb_err_iarg_invalid_value_) write (0,'("input argument n. ",i0," in entry # ",i0," has an invalid value")')i_e_d(1:2) write (0,'("current value is ",a)')a_e_d - case(71) + case(psb_err_asb_nrc_error_) write (0,'("Impossible error in ASB: nrow>ncol,")') write (0,'("Actual values are ",i0," > ",i0)')i_e_d(1:2) ! ... csr format error ... - case(80) + case(psb_err_iarg2_neg_) write (0,'("input argument ia2(1) is less than 0")') write (0,'("current value is ",i0)')i_e_d(1) ! ... csr format error ... - case(90) + case(psb_err_ia2_not_increasing_) write (0,'("indices in ia2 array are not in increasing order")') - case(91) + case(psb_err_ia1_not_increasing_) write (0,'("indices in ia1 array are not in increasing order")') ! ... csr format error ... - case(100) + case(psb_err_ia1_badindices_) write (0,'("indices in ia1 array are not within problem dimension")') write (0,'("problem dimension is ",i0)')i_e_d(1) - case(110) + case(psb_err_invalid_args_combination_) write (0,'("invalid combination of input arguments")') - case(115) + case(psb_err_invalid_pid_arg_) write (0,'("Invalid process identifier in input array argument n. ",i0,".")')i_e_d(1) write (0,'("Current value is ",i0)')i_e_d(2) - case(120) + case(psb_err_iarg_n_mbgtian_) write (0,'("input argument n. ",i0," must be greater than input argument n. ",i0)')i_e_d(1:2) write (0,'("current values are ",i0," < ",i0)') i_e_d(3:4) ! ... coo format error ... - case(130) + case(psb_err_duplicate_coo) write (0,'("there are duplicated elements in coo format")') write (0,'("and you have chosen psb_dupl_err_ ")') - case(134) + case(psb_err_invalid_input_format_) write (0,'("Invalid input format ",a3)')a_e_d(1:3) - case(135) + case(psb_err_unsupported_format_) write (0,'("Format ",a3," not yet supported here")')a_e_d(1:3) - case(136) + case(psb_err_format_unknown_) write (0,'("Format ",a3," is unknown")')a_e_d(1:3) - case(140) + case(psb_err_iarray_outside_bounds_) write (0,'("indices in input array are not within problem dimension ",2(i0,2x))')i_e_d(1:2) - case(150) + case(psb_err_iarray_outside_process_) write (0,'("indices in input array are not belonging to the calling process ",i0)')i_e_d(1) - case(290) + case(psb_err_forgot_geall_) write (0,'("To call this routine you must first call psb_geall on the same matrix")') - case(295) + case(psb_err_forgot_spall_) write (0,'("To call this routine you must first call psb_spall on the same matrix")') - case(300) + case(psb_err_iarg_mbeeiarra_i_) write (0,'("Input argument n. ",i0," must be equal to entry n. ",i0," in array input argument n.",i0)') & & i_e_d(1),i_e_d(4),i_e_d(3) write (0,'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5) - case(400) + case(psb_err_mpi_error_) write (0,'("MPI error:",i0)')i_e_d(1) - case(550) + case(psb_err_parm_differs_among_procs_) write (0,'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1) - case(551) + case(psb_err_entry_out_of_bounds_) write (0,'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')i_e_d(1),i_e_d(3),i_e_d(4),i_e_d(2) - case(552) + case(psb_err_inconsistent_index_lists_) write (0,'("Index lists are inconsistent: some indices are orphans")') - case(570) + case(psb_err_partfunc_toomuchprocs_) write (0,'("partition function passed as input argument n. ",i0," returns number of processes")')i_e_d(1) write (0,'("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')i_e_d(4) write (0,'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3) - case(575) + case(psb_err_partfunc_toofewprocs_) write (0,'("partition function passed as input argument n. ",i0," returns number of processes")')i_e_d(1) write (0,'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')i_e_d(3),i_e_d(2) - case(580) + case(psb_err_partfunc_wrong_pid_) write (0,'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')i_e_d(1) write (0,'("on global point ",i0,". Current value returned is : ",i0)')i_e_d(3),i_e_d(2) - case(581) + case(psb_err_no_optional_arg_) write (0,'("Exactly one of the optional arguments ",a," must be present")')a_e_d - case(582) + case(psb_err_arg_m_required_) write (0,'("Argument M is required when argument PARTS is specified")') - case(583) - write (0,'("No more than one of the optional arguments ",a," must be present")')a_e_d - case(600) + case(psb_err_spmat_invalid_state_) write (0,'("Sparse Matrix and descriptors are in an invalid state for this subroutine call: ",i0)')i_e_d(1) - case(700) - write (0,'("The base version of subroutine ''",a,"'' has been called.",/,& - &"The class implementation for ''",a,"'' may be incomplete!")') & - & trim(r_name), trim(a_e_d) - - case (1121) - write (0,'("Invalid state for sparse matrix A")') - case (1122) + case (psb_err_invalid_cd_state_) write (0,'("Invalid state for communication descriptor")') - case (1123) + case (psb_err_invalid_a_and_cd_state_) write (0,'("Invalid combined state for A and DESC_A")') - case (1124) - write (0,'("Invalid state for object:",a)') trim(a_e_d) - case(1125:1999) + case(1124:1999) write (0,'("computational error. code: ",i0)')err_c - case(2010) + case(psb_err_blacs_error_) write (0,'("BLACS error. Number of processes=-1")') - case(2011) + case(psb_err_initerror_neugh_procs_) write (0,'("Initialization error: not enough processes available in the parallel environment")') - case(2030) + case(psb_err_blacs_err_gridcols_not_1_) write (0,'("BLACS ERROR: Number of grid columns must be equal to 1\nCurrent value is ",i4," != 1.")')i_e_d(1) - case(2231) + case(psb_err_invalid_matrix_input_state_) write (0,'("Invalid input state for matrix.")') - case(2232) + case(psb_err_input_no_regen_) write (0,'("Input state for matrix is not adequate for regeneration.")') case (2233:2999) write(0,'("resource error. code: ",i0)')err_c case(3000:3009) write (0,'("sparse matrix representation ",a3," not yet implemented")')a_e_d(1:3) - case(3010) + case(psb_err_lld_case_not_implemented_) write (0,'("Case lld not equal matrix_data[N_COL_] is not yet implemented.")') - case(3015) + case(psb_err_transpose_unsupported_) write (0,'("transpose option for sparse matrix representation ",a3," not implemented")')a_e_d(1:3) - case(3020) + case(psb_err_transpose_c_unsupported_) write (0,'("Case trans = C is not yet implemented.")') - case(3021) + case(psb_err_transpose_not_n_unsupported_) write (0,'("Case trans /= N is not yet implemented.")') - case(3022) + case(psb_err_only_unit_diag_) write (0,'("Only unit diagonal so far for triangular matrices. ")') case(3023) write (0,'("Cases DESCRA(1:1)=S DESCRA(1:1)=T not yet implemented. ")') case(3024) write (0,'("Cases DESCRA(1:1)=G not yet implemented. ")') - case(3030) + case(psb_err_ja_nix_ia_niy_unsupported_) write (0,'("Case ja /= ix or ia/=iy is not yet implemented.")') - case(3040) + case(psb_err_ix_n1_iy_n1_unsupported_) write (0,'("Case ix /= 1 or iy /= 1 is not yet implemented.")') case(3050) write (0,'("Case ix /= iy is not yet implemented.")') @@ -539,7 +438,7 @@ contains case(3100) write (0,'("Error on index. Element has not been inserted")') write (0,'("local index is: ",i0," and global index is:",i0)')i_e_d(1:2) - case(3110) + case(psb_err_input_matrix_unassembled_) write (0,'("Before you call this routine, you must assembly sparse matrix")') case(3111) write (0,'("Before you call this routine, you must initialize the preconditioner")') @@ -547,23 +446,23 @@ contains write (0,'("Before you call this routine, you must build the preconditioner")') case(3113:3999) write(0,'("miscellaneus error. code: ",i0)')err_c - case(4000) + case(psb_err_alloc_dealloc_) write(0,'("Allocation/deallocation error")') - case(4001) + case(psb_err_internal_error_) write(0,'("Internal error: ",a)')a_e_d - case(4010) + case(psb_err_from_subroutine_) write (0,'("Error from call to subroutine ",a)')a_e_d - case(4011) + case(psb_err_from_subroutine_non_) write (0,'("Error from call to a subroutine ")') - case(4012) + case(psb_err_from_subroutine_i_) write (0,'("Error ",i0," from call to a subroutine ")')i_e_d(1) - case(4013) + case(psb_err_from_subroutine_ai_) write (0,'("Error from call to subroutine ",a," ",i0)')a_e_d,i_e_d(1) - case(4025) + case(psb_err_alloc_request_) write (0,'("Error on allocation request for ",i0," items of type ",a)')i_e_d(1),a_e_d case(4110) write (0,'("Error ",i0," from call to an external package in subroutine ",a)')i_e_d(1),a_e_d - case (5001) + case (psb_err_invalid_istop_) write (0,'("Invalid ISTOP: ",i0)')i_e_d(1) case (5002) write (0,'("Invalid PREC: ",i0)')i_e_d(1) diff --git a/base/modules/psb_penv_mod.F90 b/base/modules/psb_penv_mod.F90 index f5912dc4..17f0f6a7 100644 --- a/base/modules/psb_penv_mod.F90 +++ b/base/modules/psb_penv_mod.F90 @@ -1,3571 +1,11 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari 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 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, parameter :: mpi_success=0 - integer, parameter :: mpi_request_null=0 - integer, parameter :: mpi_status_size=1 - integer, parameter :: mpi_integer = 1 - integer, parameter :: mpi_integer8 = 2 - integer, parameter :: mpi_real = 3 - integer, parameter :: mpi_double_precision = 4 - integer, parameter :: mpi_complex = 5 - integer, parameter :: mpi_double_complex = 6 - real(psb_dpk_), external :: mpi_wtime -end module mpi -#endif - -module psb_penv_mod - - use psb_const_mod - use psb_blacs_mod - - interface psb_init - module procedure psb_init - end interface - - interface psb_exit - module procedure psb_exit - end interface - - interface psb_abort - module procedure psb_abort - end interface - - interface psb_info - module procedure psb_info - end interface - - interface psb_barrier - module procedure psb_barrier - end interface - - interface psb_wtime - module procedure psb_wtime - end interface - - interface psb_bcast - module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,& - & psb_dbcasts, psb_dbcastv, psb_dbcastm,& - & psb_zbcasts, psb_zbcastv, psb_zbcastm,& - & psb_sbcasts, psb_sbcastv, psb_sbcastm,& - & psb_cbcasts, psb_cbcastv, psb_cbcastm,& - & psb_hbcasts, psb_hbcastv, psb_lbcasts, psb_lbcastv - end interface - - - interface psb_snd - module procedure psb_isnds, psb_isndv, psb_isndm,& - & psb_ssnds, psb_ssndv, psb_ssndm,& - & psb_csnds, psb_csndv, psb_csndm,& - & psb_dsnds, psb_dsndv, psb_dsndm,& - & psb_zsnds, psb_zsndv, psb_zsndm,& - & psb_hsnds, psb_lsnds - end interface - - interface psb_rcv - module procedure psb_ircvs, psb_ircvv, psb_ircvm,& - & psb_srcvs, psb_srcvv, psb_srcvm,& - & psb_crcvs, psb_crcvv, psb_crcvm,& - & psb_drcvs, psb_drcvv, psb_drcvm,& - & psb_zrcvs, psb_zrcvv, psb_zrcvm,& - & psb_hrcvs, psb_lrcvs - end interface - - interface psb_max - module procedure psb_imaxs, psb_imaxv, psb_imaxm,& - & psb_i8maxs, & - & psb_smaxs, psb_smaxv, psb_smaxm,& - & psb_dmaxs, psb_dmaxv, psb_dmaxm - end interface - - - interface psb_min - module procedure psb_imins, psb_iminv, psb_iminm,& - & psb_i8mins, & - & psb_smins, psb_sminv, psb_sminm,& - & psb_dmins, psb_dminv, psb_dminm - end interface - - - interface psb_amx - module procedure psb_iamxs, psb_iamxv, psb_iamxm,& - & psb_i8amxs, & - & psb_samxs, psb_samxv, psb_samxm,& - & psb_camxs, psb_camxv, psb_camxm,& - & psb_damxs, psb_damxv, psb_damxm,& - & psb_zamxs, psb_zamxv, psb_zamxm - end interface - - interface psb_amn - module procedure psb_iamns, psb_iamnv, psb_iamnm,& - & psb_i8amns, & - & psb_samns, psb_samnv, psb_samnm,& - & psb_camns, psb_camnv, psb_camnm,& - & psb_damns, psb_damnv, psb_damnm,& - & psb_zamns, psb_zamnv, psb_zamnm - end interface - - interface psb_sum - module procedure psb_isums, psb_isumv, psb_isumm,& - & psb_i8sums, psb_i8sumv,& - & psb_ssums, psb_ssumv, psb_ssumm,& - & psb_csums, psb_csumv, psb_csumm,& - & psb_dsums, psb_dsumv, psb_dsumm,& - & psb_zsums, psb_zsumv, psb_zsumm - end interface - - -#if defined(SERIAL_MPI) - integer, private, save :: nctxt=0 -#else -#if defined(HAVE_KSENDID) - interface - integer function krecvid(contxt,proc_to_comm,myrow) - integer contxt,proc_to_comm,myrow - end function krecvid - end interface - interface - integer function ksendid(contxt,proc_to_comm,myrow) - integer contxt,proc_to_comm,myrow - end function ksendid - end interface -#endif -#endif - - private psi_get_sizes -contains - - subroutine psi_get_sizes() - use psb_const_mod - real(psb_dpk_) :: dv(2) - real(psb_spk_) :: sv(2) - integer :: iv(2) - integer(psb_long_int_k_) :: ilv(2) - - call psi_c_diffadd(sv(1),sv(2),psb_sizeof_sp) - call psi_c_diffadd(dv(1),dv(2),psb_sizeof_dp) - call psi_c_diffadd(iv(1),iv(2),psb_sizeof_int) - call psi_c_diffadd(ilv(1),ilv(2),psb_sizeof_long_int) - - end subroutine psi_get_sizes - - subroutine psb_init(ictxt,np) - use psb_const_mod - use psb_error_mod - integer, intent(out) :: ictxt - integer, intent(in), optional :: np - - integer :: np_, npavail, iam, info - character(len=20), parameter :: name='psb_init' -#if defined(SERIAL_MPI) - ictxt = nctxt - nctxt = nctxt + 1 - np_ = 1 -#else - call blacs_pinfo(iam, npavail) - call blacs_get(izero, izero, ictxt) - - if (present(np)) then - np_ = max(1,min(np,npavail)) - else - np_ = npavail - endif - - call blacs_gridinit(ictxt, 'R', np_, ione) -#endif - if (present(np)) then - if (np_ < np) then - info = psb_err_initerror_neugh_procs_ - call psb_errpush(info,name) - call psb_error(ictxt) - endif - endif - call psi_get_sizes() - - end subroutine psb_init - - subroutine psb_exit(ictxt,close) - integer, intent(in) :: ictxt - logical, intent(in), optional :: close - logical :: close_ - integer :: nprow, npcol, myprow, mypcol - -#if !defined(SERIAL_MPI) - if (present(close)) then - close_ = close - else - close_ = .true. - end if - call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol) - if ((myprow >=0).and.(mypcol>=0)) then - call blacs_gridexit(ictxt) - end if - if (close_) call blacs_exit(0) -#endif - end subroutine psb_exit - - - subroutine psb_barrier(ictxt) - integer, intent(in) :: ictxt - -#if !defined(SERIAL_MPI) - call blacs_barrier(ictxt,'All') -#endif - - end subroutine psb_barrier - - function psb_wtime() -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - real(psb_dpk_) :: psb_wtime - - psb_wtime = mpi_wtime() - end function psb_wtime - - subroutine psb_abort(ictxt) - integer, intent(in) :: ictxt - -#if defined(SERIAL_MPI) - stop -#else - call blacs_abort(ictxt,-1) -#endif - - end subroutine psb_abort - - - subroutine psb_info(ictxt,iam,np) - - integer, intent(in) :: ictxt - integer, intent(out) :: iam, np - integer :: nprow, npcol, myprow, mypcol - -#if defined(SERIAL_MPI) - iam = 0 - np = 1 -#else - call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol) - - iam = myprow - np = nprow -#endif - - end subroutine psb_info - - - subroutine psb_ibcasts(ictxt,dat,root) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_ibcasts - - subroutine psb_ibcastv(ictxt,dat,root) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_ibcastv - - subroutine psb_ibcastm(ictxt,dat,root) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_ibcastm - - - subroutine psb_sbcasts(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_sbcasts - - - subroutine psb_sbcastv(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_sbcastv - - subroutine psb_sbcastm(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_sbcastm - - - - subroutine psb_dbcasts(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_dbcasts - - - subroutine psb_dbcastv(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_dbcastv - - subroutine psb_dbcastm(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_dbcastm - - - subroutine psb_cbcasts(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_cbcasts - - subroutine psb_cbcastv(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_cbcastv - - subroutine psb_cbcastm(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_cbcastm - - subroutine psb_zbcasts(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zbcasts - - subroutine psb_zbcastv(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zbcastv - - subroutine psb_zbcastm(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: iam, np, root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - - if (iam == root_) then - call gebs2d(ictxt,'A',dat) - else - call gebr2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zbcastm - - - subroutine psb_hbcasts(ictxt,dat,root,length) -#ifdef MPI_H - include 'mpif.h' -#endif -#ifdef MPI_MOD - use mpi -#endif - integer, intent(in) :: ictxt - character(len=*), intent(inout) :: dat - integer, intent(in), optional :: root,length - - integer :: iam, np, root_,icomm,length_,info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - if (present(length)) then - length_ = length - else - length_ = len(dat) - endif - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - call mpi_bcast(dat,length_,MPI_CHARACTER,root_,icomm,info) -#endif - - end subroutine psb_hbcasts - - subroutine psb_hbcastv(ictxt,dat,root) -#ifdef MPI_H - include 'mpif.h' -#endif -#ifdef MPI_MOD - use mpi -#endif - integer, intent(in) :: ictxt - character(len=*), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_,icomm,length_,info, size_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - length_ = len(dat) - size_ = size(dat) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,icomm,info) -#endif - - end subroutine psb_hbcastv - - subroutine psb_lbcasts(ictxt,dat,root) -#ifdef MPI_H - include 'mpif.h' -#endif -#ifdef MPI_MOD - use mpi -#endif - integer, intent(in) :: ictxt - logical, intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: iam, np, root_,icomm,info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - call mpi_bcast(dat,1,MPI_LOGICAL,root_,icomm,info) -#endif - - end subroutine psb_lbcasts - - - subroutine psb_lbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - logical, intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: iam, np, root_,icomm,info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,icomm,info) -#endif - - end subroutine psb_lbcastv - - - - subroutine psb_imaxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_, dat_ - integer :: iam, np, icomm,info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_integer,mpi_max,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_integer,mpi_max,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_imaxs - - subroutine psb_imaxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: root_ - integer, allocatable :: dat_(:) - integer :: iam, np, icomm, info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_=dat - if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_max,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_integer,mpi_max,root_,icomm,info) - end if - endif -#endif - end subroutine psb_imaxv - - subroutine psb_imaxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer :: root_ - integer, allocatable :: dat_(:,:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_=dat - if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_max,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_integer,mpi_max,root_,icomm,info) - end if - endif -#endif - end subroutine psb_imaxm - - subroutine psb_smaxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - real(psb_spk_) :: dat_ - integer :: iam, np, icomm,info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_real,mpi_max,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_real,mpi_max,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_smaxs - - subroutine psb_smaxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - if (info == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,icomm,info) - end if - endif -#endif - end subroutine psb_smaxv - - subroutine psb_smaxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer :: iam, np, icomm, info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - if (info == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,icomm,info) - end if - endif -#endif - end subroutine psb_smaxm - - subroutine psb_dmaxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - real(psb_dpk_) :: dat_ - integer :: iam, np, icomm,info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_max,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_max,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_dmaxs - subroutine psb_dmaxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - if (info == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_max,root_,icomm,info) - end if - endif -#endif - end subroutine psb_dmaxv - - subroutine psb_dmaxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer :: iam, np, icomm, info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - if (info == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_max,root_,icomm,info) - end if - endif -#endif - end subroutine psb_dmaxm - - - subroutine psb_imins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_, dat_ - integer :: iam, np, icomm,info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_integer,mpi_min,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_integer,mpi_min,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_imins - - subroutine psb_iminv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: root_ - integer, allocatable :: dat_(:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_=dat - if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_min,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_integer,mpi_min,root_,icomm,info) - end if - endif -#endif - end subroutine psb_iminv - - subroutine psb_iminm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer :: root_ - integer, allocatable :: dat_(:,:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_=dat - if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_min,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_integer,mpi_min,root_,icomm,info) - end if - endif -#endif - end subroutine psb_iminm - - subroutine psb_smins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - real(psb_spk_) :: dat_ - integer :: iam, np, icomm,info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_real,mpi_min,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_real,mpi_min,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_smins - - subroutine psb_sminv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - if (info == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,icomm,info) - end if - endif -#endif - end subroutine psb_sminv - - subroutine psb_sminm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer :: iam, np, icomm, info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - if (info == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,icomm,info) - end if - endif -#endif - - end subroutine psb_sminm - - subroutine psb_dmins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - real(psb_dpk_) :: dat_ - integer :: iam, np, icomm,info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_min,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_min,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_dmins - - subroutine psb_dminv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer :: iam, np, icomm, info - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - if (info == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_min,root_,icomm,info) - end if - endif -#endif - end subroutine psb_dminv - - subroutine psb_dminm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer :: iam, np, icomm, info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - if (info == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,icomm,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,icomm,info) - else - call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_min,root_,icomm,info) - end if - endif -#endif - - end subroutine psb_dminm - - - subroutine psb_iamxs(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_iamxs - - subroutine psb_iamxv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_iamxv - - subroutine psb_iamxm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_iamxm - - subroutine psb_samxs(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_samxs - - subroutine psb_samxv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_samxv - - subroutine psb_samxm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_samxm - - subroutine psb_damxs(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_damxs - - subroutine psb_damxv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_damxv - - subroutine psb_damxm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_damxm - - - subroutine psb_camxs(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_camxs - - subroutine psb_camxv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_camxv - - subroutine psb_camxm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_camxm - - subroutine psb_zamxs(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zamxs - - subroutine psb_zamxv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zamxv - - subroutine psb_zamxm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamx2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zamxm - subroutine psb_iamns(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_iamns - - subroutine psb_iamnv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_iamnv - - subroutine psb_iamnm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_iamnm - - - subroutine psb_samns(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_samns - - subroutine psb_samnv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_samnv - - subroutine psb_samnm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_samnm - - subroutine psb_damns(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_damns - - subroutine psb_damnv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_damnv - - subroutine psb_damnm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_damnm - - - subroutine psb_camns(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_camns - - subroutine psb_camnv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_camnv - - subroutine psb_camnm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_camnm - - subroutine psb_zamns(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia - - integer :: root_ - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zamns - - subroutine psb_zamnv(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:) - - integer :: root_ - integer, allocatable :: cia(:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zamnv - - subroutine psb_zamnm(ictxt,dat,root,ia) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - integer, intent(inout), optional :: ia(:,:) - - integer :: root_ - integer, allocatable :: cia(:,:) - - -#if defined(SERIAL_MPI) - if (present(ia)) then - ia = 0 - end if -#else - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (present(ia)) then - allocate(cia(size(ia,1),size(ia,2))) - call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) - else - call gamn2d(ictxt,'A',dat,rrt=root_) - endif -#endif - end subroutine psb_zamnm - - - - subroutine psb_i8sumv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - integer :: mpi_int8_type, info, icomm - - integer :: root_, iam, np, isz - integer(psb_long_int_k_), allocatable :: dat_(:) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - mpi_int8_type = mpi_integer8 - isz = size(dat) - allocate(dat_(isz),stat=info) - if (root_ == -1) then - dat_=dat - call mpi_allreduce(dat_,dat,isz,mpi_int8_type,mpi_sum,icomm,info) - else - if (iam == root_) then - dat_=dat - call mpi_reduce(dat_,dat,isz,mpi_int8_type,mpi_sum,root_,icomm,info) - else - call mpi_reduce(dat,dat_,isz,mpi_int8_type,mpi_sum,root_,icomm,info) - end if - endif -#endif - - end subroutine psb_i8sumv - - - subroutine psb_i8sums(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: mpi_int8_type, info, icomm - - integer :: root_, iam, np - integer(psb_long_int_k_) :: dat_ - - if (present(root)) then - root_ = root - else - root_ = -1 - endif -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - mpi_int8_type = mpi_integer8 - if (root_ == -1) then - dat_=dat - call mpi_allreduce(dat_,dat,1,mpi_int8_type,mpi_sum,icomm,info) - else - if (iam == root_) then - dat_=dat - call mpi_reduce(dat_,dat,1,mpi_int8_type,mpi_sum,root_,icomm,info) - else - call mpi_reduce(dat,dat_,1,mpi_int8_type,mpi_sum,root_,icomm,info) - end if - endif -#endif - end subroutine psb_i8sums - - subroutine psb_i8amx_mpi_user(inv, outv,len,type) - integer(psb_long_int_k_) :: inv(*),outv(*) - integer :: len,type - integer :: i - - do i=1, len - if (abs(inv(i)) > abs(outv(i))) then - outv(i) = inv(i) - end if - end do - end subroutine psb_i8amx_mpi_user - - subroutine psb_i8amn_mpi_user(inv, outv,len,type) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_long_int_k_) :: inv(*),outv(*) - integer :: len,type - integer :: i - if (type /= mpi_integer8) then - write(0,*) 'Invalid type !!!' - end if - do i=1, len - if (abs(inv(i)) < abs(outv(i))) then - outv(i) = inv(i) - end if - end do - end subroutine psb_i8amn_mpi_user - - subroutine psb_i8amns(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - integer(psb_long_int_k_) :: dat_ - integer :: iam, np, icomm,info, i8amn - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - call mpi_op_create(psb_i8amn_mpi_user,.true.,i8amn,info) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_integer8,i8amn,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_integer8,i8amn,root_,icomm,info) - dat = dat_ - endif - call mpi_op_free(i8amn,info) -#endif - end subroutine psb_i8amns - - subroutine psb_i8amxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - integer(psb_long_int_k_) :: dat_ - integer :: iam, np, icomm,info, i8amx - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - call mpi_op_create(psb_i8amx_mpi_user,.true.,i8amx,info) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_integer8,i8amx,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_integer8,i8amx,root_,icomm,info) - dat = dat_ - endif - call mpi_op_free(i8amx,info) -#endif - end subroutine psb_i8amxs - - subroutine psb_i8mins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - integer(psb_long_int_k_) :: dat_ - integer :: iam, np, icomm,info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_min,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_min,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_i8mins - - subroutine psb_i8maxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif -#ifdef MPI_H - include 'mpif.h' -#endif - integer, intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer, intent(in), optional :: root - integer :: root_ - integer(psb_long_int_k_) :: dat_ - integer :: iam, np, icomm,info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - call psb_get_mpicomm(ictxt,icomm) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_max,icomm,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_max,root_,icomm,info) - dat = dat_ - endif -#endif - end subroutine psb_i8maxs - - subroutine psb_isums(ictxt,dat,root) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_isums - - subroutine psb_isumv(ictxt,dat,root) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - end subroutine psb_isumv - - subroutine psb_isumm(ictxt,dat,root) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_isumm - - - subroutine psb_ssums(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_ssums - - subroutine psb_ssumv(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_ssumv - - subroutine psb_ssumm(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) - -#endif - end subroutine psb_ssumm - - subroutine psb_dsums(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_dsums - - subroutine psb_dsumv(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_dsumv - - subroutine psb_dsumm(ictxt,dat,root) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) - -#endif - end subroutine psb_dsumm - - - subroutine psb_csums(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_csums - - subroutine psb_csumv(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: root_ - integer, allocatable :: cia(:) - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_csumv - - subroutine psb_csumm(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) - -#endif - end subroutine psb_csumm - - subroutine psb_zsums(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_zsums - - subroutine psb_zsumv(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in), optional :: root - - integer :: root_ - integer, allocatable :: cia(:) - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) -#endif - - end subroutine psb_zsumv - - subroutine psb_zsumm(ictxt,dat,root) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in), optional :: root - - integer :: root_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = -1 - endif - - call gsum2d(ictxt,'A',dat,rrt=root_) - -#endif - end subroutine psb_zsumm - - - subroutine psb_hsnds(ictxt,dat,dst,length) - use psb_error_mod - integer, intent(in) :: ictxt - character(len=*), intent(in) :: dat - integer, intent(in) :: dst - integer, intent(in), optional :: length - integer, allocatable :: buffer(:) - integer :: length_, i - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - if (present(length)) then - length_ = length - else - length_ = len(dat) - endif - allocate(buffer(length_)) - do i=1,length_ - buffer(i) = iachar(dat(i:i)) - end do - - call gesd2d(ictxt,buffer,dst,0) -#endif - end subroutine psb_hsnds - - subroutine psb_hrcvs(ictxt,dat,src,length) - use psb_error_mod - integer, intent(in) :: ictxt - character(len=*), intent(out) :: dat - integer, intent(in) :: src - integer, intent(in), optional :: length - integer, allocatable :: buffer(:) - integer :: length_, i - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = '' -#else - if (present(length)) then - length_ = length - else - length_ = len(dat) - endif - allocate(buffer(length_)) - - call gerv2d(ictxt,buffer,src,0) - do i=1,length_ - dat(i:i) = achar(buffer(i)) - end do -#endif - - end subroutine psb_hrcvs - - subroutine psb_lsnds(ictxt,dat,dst,length) - use psb_error_mod - integer, intent(in) :: ictxt - logical, intent(in) :: dat - integer, intent(in) :: dst - integer :: i - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - if (dat) then - i = 1 - else - i = 0 - endif - call gesd2d(ictxt,i,dst,0) -#endif - - end subroutine psb_lsnds - - subroutine psb_lrcvs(ictxt,dat,src,length) - use psb_error_mod - integer, intent(in) :: ictxt - logical, intent(out) :: dat - integer, intent(in) :: src - integer :: i - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = .false. -#else - call gerv2d(ictxt,i,src,0) - - dat = (i == 1) -#endif - - end subroutine psb_lrcvs - - - subroutine psb_isnds(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - integer, intent(in) :: dat - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_isnds - - subroutine psb_isndv(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - integer, intent(in) :: dat(:) - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_isndv - - subroutine psb_isndm(ictxt,dat,dst,m) - use psb_error_mod - integer, intent(in) :: ictxt - integer, intent(in) :: dat(:,:) - integer, intent(in) :: dst - integer, intent(in), optional :: m - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0,m) -#endif - - end subroutine psb_isndm - - - subroutine psb_ssnds(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_ssnds - - subroutine psb_ssndv(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:) - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_ssndv - - subroutine psb_ssndm(ictxt,dat,dst,m) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:,:) - integer, intent(in) :: dst - integer, intent(in), optional :: m - - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0,m) -#endif - - end subroutine psb_ssndm - - subroutine psb_dsnds(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_dsnds - - subroutine psb_dsndv(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_dsndv - - subroutine psb_dsndm(ictxt,dat,dst,m) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - integer, intent(in) :: dst - integer, intent(in), optional :: m - - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0,m) -#endif - - end subroutine psb_dsndm - - - subroutine psb_csnds(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_csnds - - subroutine psb_csndv(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:) - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_csndv - - subroutine psb_csndm(ictxt,dat,dst,m) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:,:) - integer, intent(in) :: dst - integer, intent(in), optional :: m - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - - call gesd2d(ictxt,dat,dst,0,m) -#endif - - end subroutine psb_csndm - - subroutine psb_zsnds(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_zsnds - - subroutine psb_zsndv(ictxt,dat,dst) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - integer, intent(in) :: dst - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - call gesd2d(ictxt,dat,dst,0) -#endif - - end subroutine psb_zsndv - - subroutine psb_zsndm(ictxt,dat,dst,m) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - integer, intent(in) :: dst - integer, intent(in), optional :: m - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >1) then - write(0,*) "Warning: process sending a message in serial mode (to itself)" - endif -#else - - call gesd2d(ictxt,dat,dst,0,m) -#endif - - end subroutine psb_zsndm - - - - subroutine psb_ircvs(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in) :: src -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_ircvs - - subroutine psb_ircvv(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_ircvv - - subroutine psb_ircvm(ictxt,dat,src,m) - use psb_error_mod - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in) :: src - integer, intent(in), optional :: m - - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - - call gerv2d(ictxt,dat,src,0,m) -#endif - - end subroutine psb_ircvm - - - subroutine psb_srcvs(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_srcvs - - subroutine psb_srcvv(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_srcvv - - subroutine psb_srcvm(ictxt,dat,src,m) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in) :: src - integer, intent(in), optional :: m - - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0,m) -#endif - - end subroutine psb_srcvm - - subroutine psb_drcvs(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_drcvs - - subroutine psb_drcvv(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_drcvv - - subroutine psb_drcvm(ictxt,dat,src,m) - use psb_error_mod - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in) :: src - integer, intent(in), optional :: m - - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0,m) -#endif - - end subroutine psb_drcvm - - - subroutine psb_crcvs(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_crcvs - - subroutine psb_crcvv(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_crcvv - - subroutine psb_crcvm(ictxt,dat,src,m) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in) :: src - integer, intent(in), optional :: m -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0,m) -#endif - - end subroutine psb_crcvm - - subroutine psb_zrcvs(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_zrcvs - - subroutine psb_zrcvv(ictxt,dat,src) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in) :: src - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0) -#endif - - end subroutine psb_zrcvv - - subroutine psb_zrcvm(ictxt,dat,src,m) - use psb_error_mod - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in) :: src - integer, intent(in), optional :: m - -#if defined(SERIAL_MPI) - if (psb_get_errverbosity() >0) then - write(0,*) "Warning: process receiving a message in serial mode (to itself)" - endif - dat = 0 -#else - call gerv2d(ictxt,dat,src,0,m) -#endif - - end subroutine psb_zrcvm +module psb_penv_mod + use psi_penv_mod + use psi_bcast_mod + use psi_reduce_mod + use psi_p2p_mod - subroutine psb_set_coher(ictxt,isvch) - integer :: ictxt, isvch - ! Ensure global repeatability for convergence checks. -#if (!defined(HAVE_ESSL_BLACS)) &&(!defined(SERIAL_MPI)) - Call blacs_get(ictxt,15,isvch) - Call blacs_set(ictxt,15,1) -#else - ! Do nothing: ESSL does coherence by default, - ! and does not handle req=16 -#endif - end subroutine psb_set_coher - subroutine psb_restore_coher(ictxt,isvch) - integer :: ictxt, isvch - ! Ensure global coherence for convergence checks. -#if (!defined(HAVE_ESSL_BLACS)) &&(!defined(SERIAL_MPI)) - Call blacs_set(ictxt,15,isvch) -#else - ! Do nothing: ESSL does coherence by default, - ! and does not handle req=15 -#endif - end subroutine psb_restore_coher - subroutine psb_get_mpicomm(ictxt,comm) - integer :: ictxt, comm -#if !defined(SERIAL_MPI) - call blacs_get(ictxt,10,comm) -#else - comm = ictxt -#endif - end subroutine psb_get_mpicomm - subroutine psb_get_rank(rank,ictxt,id) - integer :: rank,ictxt, id - integer :: blacs_pnum -#if defined(SERIAL_MPI) - rank = 0 -#else - rank = blacs_pnum(ictxt,id,0) -#endif - end subroutine psb_get_rank - -#if (!defined(HAVE_KSENDID)) || defined(SERIAL_MPI) - ! - ! Need these, as they are not in the ESSL implementation - ! of the BLACS. - ! - integer function krecvid(contxt,proc_to_comm,myrow) - integer contxt,proc_to_comm,myrow - - krecvid=32766 - - return - end function krecvid - integer function ksendid(contxt,proc_to_comm,myrow) - integer contxt,proc_to_comm,myrow - - ksendid=32766 - - return - end function ksendid -#endif - - end module psb_penv_mod + diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index d1366d63..c8f28fb9 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -38,21 +38,25 @@ module psb_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc - module procedure psb_dreallocate1i - module procedure psb_dreallocate2i - module procedure psb_dreallocate2i1d - module procedure psb_dreallocate2i1s - module procedure psb_dreallocate1d - module procedure psb_dreallocate1s - module procedure psb_dreallocated2 - module procedure psb_dreallocates2 - module procedure psb_dreallocatei2 - module procedure psb_dreallocate2i1z - module procedure psb_dreallocate2i1c - module procedure psb_dreallocate1z - module procedure psb_dreallocate1c - module procedure psb_dreallocatez2 - module procedure psb_dreallocatec2 + module procedure psb_reallocate1i + module procedure psb_reallocate2i + module procedure psb_reallocate2i1d + module procedure psb_reallocate2i1s + module procedure psb_reallocate1d + module procedure psb_reallocate1s + module procedure psb_reallocated2 + module procedure psb_reallocates2 + module procedure psb_reallocatei2 +#if ! defined(LONG_INTEGERS) + module procedure psb_reallocate1i8 + module procedure psb_reallocatei8_2 +#endif + module procedure psb_reallocate2i1z + module procedure psb_reallocate2i1c + module procedure psb_reallocate1z + module procedure psb_reallocate1c + module procedure psb_reallocatez2 + module procedure psb_reallocatec2 end Interface interface psb_move_alloc @@ -62,6 +66,10 @@ module psb_realloc_mod module procedure psb_dmove_alloc2d module procedure psb_imove_alloc1d module procedure psb_imove_alloc2d +#if !defined(LONG_INTEGERS) + module procedure psb_i8move_alloc1d + module procedure psb_i8move_alloc2d +#endif module procedure psb_cmove_alloc1d module procedure psb_cmove_alloc2d module procedure psb_zmove_alloc1d @@ -91,12 +99,18 @@ module psb_realloc_mod ! interface psb_ensure_size module procedure psb_icksz1d,& +#if !defined(LONG_INTEGERS) + & psb_i8cksz1d, & +#endif & psb_scksz1d, psb_ccksz1d, & & psb_dcksz1d, psb_zcksz1d end Interface interface psb_size module procedure psb_isize1d, psb_isize2d,& +#if !defined(LONG_INTEGERS) + & psb_i8size1d, psb_i8size2d,& +#endif & psb_ssize1d, psb_ssize2d,& & psb_csize1d, psb_csize2d,& & psb_dsize1d, psb_dsize2d,& @@ -121,10 +135,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -172,10 +186,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if if (allocated(vin)) then @@ -224,9 +238,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -274,9 +288,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -326,9 +340,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -376,9 +390,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -428,9 +442,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -478,9 +492,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -530,9 +544,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if if (allocated(vin)) then @@ -579,9 +593,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if if (allocated(vin)) then @@ -631,9 +645,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) @@ -678,9 +692,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -728,9 +742,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -776,9 +790,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -826,9 +840,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) @@ -873,9 +887,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -923,9 +937,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -971,9 +985,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1021,9 +1035,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) @@ -1069,9 +1083,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if isz1 = size(vin,1) @@ -1114,6 +1128,7 @@ Contains psb_isize1d = size(vin) end if end function psb_isize1d + function psb_isize2d(vin,dim) integer :: psb_isize2d integer, allocatable, intent(in) :: vin(:,:) @@ -1132,6 +1147,37 @@ Contains end if end function psb_isize2d +#if !defined(LONG_INTEGERS) + function psb_i8size1d(vin) + integer :: psb_i8size1d + integer(psb_long_int_k_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + psb_i8size1d = 0 + else + psb_i8size1d = size(vin) + end if + end function psb_i8size1d + + function psb_i8size2d(vin,dim) + integer :: psb_i8size2d + integer(psb_long_int_k_), allocatable, intent(in) :: vin(:,:) + integer, optional :: dim + integer :: dim_ + + if (.not.allocated(vin)) then + psb_i8size2d = 0 + else + if (present(dim)) then + dim_= dim + psb_i8size2d = size(vin,dim=dim_) + else + psb_i8size2d = size(vin) + end if + end if + end function psb_i8size2d +#endif + function psb_ssize1d(vin) integer :: psb_ssize1d real(psb_spk_), allocatable, intent(in) :: vin(:) @@ -1271,7 +1317,7 @@ Contains info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1310,6 +1356,64 @@ Contains End Subroutine psb_icksz1d +#if !defined(LONG_INTEGERS) + Subroutine psb_i8cksz1d(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,Intent(in) :: len + Integer(psb_long_int_k_),allocatable, intent(inout) :: v(:) + integer :: info + integer(psb_long_int_k_), optional, intent(in) :: pad + integer, optional, intent(in) :: addsz,newsz + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer :: isz, err_act + + name='psb_ensure_size' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + call psb_realloc(isz,v,info,pad=pad) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + end if + end If + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_i8cksz1d +#endif Subroutine psb_scksz1d(len,v,info,pad,addsz,newsz) use psb_error_mod @@ -1330,7 +1434,7 @@ Contains info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1388,7 +1492,7 @@ Contains info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1447,7 +1551,7 @@ Contains info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1505,7 +1609,7 @@ Contains info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1544,7 +1648,7 @@ Contains End Subroutine psb_zcksz1d - Subroutine psb_dreallocate1i(len,rrax,info,pad,lb) + Subroutine psb_reallocate1i(len,rrax,info,pad,lb) use psb_error_mod ! ...Subroutine Arguments @@ -1559,14 +1663,14 @@ Contains character(len=20) :: name logical, parameter :: debug=.false. - name='psb_dreallocate1i' + name='psb_reallocate1i' call psb_erractionsave(err_act) info=psb_success_ if (debug) write(0,*) 'reallocate I',len if (psb_get_errstatus() /= 0) then if (debug) write(0,*) 'reallocate errstatus /= 0' - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if @@ -1625,10 +1729,93 @@ Contains return - End Subroutine psb_dreallocate1i + End Subroutine psb_reallocate1i + Subroutine psb_reallocate1i8(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,Intent(in) :: len + Integer(psb_long_int_k_),allocatable, intent(inout) :: rrax(:) + integer :: info + integer(psb_long_int_k_), optional, intent(in) :: pad + integer, optional, intent(in) :: lb + ! ...Local Variables + Integer(psb_long_int_k_),allocatable :: tmp(:) + Integer :: dim, err_act, err,lb_, lbi, ub_ + character(len=20) :: name + logical, parameter :: debug=.false. - Subroutine psb_dreallocate1s(len,rrax,info,pad,lb) + name='psb_reallocate1i' + call psb_erractionsave(err_act) + info=psb_success_ + + if (debug) write(0,*) 'reallocate I',len + if (psb_get_errstatus() /= 0) then + if (debug) write(0,*) 'reallocate errstatus /= 0' + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer') + goto 9999 + end if + ub_ = lb_+len-1 + if (debug) write(0,*) 'reallocate : lb ub ',lb_, ub_ + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + if (debug) write(0,*) 'reallocate : calling move_alloc ' + call psb_move_alloc(tmp,rrax,info) + if (debug) write(0,*) 'reallocate : from move_alloc ',info + end if + else + dim = 0 + allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + if (debug) write(0,*) 'end reallocate : ',info + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + + End Subroutine psb_reallocate1i8 + + + Subroutine psb_reallocate1s(len,rrax,info,pad,lb) use psb_error_mod ! ...Subroutine Arguments @@ -1644,9 +1831,9 @@ Contains character(len=20) :: name logical, parameter :: debug=.false. - name='psb_dreallocate1s' + name='psb_reallocate1s' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (debug) write(0,*) 'reallocate S',len if (present(lb)) then @@ -1700,9 +1887,9 @@ Contains end if return - End Subroutine psb_dreallocate1s + End Subroutine psb_reallocate1s - Subroutine psb_dreallocate1d(len,rrax,info,pad,lb) + Subroutine psb_reallocate1d(len,rrax,info,pad,lb) use psb_error_mod ! ...Subroutine Arguments @@ -1718,9 +1905,9 @@ Contains character(len=20) :: name logical, parameter :: debug=.false. - name='psb_dreallocate1d' + name='psb_reallocate1d' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (debug) write(0,*) 'reallocate D',len if (present(lb)) then @@ -1774,10 +1961,10 @@ Contains end if return - End Subroutine psb_dreallocate1d + End Subroutine psb_reallocate1d - Subroutine psb_dreallocate1c(len,rrax,info,pad,lb) + Subroutine psb_reallocate1c(len,rrax,info,pad,lb) use psb_error_mod ! ...Subroutine Arguments @@ -1793,9 +1980,9 @@ Contains character(len=20) :: name logical, parameter :: debug=.false. - name='psb_dreallocate1c' + name='psb_reallocate1c' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (debug) write(0,*) 'reallocate C',len if (present(lb)) then lb_ = lb @@ -1848,9 +2035,9 @@ Contains end if return - End Subroutine psb_dreallocate1c + End Subroutine psb_reallocate1c - Subroutine psb_dreallocate1z(len,rrax,info,pad,lb) + Subroutine psb_reallocate1z(len,rrax,info,pad,lb) use psb_error_mod ! ...Subroutine Arguments @@ -1866,9 +2053,9 @@ Contains character(len=20) :: name logical, parameter :: debug=.false. - name='psb_dreallocate1z' + name='psb_reallocate1z' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (debug) write(0,*) 'reallocate Z',len if (present(lb)) then lb_ = lb @@ -1921,11 +2108,11 @@ Contains end if return - End Subroutine psb_dreallocate1z + End Subroutine psb_reallocate1z - Subroutine psb_dreallocates2(len1,len2,rrax,info,pad,lb1,lb2) + Subroutine psb_reallocates2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len1,len2 @@ -1941,9 +2128,9 @@ Contains & lbi1, lbi2 character(len=20) :: name - name='psb_dreallocates2' + name='psb_reallocates2' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2014,10 +2201,10 @@ Contains end if return - End Subroutine psb_dreallocates2 + End Subroutine psb_reallocates2 - Subroutine psb_dreallocated2(len1,len2,rrax,info,pad,lb1,lb2) + Subroutine psb_reallocated2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len1,len2 @@ -2033,9 +2220,9 @@ Contains & lbi1, lbi2 character(len=20) :: name - name='psb_dreallocated2' + name='psb_reallocated2' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2106,10 +2293,10 @@ Contains end if return - End Subroutine psb_dreallocated2 + End Subroutine psb_reallocated2 - Subroutine psb_dreallocatec2(len1,len2,rrax,info,pad,lb1,lb2) + Subroutine psb_reallocatec2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len1,len2 @@ -2125,9 +2312,9 @@ Contains & lbi1, lbi2 character(len=20) :: name - name='psb_dreallocatec2' + name='psb_reallocatec2' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2199,9 +2386,9 @@ Contains end if return - End Subroutine psb_dreallocatec2 + End Subroutine psb_reallocatec2 - Subroutine psb_dreallocatez2(len1,len2,rrax,info,pad,lb1,lb2) + Subroutine psb_reallocatez2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len1,len2 @@ -2217,9 +2404,9 @@ Contains & lbi1, lbi2 character(len=20) :: name - name='psb_dreallocatez2' + name='psb_reallocatez2' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2291,10 +2478,10 @@ Contains end if return - End Subroutine psb_dreallocatez2 + End Subroutine psb_reallocatez2 - Subroutine psb_dreallocatei2(len1,len2,rrax,info,pad,lb1,lb2) + Subroutine psb_reallocatei2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len1,len2 @@ -2309,9 +2496,9 @@ Contains & lbi1, lbi2 character(len=20) :: name - name='psb_dreallocatei2' + name='psb_reallocatei2' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2382,9 +2569,101 @@ Contains end if return - End Subroutine psb_dreallocatei2 + End Subroutine psb_reallocatei2 - Subroutine psb_dreallocate2i(len,rrax,y,info,pad) +#if !defined(LONG_INTEGERS) + Subroutine psb_reallocatei8_2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + Integer,Intent(in) :: len1,len2 + integer(psb_long_int_k_),allocatable :: rrax(:,:) + integer :: info + integer(psb_long_int_k_), optional, intent(in) :: pad + Integer,Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + integer(psb_long_int_k_),allocatable :: tmp(:,:) + Integer :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& + & lbi1, lbi2 + character(len=20) :: name + + name='psb_reallocatei2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1,0,0,0,0/),a_err='integer') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len2,0,0,0,0/),a_err='integer') + goto 9999 + end if + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_reallocatei8_2 +#endif + + Subroutine psb_reallocate2i(len,rrax,y,info,pad) use psb_error_mod ! ...Subroutine Arguments @@ -2395,22 +2674,22 @@ Contains character(len=20) :: name integer :: err_act, err - name='psb_dreallocate2i' + name='psb_reallocate2i' call psb_erractionsave(err_act) info=psb_success_ if(psb_get_errstatus() /= 0) then - info = psb_err_from_subroutine_ + info=psb_err_from_subroutine_ goto 9999 end if - call psb_dreallocate1i(len,rrax,info,pad=pad) + call psb_reallocate1i(len,rrax,info,pad=pad) if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if - call psb_dreallocate1i(len,y,info,pad=pad) + call psb_reallocate1i(len,y,info,pad=pad) if (info /= psb_success_) then err=4000 call psb_errpush(err,name) @@ -2429,12 +2708,12 @@ Contains end if return - End Subroutine psb_dreallocate2i + End Subroutine psb_reallocate2i - Subroutine psb_dreallocate2i1s(len,rrax,y,z,info) + Subroutine psb_reallocate2i1s(len,rrax,y,z,info) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len @@ -2445,11 +2724,11 @@ Contains integer :: err_act, err logical, parameter :: debug=.false. - name='psb_dreallocate2i1s' + name='psb_reallocate2i1s' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ call psb_realloc(len,rrax,info) if (info /= psb_success_) then err=4000 @@ -2480,10 +2759,10 @@ Contains call psb_error() end if return - End Subroutine psb_dreallocate2i1s + End Subroutine psb_reallocate2i1s - Subroutine psb_dreallocate2i1d(len,rrax,y,z,info) + Subroutine psb_reallocate2i1d(len,rrax,y,z,info) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len @@ -2493,10 +2772,10 @@ Contains character(len=20) :: name integer :: err_act, err - name='psb_dreallocate2i1d' + name='psb_reallocate2i1d' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ call psb_realloc(len,rrax,info) if (info /= psb_success_) then @@ -2528,11 +2807,11 @@ Contains call psb_error() end if return - End Subroutine psb_dreallocate2i1d + End Subroutine psb_reallocate2i1d - Subroutine psb_dreallocate2i1c(len,rrax,y,z,info) + Subroutine psb_reallocate2i1c(len,rrax,y,z,info) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len @@ -2542,11 +2821,11 @@ Contains character(len=20) :: name integer :: err_act, err - name='psb_dreallocate2i1c' + name='psb_reallocate2i1c' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ call psb_realloc(len,rrax,info) if (info /= psb_success_) then err=4000 @@ -2577,9 +2856,9 @@ Contains call psb_error() end if return - End Subroutine psb_dreallocate2i1c + End Subroutine psb_reallocate2i1c - Subroutine psb_dreallocate2i1z(len,rrax,y,z,info) + Subroutine psb_reallocate2i1z(len,rrax,y,z,info) use psb_error_mod ! ...Subroutine Arguments Integer,Intent(in) :: len @@ -2589,10 +2868,10 @@ Contains character(len=20) :: name integer :: err_act, err - name='psb_dreallocate2i1z' + name='psb_reallocate2i1z' call psb_erractionsave(err_act) - info = psb_success_ + info=psb_success_ call psb_realloc(len,rrax,info) if (info /= psb_success_) then err=4000 @@ -2623,7 +2902,7 @@ Contains call psb_error() end if return - End Subroutine psb_dreallocate2i1z + End Subroutine psb_reallocate2i1z Subroutine psb_smove_alloc1d(vin,vout,info) use psb_error_mod @@ -2631,9 +2910,26 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then +!!$ write(0,*) 'move_alloc: Clearing output' + deallocate(vout) + end if + +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_smove_alloc1d Subroutine psb_smove_alloc2d(vin,vout,info) @@ -2642,9 +2938,25 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_smove_alloc2d Subroutine psb_dmove_alloc1d(vin,vout,info) @@ -2653,9 +2965,26 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then +!!$ write(0,*) 'move_alloc: Clearing output' + deallocate(vout) + end if + +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_dmove_alloc1d Subroutine psb_dmove_alloc2d(vin,vout,info) @@ -2664,9 +2993,25 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_dmove_alloc2d Subroutine psb_cmove_alloc1d(vin,vout,info) @@ -2675,9 +3020,23 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_cmove_alloc1d Subroutine psb_cmove_alloc2d(vin,vout,info) @@ -2686,9 +3045,25 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_cmove_alloc2d Subroutine psb_zmove_alloc1d(vin,vout,info) @@ -2697,9 +3072,23 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_zmove_alloc1d Subroutine psb_zmove_alloc2d(vin,vout,info) @@ -2708,9 +3097,25 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_zmove_alloc2d Subroutine psb_imove_alloc1d(vin,vout,info) @@ -2719,8 +3124,24 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then +!!$ write(0,*) 'move_alloc: Clearing output' + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_imove_alloc1d Subroutine psb_imove_alloc2d(vin,vout,info) @@ -2729,9 +3150,79 @@ Contains integer, intent(out) :: info ! ! - info = psb_success_ - call move_alloc(vin,vout) - + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif end Subroutine psb_imove_alloc2d +#if !defined(LONG_INTEGERS) + Subroutine psb_i8move_alloc1d(vin,vout,info) + use psb_error_mod + integer(psb_long_int_k_), allocatable, intent(inout) :: vin(:),vout(:) + integer, intent(out) :: info + ! + ! + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then +!!$ write(0,*) 'move_alloc: Clearing output' + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_i8move_alloc1d + + Subroutine psb_i8move_alloc2d(vin,vout,info) + use psb_error_mod + integer(psb_long_int_k_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer, intent(out) :: info + ! + ! + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_i8move_alloc2d +#endif end module psb_realloc_mod diff --git a/base/psblas/Makefile b/base/psblas/Makefile index 49c6120d..52781ad8 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -3,7 +3,6 @@ include ../../Make.inc #FCOPT=-O2 OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.o\ psb_dnrm2.o psb_dnrmi.o psb_dspmm.o psb_dspsm.o\ - pdtreecomb.o pstreecomb.o\ psb_zamax.o psb_zasum.o psb_zaxpby.o psb_zdot.o \ psb_znrm2.o psb_znrmi.o psb_zspmm.o psb_zspsm.o\ psb_saxpby.o psb_sdot.o psb_sasum.o psb_samax.o\ diff --git a/base/psblas/pdtreecomb.F b/base/psblas/pdtreecomb.F deleted file mode 100644 index 107662d5..00000000 --- a/base/psblas/pdtreecomb.F +++ /dev/null @@ -1,396 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C This file imported from ScaLAPACK. -C -C - SUBROUTINE PDTREECOMB( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, - $ SUBPTR ) -* -* -- ScaLAPACK tools routine (version 1.0) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* February 28, 1995 -* -* .. Scalar Arguments .. - CHARACTER SCOPE - INTEGER CDEST0, ICTXT, N, RDEST0 -* .. -* .. Array Arguments .. - DOUBLE PRECISION MINE( * ) -* .. -* .. Subroutine Arguments .. - EXTERNAL SUBPTR -* .. -* -* Purpose -* == = ==== -* -* PDTREECOMB does a 1-tree parallel combine operation on scalars, -* using the subroutine indicated by SUBPTR to perform the required -* computation. -* -* Arguments -* == = ====== -* -* ICTXT (global input) INTEGER -* The BLACS context handle, indicating the global context of -* the operation. The context itself is global. -* -* SCOPE (global input) CHARACTER -* The scope of the operation: 'Rowwise', 'Columnwise', or -* 'All'. -* -* N (global input) INTEGER -* The number of elements in MINE. N = 1 for the norm-2 -* computation and 2 for the sum of square. -* -* MINE (local input/global output) DOUBLE PRECISION array of -* dimension at least equal to N. The local data to use in the -* combine. -* -* RDEST0 (global input) INTEGER -* The process row to receive the answer. If RDEST0 = -1, -* every process in the scope gets the answer. -* -* CDEST0 (global input) INTEGER -* The process column to receive the answer. If CDEST0 = -1, -* every process in the scope gets the answer. -* -* SUBPTR (local input) Pointer to the subroutine to call to perform -* the required combine. -* -* == = ================================================================== -* -* .. Local Scalars .. - LOGICAL BCAST, RSCOPE, CSCOPE - INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL, - $ MYROW, MYDIST, MYDIST2, NP, NPCOL, NPROW, - $ RMSSG, TCDEST, TRDEST -* .. -* .. Local Arrays .. - DOUBLE PRECISION HIS( 2 ) -* .. -* .. External Subroutines .. -#if !defined(SERIAL_MPI) - EXTERNAL BLACS_GRIDINFO, DGEBR2D, DGEBS2D, - $ DGERV2D, DGESD2D -#endif -* .. -* .. External Functions .. - LOGICAL PSB_LSAME - EXTERNAL PSB_LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* See if everyone wants the answer (need to broadcast the answer) -* - BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) ) - IF( BCAST ) THEN - TRDEST = 0 - TCDEST = 0 - ELSE - TRDEST = RDEST0 - TCDEST = CDEST0 - END IF -#if !defined(SERIAL_MPI) - -* -* Get grid parameters. -* - CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) -* -* Figure scope-dependant variables, or report illegal scope -* - RSCOPE = PSB_LSAME( SCOPE, 'R' ) - CSCOPE = PSB_LSAME( SCOPE, 'C' ) -* - IF( RSCOPE ) THEN - IF( BCAST ) THEN - TRDEST = MYROW - ELSE IF( MYROW.NE.TRDEST ) THEN - RETURN - END IF - NP = NPCOL - MYDIST = MOD( NPCOL + MYCOL - TCDEST, NPCOL ) - ELSE IF( CSCOPE ) THEN - IF( BCAST ) THEN - TCDEST = MYCOL - ELSE IF( MYCOL.NE.TCDEST ) THEN - RETURN - END IF - NP = NPROW - MYDIST = MOD( NPROW + MYROW - TRDEST, NPROW ) - ELSE IF( PSB_LSAME( SCOPE, 'A' ) ) THEN - NP = NPROW * NPCOL - IAM = MYROW*NPCOL + MYCOL - DEST = TRDEST*NPCOL + TCDEST - MYDIST = MOD( NP + IAM - DEST, NP ) - ELSE - RETURN - END IF -* - IF( NP.LT.2 ) - $ RETURN -* - MYDIST2 = MYDIST - RMSSG = MYROW - CMSSG = MYCOL - I = 1 -* - 10 CONTINUE -* - IF( MOD( MYDIST, 2 ).NE.0 ) THEN -* -* If I am process that sends information -* - DIST = I * ( MYDIST - MOD( MYDIST, 2 ) ) -* -* Figure coordinates of dest of message -* - IF( RSCOPE ) THEN - CMSSG = MOD( TCDEST + DIST, NP ) - ELSE IF( CSCOPE ) THEN - RMSSG = MOD( TRDEST + DIST, NP ) - ELSE - CMSSG = MOD( DEST + DIST, NP ) - RMSSG = CMSSG / NPCOL - CMSSG = MOD( CMSSG, NPCOL ) - END IF -* - CALL DGESD2D( ICTXT, N, 1, MINE, N, RMSSG, CMSSG ) -* - GO TO 20 -* - ELSE -* -* If I am a process receiving information, figure coordinates -* of source of message -* - DIST = MYDIST2 + I - IF( RSCOPE ) THEN - CMSSG = MOD( TCDEST + DIST, NP ) - HISDIST = MOD( NP + CMSSG - TCDEST, NP ) - ELSE IF( CSCOPE ) THEN - RMSSG = MOD( TRDEST + DIST, NP ) - HISDIST = MOD( NP + RMSSG - TRDEST, NP ) - ELSE - CMSSG = MOD( DEST + DIST, NP ) - RMSSG = CMSSG / NPCOL - CMSSG = MOD( CMSSG, NPCOL ) - HISDIST = MOD( NP + RMSSG*NPCOL+CMSSG - DEST, NP ) - END IF -* - IF( MYDIST2.LT.HISDIST ) THEN -* -* If I have anyone sending to me -* - CALL DGERV2D( ICTXT, N, 1, HIS, N, RMSSG, CMSSG ) - CALL SUBPTR( MINE, HIS ) -* - END IF - MYDIST = MYDIST / 2 -* - END IF - I = I * 2 -* - IF( I.LT.NP ) - $ GO TO 10 -* - 20 CONTINUE -* - IF( BCAST ) THEN - IF( MYDIST2.EQ.0 ) THEN - CALL DGEBS2D( ICTXT, SCOPE, ' ', N, 1, MINE, N ) - ELSE - CALL DGEBR2D( ICTXT, SCOPE, ' ', N, 1, MINE, N, - $ TRDEST, TCDEST ) - END IF - END IF -#endif -* - RETURN -* -* End of PDTREECOMB -* - END -* - SUBROUTINE DCOMBAMAX( V1, V2 ) -* -* -- ScaLAPACK tools routine (version 1.0) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* February 28, 1995 -* -* .. Array Arguments .. - DOUBLE PRECISION V1( 2 ), V2( 2 ) -* .. -* -* Purpose -* == = ==== -* -* DCOMBAMAX finds the element having max. absolute value as well -* as its corresponding globl index. -* -* Arguments -* == = ====== -* -* V1 (local input/local output) DOUBLE PRECISION array of -* dimension 2. The first maximum absolute value element and -* its global index. V1(1) = AMAX, V1(2) = INDX. -* -* V2 (local input) DOUBLE PRECISION array of dimension 2. -* The second maximum absolute value element and its global -* index. V2(1) = AMAX, V2(2) = INDX. -* -* == = ================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( ABS( V1( 1 ) ).LT.ABS( V2( 1 ) ) ) THEN - V1( 1 ) = V2( 1 ) - V1( 2 ) = V2( 2 ) - END IF -* - RETURN -* -* End of DCOMBAMAX -* - END -* - SUBROUTINE DCOMBSSQ( V1, V2 ) -* -* -- ScaLAPACK tools routine (version 1.0) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* February 28, 1995 -* -* .. Array Arguments .. - DOUBLE PRECISION V1( 2 ), V2( 2 ) -* .. -* -* Purpose -* == = ==== -* -* DCOMBSSQ does a scaled sum of squares on two scalars. -* -* Arguments -* == = ====== -* -* V1 (local input/local output) DOUBLE PRECISION array of -* dimension 2. The first scaled sum. V1(1) = SCALE, -* V1(2) = SUMSQ. -* -* V2 (local input) DOUBLE PRECISION array of dimension 2. -* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ. -* -* == = ================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* - IF( V1( 1 ).GE.V2( 1 ) ) THEN - IF( V1( 1 ).NE.ZERO ) - $ V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) - ELSE - V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) - V1( 1 ) = V2( 1 ) - END IF -* - RETURN -* -* End of DCOMBSSQ -* - END -* - SUBROUTINE DCOMBNRM2( X, Y ) -* -* -- ScaLAPACK tools routine (version 1.0) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* February 28, 1995 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* == = ==== -* -* DCOMBNRM2 combines local norm 2 results, taking care not to cause -* unnecessary overflow. -* -* Arguments -* == = ====== -* -* X (local input) DOUBLE PRECISION -* Y (local input) DOUBLE PRECISION -* X and Y specify the values x and y. X and Y are supposed to -* be >= 0. -* -* == = ================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - W = MAX( X, Y ) - Z = MIN( X, Y ) -* - IF( Z.EQ.ZERO ) THEN - X = W - ELSE - X = W*SQRT( ONE+( Z / W )**2 ) - END IF -* - RETURN -* -* End of DCOMBNRM2 -* - END diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index e73be103..57314c2d 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -45,7 +45,10 @@ ! jx - integer(optional). The column offset for sub( X ). ! function psb_cnrm2(x, desc_a, info, jx) - use psb_sparse_mod, psb_protect_name => psb_cnrm2 + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod implicit none complex(psb_spk_), intent(in) :: x(:,:) @@ -59,7 +62,7 @@ function psb_cnrm2(x, desc_a, info, jx) & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm real(psb_spk_) :: nrm2, scnrm2, dd - external scombnrm2 +!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_cnrm2' @@ -71,7 +74,7 @@ function psb_cnrm2(x, desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -116,8 +119,9 @@ function psb_cnrm2(x, desc_a, info, jx) nrm2 = dzero end if - call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) - +!!$ call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + call psb_nrm2(ictxt,nrm2) + psb_cnrm2 = nrm2 call psb_erractionrestore(err_act) @@ -178,7 +182,10 @@ end function psb_cnrm2 ! info - integer. Return code ! function psb_cnrm2v(x, desc_a, info) - use psb_sparse_mod, psb_protect_name => psb_cnrm2v + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod implicit none complex(psb_spk_), intent(in) :: x(:) @@ -191,7 +198,7 @@ function psb_cnrm2v(x, desc_a, info) & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_spk_) :: nrm2, scnrm2, dd - external scombnrm2 +!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_cnrm2v' @@ -203,7 +210,7 @@ function psb_cnrm2v(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -243,7 +250,8 @@ function psb_cnrm2v(x, desc_a, info) nrm2 = dzero end if - call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) +!!$ call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + call psb_nrm2(ictxt,nrm2) psb_cnrm2v = nrm2 @@ -307,7 +315,10 @@ end function psb_cnrm2v ! info - integer. Return code ! subroutine psb_cnrm2vs(res, x, desc_a, info) - use psb_sparse_mod, psb_protect_name => psb_cnrm2vs + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod implicit none complex(psb_spk_), intent(in) :: x(:) @@ -320,7 +331,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_spk_) :: nrm2, scnrm2, dd - external scombnrm2 +!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_cnrm2' @@ -332,7 +343,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -372,8 +383,8 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) nrm2 = dzero end if - call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) - +!!$ call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + call psb_nrm2(ictxt,nrm2) res = nrm2 call psb_erractionrestore(err_act) diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 5bbc57da..9aabb36b 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -61,7 +61,7 @@ function psb_dnrm2(x, desc_a, info, jx) integer :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm real(psb_dpk_) :: nrm2, dnrm2, dd - external dcombnrm2 +!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2' @@ -73,7 +73,7 @@ function psb_dnrm2(x, desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -118,7 +118,8 @@ function psb_dnrm2(x, desc_a, info, jx) nrm2 = dzero end if - call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) +!!$ call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) + call psb_nrm2(ictxt,nrm2) psb_dnrm2 = nrm2 @@ -195,7 +196,7 @@ function psb_dnrm2v(x, desc_a, info) integer :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_dpk_) :: nrm2, dnrm2, dd - external dcombnrm2 +!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2v' @@ -207,7 +208,7 @@ function psb_dnrm2v(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -247,7 +248,8 @@ function psb_dnrm2v(x, desc_a, info) nrm2 = dzero end if - call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) +!!$ call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) + call psb_nrm2(ictxt,nrm2) psb_dnrm2v = nrm2 @@ -311,7 +313,10 @@ end function psb_dnrm2v ! info - integer. Return code ! subroutine psb_dnrm2vs(res, x, desc_a, info) - use psb_sparse_mod, psb_protect_name => psb_dnrm2vs + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod implicit none real(psb_dpk_), intent(in) :: x(:) @@ -323,7 +328,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) integer :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_dpk_) :: nrm2, dnrm2, dd - external dcombnrm2 +!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2' @@ -335,7 +340,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -375,7 +380,8 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) nrm2 = dzero end if - call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) +!!$ call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) + call psb_nrm2(ictxt,nrm2) res = nrm2 diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index 1388b327..3d1a3083 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -61,7 +61,7 @@ function psb_snrm2(x, desc_a, info, jx) integer :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm real(psb_spk_) :: nrm2, snrm2, dd - external scombnrm2 +!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_snrm2' @@ -73,7 +73,7 @@ function psb_snrm2(x, desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -118,7 +118,8 @@ function psb_snrm2(x, desc_a, info, jx) nrm2 = szero end if - call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) +!!$ call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + call psb_nrm2(ictxt,nrm2) psb_snrm2 = nrm2 @@ -195,8 +196,8 @@ function psb_snrm2v(x, desc_a, info) integer :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_spk_) :: nrm2, snrm2, dd - external scombnrm2 - character(len=20) :: name, ch_err +!!$ external scombnrm2 + character(len=20) :: name, ch_err name='psb_snrm2v' if(psb_get_errstatus() /= 0) return @@ -207,7 +208,7 @@ function psb_snrm2v(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -247,7 +248,8 @@ function psb_snrm2v(x, desc_a, info) nrm2 = szero end if - call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) +!!$ call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + call psb_nrm2(ictxt,nrm2) psb_snrm2v = nrm2 @@ -311,7 +313,10 @@ end function psb_snrm2v ! info - integer. Return code ! subroutine psb_snrm2vs(res, x, desc_a, info) - use psb_sparse_mod, psb_protect_name => psb_snrm2vs + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod implicit none real(psb_spk_), intent(in) :: x(:) @@ -323,7 +328,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info) integer :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_spk_) :: nrm2, snrm2, dd - external scombnrm2 +!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_snrm2' @@ -335,7 +340,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -375,7 +380,8 @@ subroutine psb_snrm2vs(res, x, desc_a, info) nrm2 = szero end if - call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) +!!$ call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + call psb_nrm2(ictxt,nrm2) res = nrm2 diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 9b18045a..2995358c 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -62,7 +62,7 @@ function psb_znrm2(x, desc_a, info, jx) & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm real(psb_dpk_) :: nrm2, dznrm2, dd - external dcombnrm2 +!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2' @@ -74,7 +74,7 @@ function psb_znrm2(x, desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -119,7 +119,8 @@ function psb_znrm2(x, desc_a, info, jx) nrm2 = dzero end if - call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) +!!$ call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) + call psb_nrm2(ictxt,nrm2) psb_znrm2 = nrm2 @@ -197,7 +198,7 @@ function psb_znrm2v(x, desc_a, info) & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_dpk_) :: nrm2, dznrm2, dd - external dcombnrm2 +!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2v' @@ -209,7 +210,7 @@ function psb_znrm2v(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -249,7 +250,8 @@ function psb_znrm2v(x, desc_a, info) nrm2 = dzero end if - call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) +!!$ call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) + call psb_nrm2(ictxt,nrm2) psb_znrm2v = nrm2 @@ -313,7 +315,10 @@ end function psb_znrm2v ! info - integer. Return code ! subroutine psb_znrm2vs(res, x, desc_a, info) - use psb_sparse_mod, psb_protect_name => psb_znrm2vs + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod implicit none complex(psb_dpk_), intent(in) :: x(:) @@ -326,7 +331,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(psb_dpk_) :: nrm2, dznrm2, dd - external dcombnrm2 +!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2' @@ -338,7 +343,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_blacs_error_ + info=psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -378,7 +383,8 @@ subroutine psb_znrm2vs(res, x, desc_a, info) nrm2 = dzero end if - call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) +!!$ call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) + call psb_nrm2(ictxt,nrm2) res = nrm2 diff --git a/base/psblas/pstreecomb.F b/base/psblas/pstreecomb.F deleted file mode 100644 index 683b804d..00000000 --- a/base/psblas/pstreecomb.F +++ /dev/null @@ -1,396 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C This file imported from ScaLAPACK. -C -C - SUBROUTINE PSTREECOMB( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, - $ SUBPTR ) -* -* -- ScaLAPACK tools routine (version 1.5) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* May 1, 1997 -* -* .. Scalar Arguments .. - CHARACTER SCOPE - INTEGER CDEST0, ICTXT, N, RDEST0 -* .. -* .. Array Arguments .. - REAL MINE( * ) -* .. -* .. Subroutine Arguments .. - EXTERNAL SUBPTR -* .. -* -* Purpose -* == = ==== -* -* PSTREECOMB does a 1-tree parallel combine operation on scalars, -* using the subroutine indicated by SUBPTR to perform the required -* computation. -* -* Arguments -* == = ====== -* -* ICTXT (global input) INTEGER -* The BLACS context handle, indicating the global context of -* the operation. The context itself is global. -* -* SCOPE (global input) CHARACTER -* The scope of the operation: 'Rowwise', 'Columnwise', or -* 'All'. -* -* N (global input) INTEGER -* The number of elements in MINE. N = 1 for the norm-2 -* computation and 2 for the sum of square. -* -* MINE (local input/global output) REAL array of -* dimension at least equal to N. The local data to use in the -* combine. -* -* RDEST0 (global input) INTEGER -* The process row to receive the answer. If RDEST0 = -1, -* every process in the scope gets the answer. -* -* CDEST0 (global input) INTEGER -* The process column to receive the answer. If CDEST0 = -1, -* every process in the scope gets the answer. -* -* SUBPTR (local input) Pointer to the subroutine to call to perform -* the required combine. -* -* == = ================================================================== -* -* .. Local Scalars .. - LOGICAL BCAST, RSCOPE, CSCOPE - INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL, - $ MYROW, MYDIST, MYDIST2, NP, NPCOL, NPROW, - $ RMSSG, TCDEST, TRDEST -* .. -* .. Local Arrays .. - REAL HIS( 2 ) -* .. -* .. External Subroutines .. -#if !defined(SERIAL_MPI) - EXTERNAL BLACS_GRIDINFO, SGEBR2D, SGEBS2D, - $ SGERV2D, SGESD2D -#endif -* .. -* .. External Functions .. - LOGICAL PSB_LSAME - EXTERNAL PSB_LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* See if everyone wants the answer (need to broadcast the answer) -* - BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) ) - IF( BCAST ) THEN - TRDEST = 0 - TCDEST = 0 - ELSE - TRDEST = RDEST0 - TCDEST = CDEST0 - END IF -#if !defined(SERIAL_MPI) - -* -* Get grid parameters. -* - CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) -* -* Figure scope-dependant variables, or report illegal scope -* - RSCOPE = PSB_LSAME( SCOPE, 'R' ) - CSCOPE = PSB_LSAME( SCOPE, 'C' ) -* - IF( RSCOPE ) THEN - IF( BCAST ) THEN - TRDEST = MYROW - ELSE IF( MYROW.NE.TRDEST ) THEN - RETURN - END IF - NP = NPCOL - MYDIST = MOD( NPCOL + MYCOL - TCDEST, NPCOL ) - ELSE IF( CSCOPE ) THEN - IF( BCAST ) THEN - TCDEST = MYCOL - ELSE IF( MYCOL.NE.TCDEST ) THEN - RETURN - END IF - NP = NPROW - MYDIST = MOD( NPROW + MYROW - TRDEST, NPROW ) - ELSE IF( PSB_LSAME( SCOPE, 'A' ) ) THEN - NP = NPROW * NPCOL - IAM = MYROW*NPCOL + MYCOL - DEST = TRDEST*NPCOL + TCDEST - MYDIST = MOD( NP + IAM - DEST, NP ) - ELSE - RETURN - END IF -* - IF( NP.LT.2 ) - $ RETURN -* - MYDIST2 = MYDIST - RMSSG = MYROW - CMSSG = MYCOL - I = 1 -* - 10 CONTINUE -* - IF( MOD( MYDIST, 2 ).NE.0 ) THEN -* -* If I am process that sends information -* - DIST = I * ( MYDIST - MOD( MYDIST, 2 ) ) -* -* Figure coordinates of dest of message -* - IF( RSCOPE ) THEN - CMSSG = MOD( TCDEST + DIST, NP ) - ELSE IF( CSCOPE ) THEN - RMSSG = MOD( TRDEST + DIST, NP ) - ELSE - CMSSG = MOD( DEST + DIST, NP ) - RMSSG = CMSSG / NPCOL - CMSSG = MOD( CMSSG, NPCOL ) - END IF -* - CALL SGESD2D( ICTXT, N, 1, MINE, N, RMSSG, CMSSG ) -* - GO TO 20 -* - ELSE -* -* If I am a process receiving information, figure coordinates -* of source of message -* - DIST = MYDIST2 + I - IF( RSCOPE ) THEN - CMSSG = MOD( TCDEST + DIST, NP ) - HISDIST = MOD( NP + CMSSG - TCDEST, NP ) - ELSE IF( CSCOPE ) THEN - RMSSG = MOD( TRDEST + DIST, NP ) - HISDIST = MOD( NP + RMSSG - TRDEST, NP ) - ELSE - CMSSG = MOD( DEST + DIST, NP ) - RMSSG = CMSSG / NPCOL - CMSSG = MOD( CMSSG, NPCOL ) - HISDIST = MOD( NP + RMSSG*NPCOL+CMSSG - DEST, NP ) - END IF -* - IF( MYDIST2.LT.HISDIST ) THEN -* -* If I have anyone sending to me -* - CALL SGERV2D( ICTXT, N, 1, HIS, N, RMSSG, CMSSG ) - CALL SUBPTR( MINE, HIS ) -* - END IF - MYDIST = MYDIST / 2 -* - END IF - I = I * 2 -* - IF( I.LT.NP ) - $ GO TO 10 -* - 20 CONTINUE -* - IF( BCAST ) THEN - IF( MYDIST2.EQ.0 ) THEN - CALL SGEBS2D( ICTXT, SCOPE, ' ', N, 1, MINE, N ) - ELSE - CALL SGEBR2D( ICTXT, SCOPE, ' ', N, 1, MINE, N, - $ TRDEST, TCDEST ) - END IF - END IF -#endif -* - RETURN -* -* End of PSTREECOMB -* - END -* - SUBROUTINE SCOMBAMAX( V1, V2 ) -* -* -- ScaLAPACK tools routine (version 1.5) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* May 1, 1997 -* -* .. Array Arguments .. - REAL V1( 2 ), V2( 2 ) -* .. -* -* Purpose -* == = ==== -* -* SCOMBAMAX finds the element having max. absolute value as well -* as its corresponding globl index. -* -* Arguments -* == = ====== -* -* V1 (local input/local output) REAL array of -* dimension 2. The first maximum absolute value element and -* its global index. V1(1) = AMAX, V1(2) = INDX. -* -* V2 (local input) REAL array of dimension 2. -* The second maximum absolute value element and its global -* index. V2(1) = AMAX, V2(2) = INDX. -* -* == = ================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( ABS( V1( 1 ) ).LT.ABS( V2( 1 ) ) ) THEN - V1( 1 ) = V2( 1 ) - V1( 2 ) = V2( 2 ) - END IF -* - RETURN -* -* End of SCOMBAMAX -* - END -* - SUBROUTINE SCOMBSSQ( V1, V2 ) -* -* -- ScaLAPACK tools routine (version 1.5) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* May 1, 1997 -* -* .. Array Arguments .. - REAL V1( 2 ), V2( 2 ) -* .. -* -* Purpose -* == = ==== -* -* SCOMBSSQ does a scaled sum of squares on two scalars. -* -* Arguments -* == = ====== -* -* V1 (local input/local output) REAL array of -* dimension 2. The first scaled sum. V1(1) = SCALE, -* V1(2) = SUMSQ. -* -* V2 (local input) REAL array of dimension 2. -* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ. -* -* == = ================================================================== -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* - IF( V1( 1 ).GE.V2( 1 ) ) THEN - IF( V1( 1 ).NE.ZERO ) - $ V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) - ELSE - V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) - V1( 1 ) = V2( 1 ) - END IF -* - RETURN -* -* End of SCOMBSSQ -* - END -* - SUBROUTINE SCOMBNRM2( X, Y ) -* -* -- ScaLAPACK tools routine (version 1.5) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* May 1, 1997 -* -* .. Scalar Arguments .. - REAL X, Y -* .. -* -* Purpose -* == = ==== -* -* SCOMBNRM2 combines local norm 2 results, taking care not to cause -* unnecessary overflow. -* -* Arguments -* == = ====== -* -* X (local input) REAL -* Y (local input) REAL -* X and Y specify the values x and y. X and Y are supposed to -* be >= 0. -* -* == = ================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - REAL W, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - W = MAX( X, Y ) - Z = MIN( X, Y ) -* - IF( Z.EQ.ZERO ) THEN - X = W - ELSE - X = W*SQRT( ONE+( Z / W )**2 ) - END IF -* - RETURN -* -* End of SCOMBNRM2 -* - END diff --git a/configure b/configure index 4f01c123..cc555ed8 100755 --- a/configure +++ b/configure @@ -649,7 +649,6 @@ PSBLASRULES FINCLUDES CINCLUDES METIS_LIBS -BLACS_LIBS INSTALL_DOCSDIR INSTALL_INCLUDEDIR INSTALL_LIBDIR @@ -785,7 +784,6 @@ with_module_path enable_dependency_tracking with_blas with_lapack -with_blacs with_metis ' ac_precious_vars='build_alias @@ -1459,8 +1457,6 @@ Optional Packages: prepend to MODULE_PATH --with-blas= use BLAS library --with-lapack= use LAPACK library - --with-blacs=LIB Specify BLACSLIBNAME or -lBLACSLIBNAME or the - absolute library filename. --with-metis=LIB Specify -lMETISLIBNAME or the absolute library filename. @@ -7001,7 +6997,7 @@ if test "X$CCOPT" == "X" ; then CCOPT="-O2 $CCOPT" fi fi -CFLAGS="${CCOPT}" +#CFLAGS="${CCOPT}" if test "X$FCOPT" == "X" ; then if test "X$psblas_cv_fc" == "Xgcc" ; then @@ -7010,7 +7006,7 @@ if test "X$FCOPT" == "X" ; then FCOPT="-O3 $FCOPT" elif test "X$psblas_cv_fc" == X"xlf" ; then # XL compiler : consider using -qarch=auto - FCOPT="-O3 -qarch=auto $FCOPT" + FCOPT="-O3 -qarch=auto -qfixed -qsuffix=f=f:cpp=F $FCOPT" elif test "X$psblas_cv_fc" == X"ifc" ; then # other compilers .. FCOPT="-O3 $FCOPT" @@ -7033,7 +7029,7 @@ if test "X$psblas_cv_fc" == X"nag" ; then # Add needed options FCOPT="$FCOPT -dcfuns -f2003 -wmismatch=mpi_scatterv,mpi_alltoallv,mpi_gatherv,mpi_allgatherv" fi -FFLAGS="${FCOPT}" +#FFLAGS="${FCOPT}" if test "X$F90COPT" == "X" ; then if test "X$psblas_cv_fc" == "Xgcc" ; then @@ -7042,7 +7038,7 @@ if test "X$F90COPT" == "X" ; then F90COPT="-O3 $F90COPT" elif test "X$psblas_cv_fc" == X"xlf" ; then # XL compiler : consider using -qarch=auto - F90COPT="-O3 -qarch=auto $F90COPT" + F90COPT="-O3 -qarch=auto -qsuffix=f=f90:cpp=F90 $F90COPT" elif test "X$psblas_cv_fc" == X"ifc" ; then # other compilers .. F90COPT="-O3 $F90COPT" @@ -7067,59 +7063,30 @@ if test "X$psblas_cv_fc" == X"nag" ; then F90COPT="$F90COPT -dcfuns -f2003 -wmismatch=mpi_scatterv,mpi_alltoallv,mpi_gatherv,mpi_allgatherv" EXTRA_OPT="-mismatch_all" F03COPT="${F90COPT}" + F03="nagfor" +elif test "X$psblas_cv_fc" == X"xlf" ; then + F03="xlf2003_r" + F03COPT="-O3 -qarch=auto -qsuffix=f=f03:cpp=F03 $F03COPT" else + F03=${FC} F03COPT="${F90COPT}" fi -FCFLAGS="${F90COPT}" +#FCFLAGS="${F90COPT}" # COPT,FCOPT, F90COPT are aliases for FFLAGS,CFLAGS,FCFLAGS . ############################################################################## # Compilers variables selection ############################################################################## -if test "X$psblas_cv_fc" == X"xlf" ; then - # WARNING : this is EVIL : specifying a pathname prefixed compiler will be ignored! - # But this is necessary since : - # - if called from some script, xlf could behave strangely - # - it is not said that mpxlf95 gets chosen by the configure script. - F90="xlf95 -qsuffix=f=f90:cpp=F90" - F03="xlf2003_r -qsuffix=f=f03:cpp=F03" - # F90="xlf95" -# FC="xlf" - -# Note : this gives problems in base/serial/aux/isaperm.f -# FC="mpxlf -qsuffix=f=f90:cpp=F90" - -# Note : this is the cure - FC="xlf -qsuffix=f=f:cpp=F" - # Note : maybe we will want xlf -qsuffix=cpp=F - F77="xlf" - CC="xlc" - if test x"$pac_cv_serial_mpi" == x"yes" ; then - MPF90="xlf2003_r -qsuffix=f=f90:cpp=F90" - MPF77="xlf95 -qfixed -qsuffix=f=f:cpp=F" - MPCC="xlc" - else - MPF90="mpxlf2003_r -qsuffix=f=f90:cpp=F90" - MPF77="mpxlf95 -qfixed -qsuffix=f=f:cpp=F" - MPCC="mpcc" - fi - #MPFCC="mpxlc" - # Note : -qfixed should be not specified in the environment FFLAGS or things will break. - # This fact should be documented somewhere. -else - # We really think about the GCC here but this is our idea for other compilers, too. - # If the user wishes to, she should specify MPICC, MPIF77 after ./configure. - # Note: this behavious should be documented. - F90=${FC} - F03=${FC} - MPF90=${MPIFC} - FC=${FC} - MPF77=${MPIFC} - CC=${CC} - MPCC=${MPICC} -fi +F90=${FC} +F03=${F03} +MPF90=${MPIFC} +FC=${FC} +MPF77=${MPIFC} +CC=${CC} +MPCC=${MPICC} + ############################################################################## @@ -10257,93 +10224,92 @@ fi ############################################################################### # BLACS library presence checks ############################################################################### -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu +#AC_LANG([C]) +#if test x"$pac_cv_serial_mpi" == x"no" ; then +#save_FC="$FC"; +#save_CC="$CC"; +#FC="$MPIFC"; +#CC="$MPICC"; +#PAC_CHECK_BLACS +#FC="$save_FC"; +#CC="$save_CC"; +#fi -if test x"$pac_cv_serial_mpi" == x"no" ; then -save_FC="$FC"; -save_CC="$CC"; -FC="$MPIFC"; -CC="$MPICC"; -# Check whether --with-blacs was given. -if test "${with_blacs+set}" = set; then - withval=$with_blacs; psblas_cv_blacs=$withval +{ $as_echo "$as_me:$LINENO: checking for gnumake" >&5 +$as_echo_n "checking for gnumake... " >&6; } +MAKE=${MAKE:-make} + +if $MAKE --version 2>&1 | grep -e"GNU Make" >/dev/null; then + { $as_echo "$as_me:$LINENO: result: yes" >&5 +$as_echo "yes" >&6; } + psblas_make_gnumake='yes' else - psblas_cv_blacs='' + { $as_echo "$as_me:$LINENO: result: no" >&5 +$as_echo "no" >&6; } + psblas_make_gnumake='no' fi -case $psblas_cv_blacs in - yes | "") ;; - -* | */* | *.a | *.so | *.so.* | *.o) - BLACS_LIBS="$psblas_cv_blacs" ;; - *) BLACS_LIBS="-l$psblas_cv_blacs" ;; -esac +############################################################################### +# METIS, SuperLU, SuperLU_Dist UMFPack libraries presence checks +############################################################################### -# -# Test user-defined BLACS -# -if test x"$psblas_cv_blacs" != "x" ; then - save_LIBS="$LIBS"; - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu +# Note : also SuperLUStat,superlu_gridexit,.. +# Note : SuperLU_Dist produces superlu.a by default.. +# Note : THESE WERE NOT TESTED +#AC_CHECK_LIB(superlu,[superlu_malloc_dist],psblas_cv_have_superludist=yes,psblas_cv_have_superludist=no) +#AC_CHECK_LIB(superlu,[superlu_malloc],psblas_cv_have_superlu=yes,psblas_cv_have_superlu=no) +# Note : also umfdi_local_search, ... +#AC_CHECK_LIB(umf,umfpack_di_solve,psblas_cv_have_umfpack=yes,psblas_cv_have_umfpack=no,[amd]) - LIBS="$BLACS_LIBS $LIBS" - { $as_echo "$as_me:$LINENO: checking for dgesd2d in $BLACS_LIBS" >&5 -$as_echo_n "checking for dgesd2d in $BLACS_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF - program main - call dgesd2d - end -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - psblas_cv_blacs_ok=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - psblas_cv_blacs_ok=no;BLACS_LIBS="" +# Check whether --with-metis was given. +if test "${with_metis+set}" = set; then + withval=$with_metis; psblas_cv_metis=$withval +else + psblas_cv_metis='' fi -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $psblas_cv_blacs_ok" >&5 -$as_echo "$psblas_cv_blacs_ok" >&6; } - if test x"$psblas_cv_blacs_ok" == x"yes"; then - { $as_echo "$as_me:$LINENO: checking for blacs_pinfo in $BLACS_LIBS" >&5 -$as_echo_n "checking for blacs_pinfo in $BLACS_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF - program main - call blacs_pinfo - end + +if test "x$psblas_cv_metis" != "x" ; then + { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in -l\"m\"" >&5 +$as_echo_n "checking for METIS_PartGraphRecursive in -l\"m\"... " >&6; } +if test "${ac_cv_lib__m__METIS_PartGraphRecursive+set}" = set; then + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-l"m" "$psblas_cv_metis" $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char METIS_PartGraphRecursive (); +#ifdef F77_DUMMY_MAIN + +# ifdef __cplusplus + extern "C" +# endif + int F77_DUMMY_MAIN() { return 1; } + +#endif +int +main () +{ +return METIS_PartGraphRecursive (); + ; + return 0; +} _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" @@ -10360,63 +10326,72 @@ $as_echo "$ac_try_echo") >&5 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || + test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then - psblas_cv_blacs_ok=yes + ac_cv_lib__m__METIS_PartGraphRecursive=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - psblas_cv_blacs_ok=no;BLACS_LIBS="" + ac_cv_lib__m__METIS_PartGraphRecursive=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $psblas_cv_blacs_ok" >&5 -$as_echo "$psblas_cv_blacs_ok" >&6; } - fi - LIBS="$save_LIBS"; +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib__m__METIS_PartGraphRecursive" >&5 +$as_echo "$ac_cv_lib__m__METIS_PartGraphRecursive" >&6; } +if test "x$ac_cv_lib__m__METIS_PartGraphRecursive" = x""yes; then + psblas_cv_have_metis=yes; METIS_LIBS="$psblas_cv_metis" +else + psblas_cv_have_metis=no fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -###################################### -# System BLACS with PESSL default names. -###################################### -if test x"$BLACS_LIBS" == "x" ; then - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - pac_check_libs_ok=no - for pac_check_libs_f in dgesd2d - do - for pac_check_libs_l in blacssmp blacsp2 blacs - do - if test x"$pac_check_libs_ok" == xno ; then - as_ac_Lib=`$as_echo "ac_cv_lib_$pac_check_libs_l''_$pac_check_libs_f" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $pac_check_libs_f in -l$pac_check_libs_l" >&5 -$as_echo_n "checking for $pac_check_libs_f in -l$pac_check_libs_l... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +else + save_LIBS="$LIBS"; + LIBS="-lm $LIBS"; + { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in -lmetis" >&5 +$as_echo_n "checking for METIS_PartGraphRecursive in -lmetis... " >&6; } +if test "${ac_cv_lib_metis_METIS_PartGraphRecursive+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS -LIBS="-l$pac_check_libs_l $LIBS" +LIBS="-lmetis $LIBS" cat >conftest.$ac_ext <<_ACEOF - program main - call $pac_check_libs_f - end +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char METIS_PartGraphRecursive (); +#ifdef F77_DUMMY_MAIN + +# ifdef __cplusplus + extern "C" +# endif + int F77_DUMMY_MAIN() { return 1; } + +#endif +int +main () +{ +return METIS_PartGraphRecursive (); + ; + return 0; +} _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" @@ -10433,18 +10408,18 @@ $as_echo "$ac_try_echo") >&5 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || + test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then - eval "$as_ac_Lib=yes" + ac_cv_lib_metis_METIS_PartGraphRecursive=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - eval "$as_ac_Lib=no" + ac_cv_lib_metis_METIS_PartGraphRecursive=no fi rm -rf conftest.dSYM @@ -10452,743 +10427,38 @@ rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then - pac_check_libs_ok=yes; pac_check_libs_LIBS="-l$pac_check_libs_l" +{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_metis_METIS_PartGraphRecursive" >&5 +$as_echo "$ac_cv_lib_metis_METIS_PartGraphRecursive" >&6; } +if test "x$ac_cv_lib_metis_METIS_PartGraphRecursive" = x""yes; then + psblas_cv_have_metis=yes;METIS_LIBS="-lmetis" +else + psblas_cv_have_metis=no fi - fi - done - done - # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: - if test x"$pac_check_libs_ok" = xyes ; then - psblas_cv_blacs_ok=yes; LIBS="$LIBS $pac_check_libs_LIBS " - BLACS_LIBS="$pac_check_libs_LIBS" - { $as_echo "$as_me:$LINENO: BLACS libraries detected." >&5 -$as_echo "$as_me: BLACS libraries detected." >&6;} - else - pac_check_libs_ok=no + LIBS="$save_LIBS"; +fi +if test "x$psblas_cv_have_metis" == "xyes" ; then + FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_METIS" +fi - fi +# Note : We would like to detect PSBLAS, but this is complicated by the +# module symbols mangling rules, which are compiler specific ! +# +# Moreover, the PSBLAS doesn't have an installer, currently. - if test x"$BLACS_LIBS" != "x"; then - save_LIBS="$LIBS"; - LIBS="$BLACS_LIBS $LIBS" - { $as_echo "$as_me:$LINENO: checking for blacs_pinfo in $BLACS_LIBS" >&5 -$as_echo_n "checking for blacs_pinfo in $BLACS_LIBS... " >&6; } - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu +############################################################################### +# Library target directory and archive files. +############################################################################### - cat >conftest.$ac_ext <<_ACEOF - program main - call blacs_pinfo - end -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - psblas_cv_blacs_ok=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 +LIBDIR=lib +BASELIBNAME=libpsb_base.a +PRECLIBNAME=libpsb_prec.a +METHDLIBNAME=libpsb_krylov.a - psblas_cv_blacs_ok=no;BLACS_LIBS="" -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $psblas_cv_blacs_ok" >&5 -$as_echo "$psblas_cv_blacs_ok" >&6; } - LIBS="$save_LIBS"; - fi -fi -###################################### -# Maybe we're looking at PESSL BLACS?# -###################################### -if test x"$BLACS_LIBS" != "x" ; then - save_LIBS="$LIBS"; - LIBS="$BLACS_LIBS $LIBS" - { $as_echo "$as_me:$LINENO: checking for PESSL BLACS" >&5 -$as_echo_n "checking for PESSL BLACS... " >&6; } - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - cat >conftest.$ac_ext <<_ACEOF - program main - call esvemonp - end -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - psblas_cv_pessl_blacs=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_pessl_blacs=no -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $psblas_cv_pessl_blacs" >&5 -$as_echo "$psblas_cv_pessl_blacs" >&6; } - LIBS="$save_LIBS"; -fi -if test "x$psblas_cv_pessl_blacs" == "xyes"; then - FDEFINES="$psblas_cv_define_prepend-DHAVE_ESSL_BLACS $FDEFINES" -fi - - -############################################################################## -# Netlib BLACS library with default names -############################################################################## - -if test x"$BLACS_LIBS" == "x" ; then - save_LIBS="$LIBS"; - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - - pac_check_libs_ok=no - for pac_check_libs_f in dgesd2d - do - for pac_check_libs_l in blacs_MPI-LINUX-0 blacs_MPI-SP5-0 blacs_MPI-SP4-0 blacs_MPI-SP3-0 blacs_MPI-SP2-0 blacsCinit_MPI-ALPHA-0 blacsCinit_MPI-IRIX64-0 blacsCinit_MPI-RS6K-0 blacsCinit_MPI-SPP-0 blacsCinit_MPI-SUN4-0 blacsCinit_MPI-SUN4SOL2-0 blacsCinit_MPI-T3D-0 blacsCinit_MPI-T3E-0 - - do - if test x"$pac_check_libs_ok" == xno ; then - as_ac_Lib=`$as_echo "ac_cv_lib_$pac_check_libs_l''_$pac_check_libs_f" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $pac_check_libs_f in -l$pac_check_libs_l" >&5 -$as_echo_n "checking for $pac_check_libs_f in -l$pac_check_libs_l... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-l$pac_check_libs_l $LIBS" -cat >conftest.$ac_ext <<_ACEOF - program main - call $pac_check_libs_f - end -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - eval "$as_ac_Lib=yes" -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then - pac_check_libs_ok=yes; pac_check_libs_LIBS="-l$pac_check_libs_l" -fi - - fi - done - done - # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: - if test x"$pac_check_libs_ok" = xyes ; then - psblas_cv_blacs_ok=yes; LIBS="$LIBS $pac_check_libs_LIBS " - psblas_have_netlib_blacs=yes; - BLACS_LIBS="$pac_check_libs_LIBS" - { $as_echo "$as_me:$LINENO: BLACS libraries detected." >&5 -$as_echo "$as_me: BLACS libraries detected." >&6;} - else - pac_check_libs_ok=no - - - fi - - - - if test x"$BLACS_LIBS" != "x" ; then - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - - pac_check_libs_ok=no - for pac_check_libs_f in blacs_pinfo - do - for pac_check_libs_l in blacsF77init_MPI-LINUX-0 blacsF77init_MPI-SP5-0 blacsF77init_MPI-SP4-0 blacsF77init_MPI-SP3-0 blacsF77init_MPI-SP2-0 blacsF77init_MPI-ALPHA-0 blacsF77init_MPI-IRIX64-0 blacsF77init_MPI-RS6K-0 blacsF77init_MPI-SPP-0 blacsF77init_MPI-SUN4-0 blacsF77init_MPI-SUN4SOL2-0 blacsF77init_MPI-T3D-0 blacsF77init_MPI-T3E-0 - - do - if test x"$pac_check_libs_ok" == xno ; then - as_ac_Lib=`$as_echo "ac_cv_lib_$pac_check_libs_l''_$pac_check_libs_f" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $pac_check_libs_f in -l$pac_check_libs_l" >&5 -$as_echo_n "checking for $pac_check_libs_f in -l$pac_check_libs_l... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-l$pac_check_libs_l $LIBS" -cat >conftest.$ac_ext <<_ACEOF - program main - call $pac_check_libs_f - end -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - eval "$as_ac_Lib=yes" -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then - pac_check_libs_ok=yes; pac_check_libs_LIBS="-l$pac_check_libs_l" -fi - - fi - done - done - # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: - if test x"$pac_check_libs_ok" = xyes ; then - psblas_cv_blacs_ok=yes; LIBS="$pac_check_libs_LIBS $LIBS" - BLACS_LIBS="$pac_check_libs_LIBS $BLACS_LIBS" - { $as_echo "$as_me:$LINENO: Netlib BLACS Fortran initialization libraries detected." >&5 -$as_echo "$as_me: Netlib BLACS Fortran initialization libraries detected." >&6;} - else - pac_check_libs_ok=no - - - fi - - - fi - - if test x"$BLACS_LIBS" != "x" ; then - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - pac_check_libs_ok=no - for pac_check_libs_f in Cblacs_pinfo - do - for pac_check_libs_l in blacsCinit_MPI-LINUX-0 blacsCinit_MPI-SP5-0 blacsCinit_MPI-SP4-0 blacsCinit_MPI-SP3-0 blacsCinit_MPI-SP2-0 blacsCinit_MPI-ALPHA-0 blacsCinit_MPI-IRIX64-0 blacsCinit_MPI-RS6K-0 blacsCinit_MPI-SPP-0 blacsCinit_MPI-SUN4-0 blacsCinit_MPI-SUN4SOL2-0 blacsCinit_MPI-T3D-0 blacsCinit_MPI-T3E-0 - - do - if test x"$pac_check_libs_ok" == xno ; then - as_ac_Lib=`$as_echo "ac_cv_lib_$pac_check_libs_l''_$pac_check_libs_f" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $pac_check_libs_f in -l$pac_check_libs_l" >&5 -$as_echo_n "checking for $pac_check_libs_f in -l$pac_check_libs_l... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-l$pac_check_libs_l $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $pac_check_libs_f (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main () -{ -return $pac_check_libs_f (); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - eval "$as_ac_Lib=yes" -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then - pac_check_libs_ok=yes; pac_check_libs_LIBS="-l$pac_check_libs_l" -fi - - fi - done - done - # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: - if test x"$pac_check_libs_ok" = xyes ; then - psblas_cv_blacs_ok=yes; LIBS="$pac_check_libs_LIBS $LIBS" - BLACS_LIBS="$BLACS_LIBS $pac_check_libs_LIBS" - { $as_echo "$as_me:$LINENO: Netlib BLACS C initialization libraries detected." >&5 -$as_echo "$as_me: Netlib BLACS C initialization libraries detected." >&6;} - else - pac_check_libs_ok=no - - - fi - - - fi - LIBS="$save_LIBS"; -fi - -if test x"$BLACS_LIBS" == "x" ; then - { { $as_echo "$as_me:$LINENO: error: - No BLACS library detected! $PACKAGE_NAME will be unusable. - Please make sure a BLACS implementation is accessible (ex.: --with-blacs=\"-lblacsname -L/blacs/dir\" ) - " >&5 -$as_echo "$as_me: error: - No BLACS library detected! $PACKAGE_NAME will be unusable. - Please make sure a BLACS implementation is accessible (ex.: --with-blacs=\"-lblacsname -L/blacs/dir\" ) - " >&2;} - { (exit 1); exit 1; }; } -else - save_LIBS="$LIBS"; - LIBS="$BLACS_LIBS $LIBS" - { $as_echo "$as_me:$LINENO: checking for ksendid in $BLACS_LIBS" >&5 -$as_echo_n "checking for ksendid in $BLACS_LIBS... " >&6; } - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - cat >conftest.$ac_ext <<_ACEOF - program main - call ksendid - end -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - psblas_cv_have_sendid=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_sendid=no -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $psblas_cv_have_sendid" >&5 -$as_echo "$psblas_cv_have_sendid" >&6; } - LIBS="$save_LIBS" - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - if test "x$psblas_cv_have_sendid" == "xyes"; then - FDEFINES="$psblas_cv_define_prepend-DHAVE_KSENDID $FDEFINES" - fi -fi - -FC="$save_FC"; -CC="$save_CC"; -fi - - -{ $as_echo "$as_me:$LINENO: checking for gnumake" >&5 -$as_echo_n "checking for gnumake... " >&6; } -MAKE=${MAKE:-make} - -if $MAKE --version 2>&1 | grep -e"GNU Make" >/dev/null; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 -$as_echo "yes" >&6; } - psblas_make_gnumake='yes' -else - { $as_echo "$as_me:$LINENO: result: no" >&5 -$as_echo "no" >&6; } - psblas_make_gnumake='no' -fi - - -############################################################################### -# METIS, SuperLU, SuperLU_Dist UMFPack libraries presence checks -############################################################################### - -# Note : also SuperLUStat,superlu_gridexit,.. -# Note : SuperLU_Dist produces superlu.a by default.. -# Note : THESE WERE NOT TESTED -#AC_CHECK_LIB(superlu,[superlu_malloc_dist],psblas_cv_have_superludist=yes,psblas_cv_have_superludist=no) -#AC_CHECK_LIB(superlu,[superlu_malloc],psblas_cv_have_superlu=yes,psblas_cv_have_superlu=no) -# Note : also umfdi_local_search, ... -#AC_CHECK_LIB(umf,umfpack_di_solve,psblas_cv_have_umfpack=yes,psblas_cv_have_umfpack=no,[amd]) - - -# Check whether --with-metis was given. -if test "${with_metis+set}" = set; then - withval=$with_metis; psblas_cv_metis=$withval -else - psblas_cv_metis='' -fi - - - -if test "x$psblas_cv_metis" != "x" ; then - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in -l\"m\"" >&5 -$as_echo_n "checking for METIS_PartGraphRecursive in -l\"m\"... " >&6; } -if test "${ac_cv_lib__m__METIS_PartGraphRecursive+set}" = set; then - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-l"m" "$psblas_cv_metis" $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char METIS_PartGraphRecursive (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main () -{ -return METIS_PartGraphRecursive (); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - ac_cv_lib__m__METIS_PartGraphRecursive=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib__m__METIS_PartGraphRecursive=no -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib__m__METIS_PartGraphRecursive" >&5 -$as_echo "$ac_cv_lib__m__METIS_PartGraphRecursive" >&6; } -if test "x$ac_cv_lib__m__METIS_PartGraphRecursive" = x""yes; then - psblas_cv_have_metis=yes; METIS_LIBS="$psblas_cv_metis" -else - psblas_cv_have_metis=no -fi - -else - save_LIBS="$LIBS"; - LIBS="-lm $LIBS"; - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in -lmetis" >&5 -$as_echo_n "checking for METIS_PartGraphRecursive in -lmetis... " >&6; } -if test "${ac_cv_lib_metis_METIS_PartGraphRecursive+set}" = set; then - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmetis $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char METIS_PartGraphRecursive (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main () -{ -return METIS_PartGraphRecursive (); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - ac_cv_lib_metis_METIS_PartGraphRecursive=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_metis_METIS_PartGraphRecursive=no -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_metis_METIS_PartGraphRecursive" >&5 -$as_echo "$ac_cv_lib_metis_METIS_PartGraphRecursive" >&6; } -if test "x$ac_cv_lib_metis_METIS_PartGraphRecursive" = x""yes; then - psblas_cv_have_metis=yes;METIS_LIBS="-lmetis" -else - psblas_cv_have_metis=no -fi - - LIBS="$save_LIBS"; -fi -if test "x$psblas_cv_have_metis" == "xyes" ; then - FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_METIS" -fi - - - -# Note : We would like to detect PSBLAS, but this is complicated by the -# module symbols mangling rules, which are compiler specific ! -# -# Moreover, the PSBLAS doesn't have an installer, currently. - -############################################################################### -# Library target directory and archive files. -############################################################################### - -LIBDIR=lib -BASELIBNAME=libpsb_base.a -PRECLIBNAME=libpsb_prec.a -METHDLIBNAME=libpsb_krylov.a - -# Note: psb_util code will be compiled conditionally for METIS functionalities.. using HAVE_METIS -UTILLIBNAME=libpsb_util.a +# Note: psb_util code will be compiled conditionally for METIS functionalities.. using HAVE_METIS +UTILLIBNAME=libpsb_util.a ############################################################################### @@ -11229,7 +10499,7 @@ UTILLIBNAME=libpsb_util.a - +#AC_SUBST(BLACS_LIBS) @@ -11238,7 +10508,7 @@ UTILLIBNAME=libpsb_util.a if test "X$psblas_make_gnumake" == "Xyes" ; then PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) # Warning : these rules are only valid with GNU make! @@ -11276,7 +10546,7 @@ $(.mod).o: else PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) @@ -12644,7 +11914,6 @@ fi BLAS : ${BLAS_LIBS} - BLACS : ${BLACS_LIBS} METIS detected : ${psblas_cv_have_metis} @@ -12678,7 +11947,6 @@ $as_echo "$as_me: BLAS : ${BLAS_LIBS} - BLACS : ${BLACS_LIBS} METIS detected : ${psblas_cv_have_metis} diff --git a/configure.ac b/configure.ac index 028abd49..fca9a9ea 100755 --- a/configure.ac +++ b/configure.ac @@ -605,16 +605,16 @@ PAC_LAPACK( ############################################################################### # BLACS library presence checks ############################################################################### -AC_LANG([C]) -if test x"$pac_cv_serial_mpi" == x"no" ; then -save_FC="$FC"; -save_CC="$CC"; -FC="$MPIFC"; -CC="$MPICC"; -PAC_CHECK_BLACS -FC="$save_FC"; -CC="$save_CC"; -fi +#AC_LANG([C]) +#if test x"$pac_cv_serial_mpi" == x"no" ; then +#save_FC="$FC"; +#save_CC="$CC"; +#FC="$MPIFC"; +#CC="$MPICC"; +#PAC_CHECK_BLACS +#FC="$save_FC"; +#CC="$save_CC"; +#fi PAC_MAKE_IS_GNUMAKE @@ -705,7 +705,7 @@ AC_SUBST(INSTALL_INCLUDEDIR) AC_SUBST(INSTALL_DOCSDIR) AC_SUBST(BLAS_LIBS) -AC_SUBST(BLACS_LIBS) +#AC_SUBST(BLACS_LIBS) AC_SUBST(METIS_LIBS) AC_SUBST(LAPACK_LIBS) @@ -714,7 +714,7 @@ AC_SUBST(FINCLUDES) if test "X$psblas_make_gnumake" == "Xyes" ; then PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) # Warning : these rules are only valid with GNU make! @@ -752,7 +752,7 @@ $(.mod).o: else PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) @@ -828,7 +828,7 @@ dnl FCFLAGS : ${FCFLAGS} dnl ESSL/PESSL : ${psblas_cv_have_essl} / ${psblas_cv_have_pessl} BLAS : ${BLAS_LIBS} - BLACS : ${BLACS_LIBS} +dnl BLACS : ${BLACS_LIBS} METIS detected : ${psblas_cv_have_metis} dnl SuperLU detected : ${psblas_cv_have_superlu}