diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index e9466431..9a05f46f 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -35,9 +35,9 @@ ! This subroutine gathers pieces of a distributed dense matrix into a local one. ! ! Arguments: -! globx - cplx,dimension(:,:). The local matrix into which gather +! globx - complex,dimension(:,:). The local matrix into which gather ! the distributed pieces. -! locx - cplx,dimension(:,:). The local piece of the distributed +! locx - complex,dimension(:,:). The local piece of the distributed ! matrix to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Error code. @@ -57,8 +57,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx character(len=20) :: name, ch_err @@ -82,8 +82,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -115,9 +115,9 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -207,9 +207,9 @@ end subroutine psb_cgatherm ! This subroutine gathers pieces of a distributed dense vector into a local one. ! ! Arguments: -! globx - cplx,dimension(:). The local vector into which gather +! globx - complex,dimension(:). The local vector into which gather ! the distributed pieces. -! locx - cplx,dimension(:). The local piece of the distributed +! locx - complex,dimension(:). The local piece of the distributed ! vector to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Error code. @@ -230,8 +230,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx character(len=20) :: name, ch_err @@ -255,8 +255,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -279,9 +279,9 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -341,8 +341,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx complex(psb_spk_), allocatable :: llocx(:) character(len=20) :: name, ch_err @@ -366,8 +366,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -390,7 +390,7 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index e9c7d5da..836b8efa 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -67,9 +67,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_ + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx complex(psb_spk_),pointer :: iwork(:), xp(:,:) character :: tran_ character(len=20) :: name, ch_err @@ -129,9 +129,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else data_ = psb_comm_halo_ endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -148,9 +148,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then + if(alpha /= cone) then do i=0, k-1 - call cscal(nrow,alpha,x(:,jjx+i),1) + call cscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1) end do end if end if @@ -289,7 +289,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, & + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, & & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ complex(psb_spk_),pointer :: iwork(:) character :: tran_ @@ -333,9 +334,9 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) else imode = IOR(psb_swap_send_,psb_swap_recv_) endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -352,8 +353,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then - call cscal(nrow,alpha,x,ione) + if(alpha /= cone) then + call cscal(int(nrow,kind=psb_mpik_),alpha,x,ione) end if end if @@ -486,7 +487,7 @@ subroutine psb_chalo_vect(x,desc_a,info,alpha,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 index afd1ae0d..9fd83080 100644 --- a/base/comm/psb_covrl.f90 +++ b/base/comm/psb_covrl.f90 @@ -76,9 +76,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx complex(psb_spk_),pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err @@ -135,9 +135,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -177,7 +177,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) end if ! exchange overlap elements if(do_swap) then - xp => x(iix:size(x,1),jjx:jjx+k-1) + xp => x(iix:ldx,jjx:jjx+k-1) call psi_swapdata(mode_,k,cone,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if @@ -278,7 +278,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork, ldx complex(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -321,9 +321,9 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -403,7 +403,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork,ldx complex(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -453,7 +453,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index 4eba4f56..a6273209 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -62,10 +62,10 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& - & jlx, myrank, rootrank, c, pos + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,& + & jlx, c, pos complex(psb_spk_),allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err @@ -89,8 +89,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -128,8 +128,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -295,10 +295,9 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& - & rootrank, pos, ilx, jlx + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx complex(psb_spk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err @@ -325,8 +324,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -349,9 +348,9 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 98a94c79..53937209 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -18,10 +18,12 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer(psb_mpik_) :: ictxt,np,me, icomm, minfo + integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit @@ -53,8 +55,8 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& - & a_err='integer') + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if call loca%mv_to(loc_coo) @@ -70,15 +72,16 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep ndx = nzbr(me+1) call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,& & glob_coo%val,nzbr,idisp,& - & mpi_complex,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& + & mpi_complex,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_integer,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& + & psb_mpi_integer,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_integer,icomm,info) + & psb_mpi_integer,icomm,minfo) - if (info /= psb_success_) then + if (minfo /= psb_success_) then + info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 end if diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index c0e97e79..8e41c7a1 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -36,15 +36,14 @@ ! ! Arguments: ! globx - real,dimension(:,:). The local matrix into which gather -! the distributed pieces. +! the distributed pieces. ! locx - real,dimension(:,:). The local piece of the distributed -! matrix to be gathered. +! matrix to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. +! info - integer. Error code. ! iroot - integer. The process that has to own the ! global matrix. If -1 all ! the processes will have a copy. -! Default: -1. ! subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_dgatherm @@ -58,9 +57,10 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx + character(len=20) :: name, ch_err name='psb_dgatherm' @@ -82,8 +82,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -115,9 +115,9 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -131,7 +131,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:,:)=0.d0 + globx(:,:)=dzero do j=1,k do i=1,desc_a%get_local_rows() @@ -207,15 +207,16 @@ end subroutine psb_dgatherm ! This subroutine gathers pieces of a distributed dense vector into a local one. ! ! Arguments: -! globx - real,dimension(:). The local vector into which gather the -! distributed pieces. -! locx - real,dimension(:). The local piece of the ditributed +! globx - real,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - real,dimension(:). The local piece of the distributed ! vector to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! root - integer. The process that has to own the +! info - integer. Error code. +! iroot - integer. The process that has to own the ! global matrix. If -1 all ! the processes will have a copy. +! default: -1 ! subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_dgatherv @@ -229,8 +230,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx character(len=20) :: name, ch_err @@ -254,8 +255,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -272,15 +273,15 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - + k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -294,7 +295,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) goto 9999 end if - globx(:)=0.d0 + globx(:)=dzero do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) @@ -333,20 +334,20 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) implicit none type(psb_d_vect_type), intent(inout) :: locx - real(psb_dpk_), intent(out) :: globx(:) + real(psb_dpk_), intent(out) :: globx(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: iroot ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx real(psb_dpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_dgatherv' + name='psb_cgatherv' if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) @@ -365,8 +366,8 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -389,7 +390,7 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then @@ -408,7 +409,6 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) globx(:) = dzero llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = llocx(i) diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index 0993f5a9..e875aa57 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -67,9 +67,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_ + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx real(psb_dpk_),pointer :: iwork(:), xp(:,:) character :: tran_ character(len=20) :: name, ch_err @@ -129,9 +129,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else data_ = psb_comm_halo_ endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -148,9 +148,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then + if(alpha /= done) then do i=0, k-1 - call dscal(nrow,alpha,x(:,jjx+i),1) + call dscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1) end do end if end if @@ -289,7 +289,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, & + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, & & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ real(psb_dpk_),pointer :: iwork(:) character :: tran_ @@ -333,9 +334,9 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) else imode = IOR(psb_swap_send_,psb_swap_recv_) endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -352,8 +353,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then - call dscal(nrow,alpha,x,ione) + if(alpha /= done) then + call dscal(int(nrow,kind=psb_mpik_),alpha,x,ione) end if end if @@ -486,7 +487,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,alpha,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index e4f1a9f0..c8708bad 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -76,9 +76,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx real(psb_dpk_),pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err @@ -135,9 +135,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -177,7 +177,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) end if ! exchange overlap elements if(do_swap) then - xp => x(iix:size(x,1),jjx:jjx+k-1) + xp => x(iix:ldx,jjx:jjx+k-1) call psi_swapdata(mode_,k,done,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if @@ -278,7 +278,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork, ldx real(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -321,9 +321,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -403,7 +403,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork,ldx real(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -453,7 +453,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index 525cfe55..10d16d65 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -36,13 +36,13 @@ ! into pieces that are local to alle the processes. ! ! Arguments: -! globx - real,dimension(:,:). The global matrix to scatter. -! locx - real,dimension(:,:). The local piece of the ditributed matrix. +! globx - real,dimension(:,:). The global matrix to scatter. +! locx - real,dimension(:,:). The local piece of the distributed matrix. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Error code. -! iroot - integer(optional). The process that owns the global matrix. If -1 all -! the processes have a copy. Default -1. -! +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_dscatterm @@ -62,12 +62,12 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& - & jlx, myrank, rootrank, c, pos - real(psb_dpk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,& + & jlx, c, pos + real(psb_dpk_),allocatable :: scatterv(:) + integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -89,8 +89,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -128,8 +128,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -178,7 +178,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) displ(i)=displ(i-1)+all_dim(i-1) end do - ! root has to gather loc_glob from each process + ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -270,16 +270,15 @@ end subroutine psb_dscatterm ! into pieces that are local to alle the processes. ! ! Arguments: -! globx - real,dimension(:). The global vector to scatter. -! locx - real,dimension(:). The local piece of the ditributed vector. +! globx - real,dimension(:). The global vector to scatter. +! locx - real,dimension(:). The local piece of the ditributed vector. ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. +! info - integer. Return code ! iroot - integer(optional). The process that owns the global vector. If -1 all ! the processes have a copy. ! subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_dscatterv - #ifdef MPI_MOD use mpi #endif @@ -296,12 +295,11 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& - & rootrank, pos, ilx, jlx + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx real(psb_dpk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) + integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -326,8 +324,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -350,9 +348,9 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index ab4f640f..4ffde0ad 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -18,10 +18,12 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_d_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer(psb_mpik_) :: ictxt,np,me, icomm, minfo + integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit @@ -53,8 +55,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& - & a_err='integer') + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if call loca%mv_to(loc_coo) @@ -68,17 +70,18 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,mpi_double_precision,& + call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,& & glob_coo%val,nzbr,idisp,& - & mpi_double_precision,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& + & mpi_complex,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_integer,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& + & psb_mpi_integer,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_integer,icomm,info) + & psb_mpi_integer,icomm,minfo) - if (info /= psb_success_) then + if (minfo /= psb_success_) then + info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 end if diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index aa796057..7c090329 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -58,8 +58,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx character(len=20) :: name, ch_err @@ -82,8 +82,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -115,9 +115,9 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -229,8 +229,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx character(len=20) :: name, ch_err @@ -254,8 +254,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -278,9 +278,9 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 2e3a4694..76a10058 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -70,7 +70,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, k, maxk, liwork,& - & imode, err,data_ + & imode, err,data_, ldx integer(psb_ipk_), pointer :: xp(:,:), iwork(:) character :: tran_ character(len=20) :: name, ch_err @@ -103,7 +103,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) nrow = desc_a%get_local_rows() maxk=size(x,2)-ijx+1 - + if(present(ik)) then if(ik > maxk) then k=maxk @@ -133,8 +133,9 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) imode = IOR(psb_swap_send_,psb_swap_recv_) endif + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -186,7 +187,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) end if end if - xp => x(iix:size(x,1),jjx:jjx+k-1) + xp => x(iix:ldx,jjx:jjx+k-1) ! exchange halo elements if(tran_ == 'N') then call psi_swapdata(imode,k,izero,xp,& @@ -294,7 +295,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork, data_ + & err, liwork, data_,ldx integer(psb_ipk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err @@ -340,8 +341,9 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) imode = IOR(psb_swap_send_,psb_swap_recv_) endif + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index c9456e85..bd40799e 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -77,7 +77,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork + & mode_, err, liwork, ldx integer(psb_ipk_), pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err @@ -134,9 +134,9 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -278,7 +278,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork, ldx integer(psb_ipk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -321,9 +321,10 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index 5f225225..a69e99b5 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -60,10 +60,10 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) integer(psb_ipk_), intent(in), optional :: iroot ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& - & jlx, myrank, rootrank, c, pos + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,& + & jlx, c, pos integer(psb_ipk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err @@ -87,8 +87,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)= root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -126,8 +126,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -293,10 +293,9 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& - & rootrank, pos, ilx, jlx + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_ipk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err @@ -323,8 +322,8 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2) = root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -347,9 +346,9 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 166cae0c..cd67484b 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -36,15 +36,14 @@ ! ! Arguments: ! globx - real,dimension(:,:). The local matrix into which gather -! the distributed pieces. +! the distributed pieces. ! locx - real,dimension(:,:). The local piece of the distributed -! matrix to be gathered. +! matrix to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. +! info - integer. Error code. ! iroot - integer. The process that has to own the ! global matrix. If -1 all ! the processes will have a copy. -! Default: -1. ! subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_sgatherm @@ -58,9 +57,10 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx + character(len=20) :: name, ch_err name='psb_sgatherm' @@ -82,8 +82,8 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -115,9 +115,9 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -207,15 +207,16 @@ end subroutine psb_sgatherm ! This subroutine gathers pieces of a distributed dense vector into a local one. ! ! Arguments: -! globx - real,dimension(:). The local vector into which gather the -! distributed pieces. -! locx - real,dimension(:). The local piece of the ditributed +! globx - real,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - real,dimension(:). The local piece of the distributed ! vector to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! root - integer. The process that has to own the +! info - integer. Error code. +! iroot - integer. The process that has to own the ! global matrix. If -1 all ! the processes will have a copy. +! default: -1 ! subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_sgatherv @@ -229,8 +230,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx character(len=20) :: name, ch_err @@ -254,8 +255,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -272,15 +273,15 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - + k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -333,20 +334,20 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) implicit none type(psb_s_vect_type), intent(inout) :: locx - real(psb_spk_), intent(out) :: globx(:) + real(psb_spk_), intent(out) :: globx(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: iroot ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx real(psb_spk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_dgatherv' + name='psb_cgatherv' if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) @@ -365,8 +366,8 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -389,7 +390,7 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then @@ -408,7 +409,6 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) globx(:) = szero llocx = locx%get_vect() - do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = llocx(i) diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index a13caa49..610c5b2d 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -67,9 +67,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_ + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx real(psb_spk_),pointer :: iwork(:), xp(:,:) character :: tran_ character(len=20) :: name, ch_err @@ -129,9 +129,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else data_ = psb_comm_halo_ endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -148,9 +148,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then + if(alpha /= sone) then do i=0, k-1 - call sscal(nrow,alpha,x(:,jjx+i),1) + call sscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1) end do end if end if @@ -289,7 +289,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, & + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, & & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ real(psb_spk_),pointer :: iwork(:) character :: tran_ @@ -333,9 +334,9 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) else imode = IOR(psb_swap_send_,psb_swap_recv_) endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -352,8 +353,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then - call sscal(nrow,alpha,x,ione) + if(alpha /= sone) then + call sscal(int(nrow,kind=psb_mpik_),alpha,x,ione) end if end if @@ -486,7 +487,7 @@ subroutine psb_shalo_vect(x,desc_a,info,alpha,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 index 239bd927..605e0113 100644 --- a/base/comm/psb_sovrl.f90 +++ b/base/comm/psb_sovrl.f90 @@ -76,9 +76,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx real(psb_spk_),pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err @@ -135,9 +135,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -177,7 +177,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) end if ! exchange overlap elements if(do_swap) then - xp => x(iix:size(x,1),jjx:jjx+k-1) + xp => x(iix:ldx,jjx:jjx+k-1) call psi_swapdata(mode_,k,sone,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if @@ -278,7 +278,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork, ldx real(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -321,9 +321,9 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -403,7 +403,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork,ldx real(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -453,7 +453,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index b5c6cada..7689d041 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -36,16 +36,16 @@ ! into pieces that are local to alle the processes. ! ! Arguments: -! globx - real,dimension(:,:). The global matrix to scatter. -! locx - real,dimension(:,:). The local piece of the ditributed matrix. +! globx - real,dimension(:,:). The global matrix to scatter. +! locx - real,dimension(:,:). The local piece of the distributed matrix. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Error code. -! iroot - integer(optional). The process that owns the global matrix. If -1 all -! the processes have a copy. Default -1. -! -subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_sscatterm +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_sscatterm #ifdef MPI_MOD use mpi #endif @@ -62,12 +62,12 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& - & jlx, myrank, rootrank, c, pos - real(psb_spk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,& + & jlx, c, pos + real(psb_spk_),allocatable :: scatterv(:) + integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err name='psb_scatterm' @@ -89,8 +89,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -128,8 +128,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -178,7 +178,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) displ(i)=displ(i-1)+all_dim(i-1) end do - ! root has to gather loc_glob from each process + ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -270,10 +270,10 @@ end subroutine psb_sscatterm ! into pieces that are local to alle the processes. ! ! Arguments: -! globx - real,dimension(:). The global vector to scatter. -! locx - real,dimension(:). The local piece of the ditributed vector. +! globx - real,dimension(:). The global vector to scatter. +! locx - real,dimension(:). The local piece of the ditributed vector. ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. +! info - integer. Return code ! iroot - integer(optional). The process that owns the global vector. If -1 all ! the processes have a copy. ! @@ -295,12 +295,11 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& - & rootrank, pos, ilx, jlx + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx real(psb_spk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) + integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -325,8 +324,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -349,9 +348,9 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index 1f3ce762..2dc719cc 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -18,10 +18,12 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer(psb_mpik_) :: ictxt,np,me, icomm, minfo + integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit @@ -53,8 +55,8 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& - & a_err='integer') + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if call loca%mv_to(loc_coo) @@ -68,17 +70,18 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,mpi_real,& + call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,& & glob_coo%val,nzbr,idisp,& - & mpi_real,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& + & mpi_complex,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_integer,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& + & psb_mpi_integer,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_integer,icomm,info) + & psb_mpi_integer,icomm,minfo) - if (info /= psb_success_) then + if (minfo /= psb_success_) then + info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 end if diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index f767afc2..e80d1b0a 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -35,9 +35,9 @@ ! This subroutine gathers pieces of a distributed dense matrix into a local one. ! ! Arguments: -! globx - cplx,dimension(:,:). The local matrix into which gather +! globx - complex,dimension(:,:). The local matrix into which gather ! the distributed pieces. -! locx - cplx,dimension(:,:). The local piece of the distributed +! locx - complex,dimension(:,:). The local piece of the distributed ! matrix to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Error code. @@ -57,8 +57,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx character(len=20) :: name, ch_err @@ -82,8 +82,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -115,9 +115,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -207,9 +207,9 @@ end subroutine psb_zgatherm ! This subroutine gathers pieces of a distributed dense vector into a local one. ! ! Arguments: -! globx - cplx,dimension(:). The local vector into which gather +! globx - complex,dimension(:). The local vector into which gather ! the distributed pieces. -! locx - cplx,dimension(:). The local piece of the distributed +! locx - complex,dimension(:). The local piece of the distributed ! vector to be gathered. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Error code. @@ -230,8 +230,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx character(len=20) :: name, ch_err @@ -255,8 +255,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -279,9 +279,9 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -341,8 +341,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, n, root, ilocx, iglobx, jlocx,& + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx complex(psb_dpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err @@ -366,8 +366,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -390,7 +390,7 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index f6560cda..31cbedbf 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -67,9 +67,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_ + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx complex(psb_dpk_),pointer :: iwork(:), xp(:,:) character :: tran_ character(len=20) :: name, ch_err @@ -129,9 +129,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else data_ = psb_comm_halo_ endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -148,9 +148,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then + if(alpha /= zone) then do i=0, k-1 - call zscal(nrow,alpha,x(:,jjx+i),1) + call zscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1) end do end if end if @@ -289,7 +289,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, & + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, & & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ complex(psb_dpk_),pointer :: iwork(:) character :: tran_ @@ -333,9 +334,9 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) else imode = IOR(psb_swap_send_,psb_swap_recv_) endif - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -352,8 +353,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha /= 1.d0) then - call zscal(nrow,alpha,x,ione) + if(alpha /= zone) then + call zscal(int(nrow,kind=psb_mpik_),alpha,x,ione) end if end if @@ -486,7 +487,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,alpha,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 7ad7e1ca..840d0058 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -76,9 +76,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx complex(psb_dpk_),pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err @@ -135,9 +135,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -177,7 +177,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) end if ! exchange overlap elements if(do_swap) then - xp => x(iix:size(x,1),jjx:jjx+k-1) + xp => x(iix:ldx,jjx:jjx+k-1) call psi_swapdata(mode_,k,zone,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if @@ -278,7 +278,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork, ldx complex(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -321,9 +321,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) - + ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -403,7 +403,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork + & mode_, err, liwork,ldx complex(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err @@ -453,7 +453,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index 058d979f..6697c8e6 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -44,6 +44,7 @@ ! If -1 all the processes have a copy. ! Default -1 subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_zscatterm #ifdef MPI_MOD use mpi @@ -61,10 +62,10 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me,& - & err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& - & jlx, myrank, rootrank, c, pos + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,& + & jlx, c, pos complex(psb_dpk_),allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err @@ -88,8 +89,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -127,8 +128,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' @@ -294,10 +295,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_ipk_) :: int_err(5), ictxt, np, me, & - & err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& - & rootrank, pos, ilx, jlx + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx complex(psb_dpk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) character(len=20) :: name, ch_err @@ -324,8 +324,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) root = iroot if((root < -1).or.(root > np)) then info=psb_err_input_value_invalid_i_ - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else @@ -348,9 +348,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) k = 1 ! there should be a global check on k here!!! - call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) if (info == psb_success_) & - & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index b1432616..14b90a30 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -18,10 +18,12 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer(psb_mpik_) :: ictxt,np,me, icomm, minfo + integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit @@ -53,12 +55,12 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& - & a_err='integer') + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if call loca%mv_to(loc_coo) - nzbr(:) = 0 + nzbr(:) = 0 nzbr(me+1) = loc_coo%get_nzeros() call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) @@ -68,17 +70,18 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(loc_coo%val,ndx,mpi_double_complex,& + call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,& & glob_coo%val,nzbr,idisp,& - & mpi_double_complex,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& + & mpi_complex,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_integer,icomm,info) - if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& + & psb_mpi_integer,icomm,minfo) + if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_integer,icomm,info) + & psb_mpi_integer,icomm,minfo) - if (info /= psb_success_) then + if (minfo /= psb_success_) then + info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 end if diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index ddbe4ce1..7d609e9b 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -156,7 +156,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_cswapdatam -subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidxm use psb_error_mod @@ -170,20 +170,21 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:,:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -197,7 +198,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -303,9 +305,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_complex,rcvbuf,rvsz,& & brvidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -371,7 +373,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 @@ -395,9 +397,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -420,9 +422,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -653,7 +655,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswapdatav -subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidxv use psb_error_mod @@ -667,21 +669,21 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -695,7 +697,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -801,9 +804,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_complex,rcvbuf,rvsz,& & brvidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -866,7 +869,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -890,9 +893,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -913,9 +916,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1087,7 +1090,7 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswapdata_vect -subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidx_vect use psb_error_mod @@ -1102,7 +1105,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y complex(psb_spk_) :: beta @@ -1110,14 +1113,14 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1131,7 +1134,8 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1237,9 +1241,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo & mpi_complex,rcvbuf,rvsz,& & brvidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1302,7 +1306,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1326,9 +1330,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1349,9 +1353,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 25ffaae3..a3e9087f 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -111,7 +111,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -161,7 +161,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_cswaptranm -subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidxm use psb_error_mod @@ -175,20 +175,27 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:,:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_ +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -202,6 +209,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -314,9 +323,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_complex,& & sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -379,7 +388,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -402,9 +411,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -426,9 +435,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -606,7 +615,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -657,7 +666,7 @@ end subroutine psi_cswaptranv -subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidxv use psb_error_mod @@ -671,20 +680,27 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_, n +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -698,6 +714,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -809,9 +827,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_complex,& & sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -874,7 +892,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -897,9 +915,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -920,9 +938,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1049,7 +1067,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1100,7 +1118,7 @@ end subroutine psi_cswaptran_vect -subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& +subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidx_vect @@ -1116,7 +1134,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y complex(psb_spk_) :: beta @@ -1124,13 +1142,14 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1144,6 +1163,8 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -1255,9 +1276,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& & mpi_complex,& & sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1320,7 +1341,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1343,9 +1364,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1366,9 +1387,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 75bd45ce..a8bfbb4c 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -156,7 +156,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_dswapdatam -subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidxm use psb_error_mod @@ -170,20 +170,21 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:,:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -197,7 +198,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -303,9 +305,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_double_precision,rcvbuf,rvsz,& & brvidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -371,7 +373,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 @@ -395,9 +397,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -420,9 +422,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -653,7 +655,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswapdatav -subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidxv use psb_error_mod @@ -667,21 +669,21 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -695,7 +697,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -801,9 +804,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_double_precision,rcvbuf,rvsz,& & brvidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -866,7 +869,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -890,9 +893,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -913,9 +916,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1087,7 +1090,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswapdata_vect -subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidx_vect use psb_error_mod @@ -1102,7 +1105,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y real(psb_dpk_) :: beta @@ -1110,14 +1113,14 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1131,7 +1134,8 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1237,9 +1241,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo & mpi_double_precision,rcvbuf,rvsz,& & brvidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1302,7 +1306,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1326,9 +1330,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1349,9 +1353,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 4060d0e4..4767103c 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -111,7 +111,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -161,7 +161,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_dswaptranm -subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidxm use psb_error_mod @@ -175,20 +175,27 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:,:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_ +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -202,6 +209,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -314,9 +323,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_double_precision,& & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -379,7 +388,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -402,9 +411,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -426,9 +435,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -606,7 +615,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -657,7 +666,7 @@ end subroutine psi_dswaptranv -subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidxv use psb_error_mod @@ -671,20 +680,27 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_, n +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -698,6 +714,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -809,9 +827,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_double_precision,& & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -874,7 +892,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -897,9 +915,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -920,9 +938,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1049,7 +1067,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1100,7 +1118,7 @@ end subroutine psi_dswaptran_vect -subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& +subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidx_vect @@ -1116,7 +1134,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y real(psb_dpk_) :: beta @@ -1124,13 +1142,14 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1144,6 +1163,8 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -1255,9 +1276,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& & mpi_double_precision,& & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1320,7 +1341,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1343,9 +1364,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1366,9 +1387,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 8b72c229..7603d229 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -156,7 +156,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_iswapdatam -subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswapidxm use psb_error_mod @@ -170,20 +170,21 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: y(:,:), beta integer(psb_ipk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -197,7 +198,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -303,9 +305,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & psb_mpi_integer,rcvbuf,rvsz,& & brvidx,psb_mpi_integer,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -371,7 +373,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 @@ -395,9 +397,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -420,9 +422,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -653,7 +655,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswapdatav -subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswapidxv use psb_error_mod @@ -667,21 +669,21 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: y(:), beta integer(psb_ipk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -695,7 +697,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -801,9 +804,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & psb_mpi_integer,rcvbuf,rvsz,& & brvidx,psb_mpi_integer,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -866,7 +869,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -890,9 +893,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -913,9 +916,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1087,7 +1090,7 @@ end subroutine psi_iswapidxv !!$end subroutine psi_iswapdata_vect !!$ !!$ -!!$subroutine psi_iswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +!!$subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) !!$ !!$ use psi_mod, psb_protect_name => psi_iswapidx_vect !!$ use psb_error_mod @@ -1102,7 +1105,7 @@ end subroutine psi_iswapidxv !!$ include 'mpif.h' !!$#endif !!$ -!!$ integer(psb_ipk_), intent(in) :: ictxt,icomm,flag +!!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag !!$ integer(psb_ipk_), intent(out) :: info !!$ class(psb_i_base_vect_type) :: y !!$ integer(psb_ipk_) :: beta @@ -1110,14 +1113,14 @@ end subroutine psi_iswapidxv !!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv !!$ !!$ ! locals -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, totsnd_, totrcv_,& -!!$ & idx_pt, snd_pt, rcv_pt, n, pnti, data_ -!!$ -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ integer(psb_mpik_) :: ictxt, icomm, np, me,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +!!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& !!$ & sdsz, rvsz, prcid, rvhd, sdhd -!!$ integer(psb_ipk_) :: int_err(5) +!!$ integer(psb_ipk_) :: nesd, nerv,& +!!$ & err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: ierr(5) !!$ logical :: swap_mpi, swap_sync, swap_send, swap_recv,& !!$ & albf,do_send,do_recv !!$ logical, parameter :: usersend=.false. @@ -1131,7 +1134,8 @@ end subroutine psi_iswapidxv !!$ info=psb_success_ !!$ name='psi_swap_datav' !!$ call psb_erractionsave(err_act) -!!$ +!!$ ictxt = iictxt +!!$ icomm = iicomm !!$ call psb_info(ictxt,me,np) !!$ if (np == -1) then !!$ info=psb_err_context_error_ @@ -1237,9 +1241,9 @@ end subroutine psi_iswapidxv !!$ & psb_mpi_integer,rcvbuf,rvsz,& !!$ & brvidx,psb_mpi_integer,icomm,iret) !!$ if(iret /= mpi_success) then -!!$ int_err(1) = iret +!!$ ierr(1) = iret !!$ info=psb_err_mpi_error_ -!!$ call psb_errpush(info,name,i_err=int_err) +!!$ call psb_errpush(info,name,i_err=ierr) !!$ goto 9999 !!$ end if !!$ @@ -1302,7 +1306,7 @@ end subroutine psi_iswapidxv !!$ !!$ !!$ ! Then I post all the blocking sends -!!$ if (usersend) call mpi_barrier(icomm,info) +!!$ if (usersend) call mpi_barrier(icomm,iret) !!$ !!$ pnti = 1 !!$ snd_pt = 1 @@ -1326,9 +1330,9 @@ end subroutine psi_iswapidxv !!$ end if !!$ !!$ if(iret /= mpi_success) then -!!$ int_err(1) = iret +!!$ ierr(1) = iret !!$ info=psb_err_mpi_error_ -!!$ call psb_errpush(info,name,i_err=int_err) +!!$ call psb_errpush(info,name,i_err=ierr) !!$ goto 9999 !!$ end if !!$ end if @@ -1349,9 +1353,9 @@ end subroutine psi_iswapidxv !!$ if ((proc_to_comm /= me).and.(nerv>0)) then !!$ call mpi_wait(rvhd(i),p2pstat,iret) !!$ if(iret /= mpi_success) then -!!$ int_err(1) = iret +!!$ ierr(1) = iret !!$ info=psb_err_mpi_error_ -!!$ call psb_errpush(info,name,i_err=int_err) +!!$ call psb_errpush(info,name,i_err=ierr) !!$ goto 9999 !!$ end if !!$ else if (proc_to_comm == me) then @@ -1446,4 +1450,4 @@ end subroutine psi_iswapidxv !!$ end if !!$ return !!$end subroutine psi_iswapidx_vect - +!!$ diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index 011e99cb..0cbb2965 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -111,7 +111,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -161,7 +161,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_iswaptranm -subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_itranidxm use psb_error_mod @@ -175,20 +175,27 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: y(:,:), beta integer(psb_ipk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_ +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -202,6 +209,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -314,9 +323,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & psb_mpi_integer,& & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -379,7 +388,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -402,9 +411,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -426,9 +435,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -606,7 +615,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -657,7 +666,7 @@ end subroutine psi_iswaptranv -subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_itranidxv use psb_error_mod @@ -671,20 +680,27 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: y(:), beta integer(psb_ipk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_, n +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -698,6 +714,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -809,9 +827,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & psb_mpi_integer,& & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -874,7 +892,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -897,9 +915,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -920,9 +938,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1049,7 +1067,7 @@ end subroutine psi_itranidxv !!$ ! locals !!$ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ !!$ integer(psb_ipk_), pointer :: d_idx(:) -!!$ integer(psb_ipk_) :: int_err(5) +!!$ integer(psb_ipk_) :: ierr(5) !!$ character(len=20) :: name !!$ !!$ info=psb_success_ @@ -1100,7 +1118,7 @@ end subroutine psi_itranidxv !!$ !!$ !!$ -!!$subroutine psi_itranidx_vect(ictxt,icomm,flag,beta,y,idx,& +!!$subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,& !!$ & totxch,totsnd,totrcv,work,info) !!$ !!$ use psi_mod, psb_protect_name => psi_itranidx_vect @@ -1116,7 +1134,7 @@ end subroutine psi_itranidxv !!$ include 'mpif.h' !!$#endif !!$ -!!$ integer(psb_ipk_), intent(in) :: ictxt,icomm,flag +!!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag !!$ integer(psb_ipk_), intent(out) :: info !!$ class(psb_i_base_vect_type) :: y !!$ integer(psb_ipk_) :: beta @@ -1124,13 +1142,14 @@ end subroutine psi_itranidxv !!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv !!$ !!$ ! locals -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& -!!$ & snd_pt, rcv_pt, pnti, data_, n -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ integer(psb_mpik_) :: ictxt, icomm, np, me,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +!!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& !!$ & sdsz, rvsz, prcid, rvhd, sdhd -!!$ integer(psb_ipk_) :: int_err(5) +!!$ integer(psb_ipk_) :: nesd, nerv,& +!!$ & err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: ierr(5) !!$ logical :: swap_mpi, swap_sync, swap_send, swap_recv,& !!$ & albf,do_send,do_recv !!$ logical, parameter :: usersend=.false. @@ -1144,6 +1163,8 @@ end subroutine psi_itranidxv !!$ info=psb_success_ !!$ name='psi_swap_tran' !!$ call psb_erractionsave(err_act) +!!$ ictxt = iictxt +!!$ icomm = iicomm !!$ !!$ call psb_info(ictxt,me,np) !!$ if (np == -1) then @@ -1255,9 +1276,9 @@ end subroutine psi_itranidxv !!$ & psb_mpi_integer,& !!$ & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret) !!$ if(iret /= mpi_success) then -!!$ int_err(1) = iret +!!$ ierr(1) = iret !!$ info=psb_err_mpi_error_ -!!$ call psb_errpush(info,name,i_err=int_err) +!!$ call psb_errpush(info,name,i_err=ierr) !!$ goto 9999 !!$ end if !!$ @@ -1320,7 +1341,7 @@ end subroutine psi_itranidxv !!$ !!$ !!$ ! Then I post all the blocking sends -!!$ if (usersend) call mpi_barrier(icomm,info) +!!$ if (usersend) call mpi_barrier(icomm,iret) !!$ !!$ pnti = 1 !!$ snd_pt = 1 @@ -1343,9 +1364,9 @@ end subroutine psi_itranidxv !!$ end if !!$ !!$ if(iret /= mpi_success) then -!!$ int_err(1) = iret +!!$ ierr(1) = iret !!$ info=psb_err_mpi_error_ -!!$ call psb_errpush(info,name,i_err=int_err) +!!$ call psb_errpush(info,name,i_err=ierr) !!$ goto 9999 !!$ end if !!$ end if @@ -1366,9 +1387,9 @@ end subroutine psi_itranidxv !!$ if ((proc_to_comm /= me).and.(nesd>0)) then !!$ call mpi_wait(rvhd(i),p2pstat,iret) !!$ if(iret /= mpi_success) then -!!$ int_err(1) = iret +!!$ ierr(1) = iret !!$ info=psb_err_mpi_error_ -!!$ call psb_errpush(info,name,i_err=int_err) +!!$ call psb_errpush(info,name,i_err=ierr) !!$ goto 9999 !!$ end if !!$ else if (proc_to_comm == me) then diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index 332e34cc..d9f408a3 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -156,7 +156,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_sswapdatam -subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidxm use psb_error_mod @@ -170,20 +170,21 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:,:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -197,7 +198,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -303,9 +305,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_real,rcvbuf,rvsz,& & brvidx,mpi_real,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -371,7 +373,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 @@ -395,9 +397,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -420,9 +422,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -653,7 +655,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswapdatav -subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidxv use psb_error_mod @@ -667,21 +669,21 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -695,7 +697,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -801,9 +804,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_real,rcvbuf,rvsz,& & brvidx,mpi_real,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -866,7 +869,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -890,9 +893,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -913,9 +916,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1087,7 +1090,7 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswapdata_vect -subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidx_vect use psb_error_mod @@ -1102,7 +1105,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y real(psb_spk_) :: beta @@ -1110,14 +1113,14 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1131,7 +1134,8 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1237,9 +1241,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo & mpi_real,rcvbuf,rvsz,& & brvidx,mpi_real,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1302,7 +1306,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1326,9 +1330,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1349,9 +1353,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index 747b32ab..45a31ef6 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -111,7 +111,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -161,7 +161,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_sswaptranm -subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidxm use psb_error_mod @@ -175,20 +175,27 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:,:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_ +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -202,6 +209,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -314,9 +323,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_real,& & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -379,7 +388,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -402,9 +411,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -426,9 +435,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -606,7 +615,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -657,7 +666,7 @@ end subroutine psi_sswaptranv -subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidxv use psb_error_mod @@ -671,20 +680,27 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_, n +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -698,6 +714,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -809,9 +827,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_real,& & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -874,7 +892,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -897,9 +915,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -920,9 +938,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1049,7 +1067,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1100,7 +1118,7 @@ end subroutine psi_sswaptran_vect -subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& +subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidx_vect @@ -1116,7 +1134,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y real(psb_spk_) :: beta @@ -1124,13 +1142,14 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1144,6 +1163,8 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -1255,9 +1276,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& & mpi_real,& & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1320,7 +1341,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1343,9 +1364,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1366,9 +1387,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 6f38a11f..362431fc 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -156,7 +156,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_zswapdatam -subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidxm use psb_error_mod @@ -170,20 +170,21 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -197,7 +198,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -303,9 +305,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_double_complex,rcvbuf,rvsz,& & brvidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -371,7 +373,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 @@ -395,9 +397,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -420,9 +422,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -653,7 +655,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswapdatav -subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidxv use psb_error_mod @@ -667,21 +669,21 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -695,7 +697,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -801,9 +804,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_double_complex,rcvbuf,rvsz,& & brvidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -866,7 +869,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -890,9 +893,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -913,9 +916,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1087,7 +1090,7 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswapdata_vect -subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidx_vect use psb_error_mod @@ -1102,7 +1105,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y complex(psb_dpk_) :: beta @@ -1110,14 +1113,14 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, totsnd_, totrcv_,& - & idx_pt, snd_pt, rcv_pt, n, pnti, data_ - - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1131,7 +1134,8 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1237,9 +1241,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo & mpi_double_complex,rcvbuf,rvsz,& & brvidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1302,7 +1306,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1326,9 +1330,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1349,9 +1353,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 6cd810ef..e794e5a5 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -111,7 +111,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -161,7 +161,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_zswaptranm -subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidxm use psb_error_mod @@ -175,20 +175,27 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_ - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_ +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -202,6 +209,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -314,9 +323,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & mpi_double_complex,& & sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -379,7 +388,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -402,9 +411,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -426,9 +435,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -606,7 +615,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -657,7 +666,7 @@ end subroutine psi_zswaptranv -subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidxv use psb_error_mod @@ -671,20 +680,27 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n +!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& +!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& +!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& +!!$ & snd_pt, rcv_pt, pnti, data_, n +!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& +!!$ & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -698,6 +714,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -809,9 +827,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & mpi_double_complex,& & sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -874,7 +892,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -897,9 +915,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -920,9 +938,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then @@ -1049,7 +1067,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1100,7 +1118,7 @@ end subroutine psi_zswaptran_vect -subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& +subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidx_vect @@ -1116,7 +1134,7 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y complex(psb_dpk_) :: beta @@ -1124,13 +1142,14 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_ipk_) :: np, me, nesd, nerv,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, data_, n - integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false. @@ -1144,6 +1163,8 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm call psb_info(ictxt,me,np) if (np == -1) then @@ -1255,9 +1276,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& & mpi_double_complex,& & sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1320,7 +1341,7 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,info) + if (usersend) call mpi_barrier(icomm,iret) pnti = 1 snd_pt = 1 @@ -1343,9 +1364,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if end if @@ -1366,9 +1387,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then - int_err(1) = iret + ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=ierr) goto 9999 end if else if (proc_to_comm == me) then