diff --git a/src/comm/psb_dgather.f90 b/src/comm/psb_dgather.f90 index 013a5c33e..b8c1b929a 100644 --- a/src/comm/psb_dgather.f90 +++ b/src/comm/psb_dgather.f90 @@ -62,8 +62,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,& ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& - & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& + integer :: int_err(5), ictxt, np, me,& + & err_act, n, iix, jjx, root, iiroot, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -76,21 +76,16 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,& ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then + if((root.lt.-1).or.(root.gt.np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -263,8 +258,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,& ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& - & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& + integer :: int_err(5), ictxt, np, me, mycol,& + & err_act, n, iix, jjx, root, iiroot, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -277,21 +272,16 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,& ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call psb_info(ictxt, myrow, nprow) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then + if((root.lt.-1).or.(root.gt.np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) diff --git a/src/comm/psb_dhalo.f90 b/src/comm/psb_dhalo.f90 index 12b4b6bb7..71ce84b99 100644 --- a/src/comm/psb_dhalo.f90 +++ b/src/comm/psb_dhalo.f90 @@ -51,6 +51,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) use psb_check_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none real(kind(1.d0)), intent(inout), target :: x(:,:) @@ -62,8 +63,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) character, intent(in), optional :: tran ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& - & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& + integer :: int_err(5), ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& & err, liwork, ncol real(kind(1.d0)),pointer :: iwork(:), xp(:,:) character :: ltran @@ -77,63 +78,58 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) nrow = desc_a%matrix_data(psb_n_row_) - + maxk=size(x,2)-ijx+1 - + if(present(ik)) then - if(ik.gt.maxk) then - k=maxk - else - k=ik - end if + if(ik.gt.maxk) then + k=maxk + else + k=ik + end if else - k = maxk + k = maxk end if if (present(tran)) then - ltran = tran + ltran = tran else - ltran = 'N' + ltran = 'N' endif if (present(mode)) then - imode = mode + imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = IOR(psb_swap_send_,psb_swap_recv_) endif ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -141,56 +137,56 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) if(err.ne.0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then - do i=0, k-1 - call dscal(nrow,alpha,x(1,jjx+i),1) - end do - end if + if(alpha.ne.1.d0) then + do i=0, k-1 + call dscal(nrow,alpha,x(1,jjx+i),1) + end do + end if end if liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange halo elements xp => x(iix:size(x,1),jjx:jjx+k-1) if(ltran.eq.'N') then - call psi_swapdata(imode,k,0.d0,xp,& - & desc_a,iwork,info,data=psb_comm_halo_) + call psi_swapdata(imode,k,0.d0,xp,& + & desc_a,iwork,info,data=psb_comm_halo_) !!$ call PSI_dSwapData(imode,k,0.d0,x(1,jjx),& !!$ & size(x,1),desc_a%matrix_data,& !!$ & desc_a%halo_index,iwork,liwork,info) else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,k,1.d0,xp,& - &desc_a,iwork,info) + call psi_swaptran(imode,k,1.d0,xp,& + &desc_a,iwork,info) !!$ call PSI_dSwapTran(imode,k,1.d0,x(1,jjx),& !!$ & size(x,1),desc_a%matrix_data,& !!$ & desc_a%halo_index,iwork,liwork,info) end if if(info.ne.0) then - ch_err='PSI_dSwap...' - call psb_errpush(4010,name,a_err=ch_err) - goto 9999 + ch_err='PSI_dSwap...' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 end if if(.not.present(work)) deallocate(iwork) @@ -203,8 +199,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_dhalom @@ -262,6 +258,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) use psb_check_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none real(kind(1.d0)), intent(inout) :: x(:) @@ -273,8 +270,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) character, intent(in), optional :: tran ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& - & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& + integer :: int_err(5), ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& & err, liwork, ncol real(kind(1.d0)),pointer :: iwork(:) character :: ltran @@ -288,16 +285,11 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -306,29 +298,29 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) nrow = desc_a%matrix_data(psb_n_row_) - + if (present(tran)) then - ltran = tran + ltran = tran else - ltran = 'N' + ltran = 'N' endif if (present(mode)) then - imode = mode + imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = IOR(psb_swap_send_,psb_swap_recv_) endif ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -336,47 +328,47 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) if(err.ne.0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then - call dscal(nrow,alpha,x,ione) - end if + if(alpha.ne.1.d0) then + call dscal(nrow,alpha,x,ione) + end if end if liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange halo elements if(ltran.eq.'N') then - call psi_swapdata(imode,0.d0,x(iix:size(x)),& - & desc_a,iwork,info,data=psb_comm_halo_) + call psi_swapdata(imode,0.d0,x(iix:size(x)),& + & desc_a,iwork,info,data=psb_comm_halo_) else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,1.d0,x(iix:size(x)),& - & desc_a,iwork,info) + call psi_swaptran(imode,1.d0,x(iix:size(x)),& + & desc_a,iwork,info) end if if(info.ne.0) then - ch_err='PSI_dSwap...' - call psb_errpush(4010,name,a_err=ch_err) - goto 9999 + ch_err='PSI_dSwap...' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 end if if(.not.present(work)) deallocate(iwork) @@ -389,8 +381,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_dhalov diff --git a/src/comm/psb_dovrl.f90 b/src/comm/psb_dovrl.f90 index ba5b4f0cd..5c98f15f2 100644 --- a/src/comm/psb_dovrl.f90 +++ b/src/comm/psb_dovrl.f90 @@ -49,6 +49,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) use psb_realloc_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none real(kind(1.d0)), intent(inout), target :: x(:,:) @@ -58,7 +59,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) integer, intent(in), optional :: update,jx,ik ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & imode, err, liwork, i real(kind(1.d0)),pointer :: iwork(:), xp(:,:) @@ -73,23 +74,18 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%matrix_data(psb_m_) @@ -100,19 +96,19 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then - k=maxk - else - k=ik - end if + if(ik.gt.maxk) then + k=maxk + else + k=ik + end if else - k = maxk + k = maxk end if if (present(update)) then - iupdate = update + iupdate = update else - iupdate = psb_avg_ + iupdate = psb_avg_ endif do_update = (iupdate /= psb_none_) @@ -121,14 +117,14 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -138,64 +134,64 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange overlap elements if(do_update) then - xp => x(iix:size(x,1),jjx:jjx+k-1) - call psi_swapdata(imode,k,1.d0,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) + xp => x(iix:size(x,1),jjx:jjx+k-1) + call psi_swapdata(imode,k,1.d0,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) end if if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_swapdata') - goto 9999 + call psb_errpush(4010,name,a_err='psi_swapdata') + goto 9999 end if i=0 ! switch on update type select case (iupdate) case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& - & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& + & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) + i = i+2 + end do case(psb_avg_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& - & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& + & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) + i = i+2 + end do case(psb_sum_) - ! do nothing + ! do nothing case default - ! wrong value for choice argument - info = 70 - int_err=(/10,iupdate,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 + ! wrong value for choice argument + info = 70 + int_err=(/10,iupdate,0,0,0/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 end select if(.not.present(work)) deallocate(iwork) @@ -208,8 +204,8 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_dovrlm @@ -266,6 +262,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) use psb_realloc_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none real(kind(1.d0)), intent(inout), target :: x(:) @@ -275,7 +272,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) integer, intent(in), optional :: update ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & imode, err, liwork, i real(kind(1.d0)),pointer :: iwork(:) @@ -290,16 +287,11 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ix = 1 @@ -313,9 +305,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) k = 1 if (present(update)) then - iupdate = update + iupdate = update else - iupdate = psb_avg_ + iupdate = psb_avg_ endif do_update = (iupdate /= psb_none_) @@ -324,14 +316,14 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -341,68 +333,68 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange overlap elements if(do_update) then - call psi_swapdata(imode,1.d0,x(iix:size(x)),& - & desc_a,iwork,info,data=psb_comm_ovr_) + call psi_swapdata(imode,1.d0,x(iix:size(x)),& + & desc_a,iwork,info,data=psb_comm_ovr_) end if if(info.ne.0) then - call psb_errpush(4010,name,a_err='PSI_SwapData') - goto 9999 + call psb_errpush(4010,name,a_err='PSI_SwapData') + goto 9999 end if i=0 ! switch on update type select case (iupdate) case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& - & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& + & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) + i = i+2 + end do case(psb_avg_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& - & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& + & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) + i = i+2 + end do case(psb_sum_) - ! do nothing + ! do nothing case default - ! wrong value for choice argument - info = 70 - int_err=(/10,iupdate,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 + ! wrong value for choice argument + info = 70 + int_err=(/10,iupdate,0,0,0/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 end select if(.not.present(work)) deallocate(iwork) nullify(iwork) - + call psb_erractionrestore(err_act) return @@ -410,8 +402,8 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_dovrlv diff --git a/src/comm/psb_dscatter.f90 b/src/comm/psb_dscatter.f90 index b51f50d22..bfa43ee9f 100644 --- a/src/comm/psb_dscatter.f90 +++ b/src/comm/psb_dscatter.f90 @@ -54,6 +54,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& use psb_check_mod use psb_error_mod use mpi + use psb_penv_mod implicit none real(kind(1.d0)), intent(out) :: locx(:,:) @@ -65,38 +66,32 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me,& & err_act, m, n, iix, jjx, temp(2), 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(kind(1.d0)),pointer :: scatterv(:) integer, pointer :: displ(:), l_t_g_all(:), all_dim(:) - integer :: blacs_pnum character(len=20) :: name, ch_err name='psb_scatterm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then + if((root.lt.-1).or.(root.gt.np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -153,8 +148,9 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& k = maxk end if - call blacs_get(ictxt,10,icomm) - myrank = blacs_pnum(ictxt,myrow,mycol) + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + lda_globx = size(globx) lda_locx = size(locx) @@ -162,7 +158,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) - if (myrow == iiroot) then + if (me == iiroot) then call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1) else call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) @@ -172,14 +168,14 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a%matrix_data,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if ((ilx.ne.1).or.(iglobx.ne.1)) then + if ((ilx /= 1).or.(iglobx /= 1)) then info=3040 call psb_errpush(info,name) goto 9999 @@ -187,7 +183,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& nrow=desc_a%matrix_data(psb_n_row_) - if(root.eq.-1) then + if(root == -1) then ! extract my chunk do j=1,k do i=1, nrow @@ -196,27 +192,27 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& end do end do else - rootrank = blacs_pnum(ictxt,root,mycol) + call psb_get_rank(rootrank,ictxt,root) end if ! root has to gather size information - allocate(displ(nprow),all_dim(nprow),stat=info) - if(info.ne.0) then + allocate(displ(np),all_dim(np),stat=info) + if(info /= 0) then info=4010 ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call mpi_gather(nrow,1,mpi_integer,all_dim,& - & nprow,mpi_integer,rootrank,icomm,info) + & np,mpi_integer,rootrank,icomm,info) displ(1)=1 - displ(2:)=all_dim(1:nprow-1)+1 + displ(2:)=all_dim(1:np-1)+1 ! root has to gather loc_glob from each process - if(myrow.eq.root) then + if(me == root) then allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) @@ -232,8 +228,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& do c=1, k ! prepare vector to scatter - if(myrow.eq.root) then - do i=1,nprow + if(me == root) then + do i=1,np pos=displ(i) do j=1, all_dim(i) idx=l_t_g_all(pos+j-1) @@ -257,7 +253,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -326,38 +322,32 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,& & rootrank, c, pos, ilx, jlx real(kind(1.d0)),pointer :: scatterv(:) integer, pointer :: displ(:), l_t_g_all(:), all_dim(:) - integer :: blacs_pnum character(len=20) :: name, ch_err name='psb_scatterv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then + if((root.lt.-1).or.(root.gt.np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -367,8 +357,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) root = -1 end if - call blacs_get(ictxt,10,icomm) - myrank = blacs_pnum(ictxt,myrow,mycol) + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) lda_globx = size(globx) lda_locx = size(locx) @@ -378,7 +368,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) k = 1 - if (myrow == iiroot) then + if (me == iiroot) then call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1) else call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) @@ -388,14 +378,14 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a%matrix_data,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if ((ilx.ne.1).or.(iglobx.ne.1)) then + if ((ilx /= 1).or.(iglobx /= 1)) then info=3040 call psb_errpush(info,name) goto 9999 @@ -403,26 +393,26 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) nrow=desc_a%matrix_data(psb_n_row_) - if(root.eq.-1) then + if(root == -1) then ! extract my chunk do i=1, nrow idx=desc_a%loc_to_glob(i) locx(i)=globx(idx) end do else - rootrank = blacs_pnum(ictxt,root,mycol) + call psb_get_rank(rootrank,ictxt,root) end if ! root has to gather size information - allocate(displ(nprow),all_dim(nprow)) + allocate(displ(np),all_dim(np)) call mpi_gather(nrow,1,mpi_integer,all_dim,& - & nprow,mpi_integer,rootrank,icomm,info) + & np,mpi_integer,rootrank,icomm,info) displ(1)=1 - displ(2:)=all_dim(1:nprow-1)+1 + displ(2:)=all_dim(1:np-1)+1 ! root has to gather loc_glob from each process - if(myrow.eq.root) then + if(me == root) then allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if @@ -431,8 +421,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) & displ,mpi_integer,rootrank,icomm,info) ! prepare vector to scatter - if(myrow.eq.root) then - do i=1,nprow + if(me == root) then + do i=1,np pos=displ(i) do j=1, all_dim(i) idx=l_t_g_all(pos+j-1) @@ -453,7 +443,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/comm/psb_ihalo.f90 b/src/comm/psb_ihalo.f90 index c973c59e8..e0bce8e09 100644 --- a/src/comm/psb_ihalo.f90 +++ b/src/comm/psb_ihalo.f90 @@ -52,6 +52,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) use psb_realloc_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none integer, intent(inout), target :: x(:,:) @@ -63,7 +64,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) character, intent(in), optional :: tran ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, liwork,& & imode, err integer, pointer :: xp(:,:), iwork(:) @@ -78,16 +79,11 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -258,6 +254,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) use psb_realloc_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none integer, intent(inout) :: x(:) @@ -269,7 +266,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) character, intent(in), optional :: tran ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, imode,& & err, liwork integer,pointer :: iwork(:) @@ -284,16 +281,11 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -302,31 +294,31 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) nrow = desc_a%matrix_data(psb_n_row_) -! ncol = desc_a%matrix_data(psb_n_col_) - + ! ncol = desc_a%matrix_data(psb_n_col_) + if (present(tran)) then - ltran = tran + ltran = tran else - ltran = 'N' + ltran = 'N' endif if (present(mode)) then - imode = mode + imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = IOR(psb_swap_send_,psb_swap_recv_) endif ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -341,39 +333,39 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange halo elements if(ltran.eq.'N') then - call psi_swapdata(imode,0,x(iix:size(x)),& - & desc_a,iwork,info) + call psi_swapdata(imode,0,x(iix:size(x)),& + & desc_a,iwork,info) else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,1,x(iix:size(x)),& - & desc_a,iwork,info) + call psi_swaptran(imode,1,x(iix:size(x)),& + & desc_a,iwork,info) end if if(info.ne.0) then - call psb_errpush(4010,name,a_err='PSI_iSwap...') - goto 9999 + call psb_errpush(4010,name,a_err='PSI_iSwap...') + goto 9999 end if if(.not.present(work)) deallocate(iwork) @@ -386,8 +378,8 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_ihalov diff --git a/src/comm/psb_zgather.f90 b/src/comm/psb_zgather.f90 index 5f11fd6a2..dbab03f99 100644 --- a/src/comm/psb_zgather.f90 +++ b/src/comm/psb_zgather.f90 @@ -62,7 +62,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,& ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx complex(kind(1.d0)),pointer :: tmpx(:) @@ -76,55 +76,50 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,& ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then - root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then - info=30 - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root.lt.-1).or.(root.gt.np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if if (root==-1) then - iiroot=0 + iiroot=0 endif if (present(iiglobx)) then - iglobx = iiglobx + iglobx = iiglobx else - iglobx = 1 + iglobx = 1 end if if (present(ijglobx)) then - jglobx = ijglobx + jglobx = ijglobx else - jglobx = 1 + jglobx = 1 end if if (present(iilocx)) then - ilocx = iilocx + ilocx = iilocx else - ilocx = 1 + ilocx = 1 end if if (present(ijlocx)) then - jlocx = ijlocx + jlocx = ijlocx else - jlocx = 1 + jlocx = 1 end if lda_globx = size(globx,1) @@ -132,19 +127,19 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,& m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) - + lock=size(locx,2)-jlocx+1 globk=size(globx,2)-jglobx+1 maxk=min(lock,globk) - + if(present(ik)) then - if(ik.gt.maxk) then - k=maxk - else - k=ik - end if + if(ik.gt.maxk) then + k=maxk + else + k=ik + end if else - k = maxk + k = maxk end if call psb_bcast(ictxt,k,root=iiroot) @@ -154,10 +149,10 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,& call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a%matrix_data,info) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx) if(info.ne.0) then - info=4010 - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((ilx.ne.1).or.(iglobx.ne.1)) then @@ -263,7 +258,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,& ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& & jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx complex(kind(1.d0)),pointer :: tmpx(:) @@ -277,42 +272,37 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,& ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call psb_info(ictxt, myrow, nprow) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then - root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then - info=30 - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root.lt.-1).or.(root.gt.np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if jglobx=1 if (present(iiglobx)) then - iglobx = iiglobx + iglobx = iiglobx else - iglobx = 1 + iglobx = 1 end if jlocx=1 if (present(iilocx)) then - ilocx = iilocx + ilocx = iilocx else - ilocx = 1 + ilocx = 1 end if lda_globx = size(globx) @@ -320,7 +310,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,& m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) - + k = 1 @@ -329,35 +319,35 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,& call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a%matrix_data,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx) if(info.ne.0) then - info=4010 - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((ilx.ne.1).or.(iglobx.ne.1)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if - + globx(:)=0.d0 do i=1,desc_a%matrix_data(psb_n_row_) - idx = desc_a%loc_to_glob(i) - globx(idx) = locx(i) + idx = desc_a%loc_to_glob(i) + globx(idx) = locx(i) end do ! adjust overlapped elements i=1 do while (desc_a%ovrlap_elem(i).ne.-1) - idx=desc_a%ovrlap_elem(i+psb_ovrlp_elem_) - idx=desc_a%loc_to_glob(idx) - globx(idx) = globx(idx)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - i=i+2 + idx=desc_a%ovrlap_elem(i+psb_ovrlp_elem_) + idx=desc_a%loc_to_glob(idx) + globx(idx) = globx(idx)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_) + i=i+2 end do - + call psb_sum(ictxt,globx(1:m),root=root) - + call psb_erractionrestore(err_act) return @@ -365,8 +355,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,& call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/src/comm/psb_zhalo.f90 b/src/comm/psb_zhalo.f90 index 6997c7c8e..8125fd6fa 100644 --- a/src/comm/psb_zhalo.f90 +++ b/src/comm/psb_zhalo.f90 @@ -51,6 +51,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) use psb_check_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(inout), target :: x(:,:) @@ -62,7 +63,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) character, intent(in), optional :: tran ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& & err, liwork, ncol complex(kind(1.d0)),pointer :: iwork(:), xp(:,:) @@ -77,63 +78,58 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) nrow = desc_a%matrix_data(psb_n_row_) - + maxk=size(x,2)-ijx+1 - + if(present(ik)) then - if(ik.gt.maxk) then - k=maxk - else - k=ik - end if + if(ik.gt.maxk) then + k=maxk + else + k=ik + end if else - k = maxk + k = maxk end if if (present(tran)) then - ltran = tran + ltran = tran else - ltran = 'N' + ltran = 'N' endif if (present(mode)) then - imode = mode + imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = IOR(psb_swap_send_,psb_swap_recv_) endif ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -141,50 +137,50 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) if(err.ne.0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then - do i=0, k-1 - call zscal(nrow,alpha,x(1,jjx+i),1) - end do - end if + if(alpha.ne.1.d0) then + do i=0, k-1 + call zscal(nrow,alpha,x(1,jjx+i),1) + end do + end if end if liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange halo elements xp => x(iix:size(x,1),jjx:jjx+k-1) if(ltran.eq.'N') then - call psi_swapdata(imode,k,zzero,xp,& - & desc_a,iwork,info,data=psb_comm_halo_) + call psi_swapdata(imode,k,zzero,xp,& + & desc_a,iwork,info,data=psb_comm_halo_) else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,k,zone,xp,& - &desc_a,iwork,info) + call psi_swaptran(imode,k,zone,xp,& + &desc_a,iwork,info) end if if(info.ne.0) then - ch_err='PSI_dSwap...' - call psb_errpush(4010,name,a_err=ch_err) - goto 9999 + ch_err='PSI_dSwap...' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 end if if(.not.present(work)) deallocate(iwork) @@ -197,8 +193,8 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zhalom @@ -256,6 +252,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) use psb_check_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(inout) :: x(:) @@ -267,7 +264,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) character, intent(in), optional :: tran ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& & err, liwork, ncol complex(kind(1.d0)),pointer :: iwork(:) @@ -282,16 +279,11 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -300,29 +292,29 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) nrow = desc_a%matrix_data(psb_n_row_) - + if (present(tran)) then - ltran = tran + ltran = tran else - ltran = 'N' + ltran = 'N' endif if (present(mode)) then - imode = mode + imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = IOR(psb_swap_send_,psb_swap_recv_) endif ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -330,47 +322,47 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) if(err.ne.0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then - call zscal(nrow,alpha,x,ione) - end if + if(alpha.ne.1.d0) then + call zscal(nrow,alpha,x,ione) + end if end if liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange halo elements if(ltran.eq.'N') then - call psi_swapdata(imode,zzero,x(iix:size(x)),& - & desc_a,iwork,info,data=psb_comm_halo_) + call psi_swapdata(imode,zzero,x(iix:size(x)),& + & desc_a,iwork,info,data=psb_comm_halo_) else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,zone,x(iix:size(x)),& - & desc_a,iwork,info) + call psi_swaptran(imode,zone,x(iix:size(x)),& + & desc_a,iwork,info) end if if(info.ne.0) then - ch_err='PSI_dSwap...' - call psb_errpush(4010,name,a_err=ch_err) - goto 9999 + ch_err='PSI_dSwap...' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 end if if(.not.present(work)) deallocate(iwork) @@ -383,8 +375,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zhalov diff --git a/src/comm/psb_zovrl.f90 b/src/comm/psb_zovrl.f90 index aa9b8d708..33db0e835 100644 --- a/src/comm/psb_zovrl.f90 +++ b/src/comm/psb_zovrl.f90 @@ -49,6 +49,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) use psb_realloc_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(inout), target :: x(:,:) @@ -58,7 +59,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) integer, intent(in), optional :: update,jx,ik ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & imode, err, liwork, i complex(kind(1.d0)),pointer :: iwork(:), xp(:,:) @@ -73,23 +74,18 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%matrix_data(psb_m_) @@ -100,19 +96,19 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then - k=maxk - else - k=ik - end if + if(ik.gt.maxk) then + k=maxk + else + k=ik + end if else - k = maxk + k = maxk end if if (present(update)) then - iupdate = update + iupdate = update else - iupdate = psb_avg_ + iupdate = psb_avg_ endif do_update = (iupdate /= psb_none_) @@ -121,14 +117,14 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -138,64 +134,64 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange overlap elements if(do_update) then - xp => x(iix:size(x,1),jjx:jjx+k-1) - call psi_swapdata(imode,k,zone,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) + xp => x(iix:size(x,1),jjx:jjx+k-1) + call psi_swapdata(imode,k,zone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) end if if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_swapdata') - goto 9999 + call psb_errpush(4010,name,a_err='psi_swapdata') + goto 9999 end if i=0 ! switch on update type select case (iupdate) case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& - & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& + & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) + i = i+2 + end do case(psb_avg_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& - & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:)/& + & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) + i = i+2 + end do case(psb_sum_) - ! do nothing + ! do nothing case default - ! wrong value for choice argument - info = 70 - int_err=(/10,iupdate,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 + ! wrong value for choice argument + info = 70 + int_err=(/10,iupdate,0,0,0/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 end select if(.not.present(work)) deallocate(iwork) @@ -208,8 +204,8 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zovrlm @@ -266,6 +262,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) use psb_realloc_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(inout), target :: x(:) @@ -275,7 +272,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) integer, intent(in), optional :: update ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & imode, err, liwork, i complex(kind(1.d0)),pointer :: iwork(:) @@ -290,16 +287,11 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ix = 1 @@ -313,9 +305,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) k = 1 if (present(update)) then - iupdate = update + iupdate = update else - iupdate = psb_none_ + iupdate = psb_none_ endif do_update = (iupdate /= psb_none_) @@ -324,14 +316,14 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if err=info @@ -341,69 +333,69 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(size(work).ge.liwork) then + iwork => work + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + end if + else + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if ! exchange overlap elements if(do_update) then - call psi_swapdata(imode,zone,x(iix:size(x)),& - & desc_a,iwork,info,data=psb_comm_ovr_) + call psi_swapdata(imode,zone,x(iix:size(x)),& + & desc_a,iwork,info,data=psb_comm_ovr_) end if if(info.ne.0) then - call psb_errpush(4010,name,a_err='PSI_SwapData') - goto 9999 + call psb_errpush(4010,name,a_err='PSI_SwapData') + goto 9999 end if i=0 ! switch on update type select case (iupdate) case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& - & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& + & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) + i = i+2 + end do case(psb_avg_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& - & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) - i = i+2 - end do + do while(desc_a%ovrlap_elem(i).ne.-ione) + x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& + & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& + & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) + i = i+2 + end do case(psb_sum_) - ! do nothing + ! do nothing case default - ! wrong value for choice argument - info = 70 - int_err=(/10,iupdate,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 + ! wrong value for choice argument + info = 70 + int_err=(/10,iupdate,0,0,0/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 end select if(.not.present(work)) deallocate(iwork) nullify(iwork) - + call psb_erractionrestore(err_act) return @@ -411,8 +403,8 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zovrlv diff --git a/src/comm/psb_zscatter.f90 b/src/comm/psb_zscatter.f90 index a16353417..394c95e7e 100644 --- a/src/comm/psb_zscatter.f90 +++ b/src/comm/psb_zscatter.f90 @@ -54,6 +54,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,& use psb_check_mod use psb_error_mod use mpi + use psb_penv_mod implicit none complex(kind(1.d0)), intent(out) :: locx(:,:) @@ -65,72 +66,66 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,& ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), 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 complex(kind(1.d0)),pointer :: scatterv(:) integer, pointer :: displ(:), l_t_g_all(:), all_dim(:) - integer :: blacs_pnum character(len=20) :: name, ch_err name='psb_scatterm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then - root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then - info=30 - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root.lt.-1).or.(root.gt.np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if if (root==-1) then - iiroot=0 + iiroot=0 endif - + if (present(iiglobx)) then - iglobx = iiglobx + iglobx = iiglobx else - iglobx = 1 + iglobx = 1 end if if (present(ijglobx)) then - jglobx = ijglobx + jglobx = ijglobx else - jglobx = 1 + jglobx = 1 end if if (present(iilocx)) then - ilocx = iilocx + ilocx = iilocx else - ilocx = 1 + ilocx = 1 end if if (present(ijlocx)) then - jlocx = ijlocx + jlocx = ijlocx else - jlocx = 1 + jlocx = 1 end if lda_globx = size(globx,1) @@ -138,117 +133,117 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,& m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) - + lock=size(locx,2)-jlocx+1 globk=size(globx,2)-jglobx+1 maxk=min(lock,globk) - + if(present(ik)) then - if(ik.gt.maxk) then - k=maxk - else - k=ik - end if + if(ik.gt.maxk) then + k=maxk + else + k=ik + end if else - k = maxk + k = maxk end if - call blacs_get(ictxt,10,icomm) - myrank = blacs_pnum(ictxt,myrow,mycol) + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) lda_globx = size(globx) lda_locx = size(locx) m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) - - if (myrow == iiroot) then - call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1) + + if (me == iiroot) then + call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1) else - call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) + call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) end if ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a%matrix_data,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx) - if(info.ne.0) then - info=4010 - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + if(info /= 0) then + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - if ((ilx.ne.1).or.(iglobx.ne.1)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + if ((ilx /= 1).or.(iglobx /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 end if nrow=desc_a%matrix_data(psb_n_row_) - if(root.eq.-1) then - ! extract my chunk - do j=1,k - do i=1, nrow - idx=desc_a%loc_to_glob(i) - locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) - end do - end do + if(root == -1) then + ! extract my chunk + do j=1,k + do i=1, nrow + idx=desc_a%loc_to_glob(i) + locx(i,jlocx+j-1)=globx(idx,jglobx+j-1) + end do + end do else - rootrank = blacs_pnum(ictxt,root,mycol) + call psb_get_rank(rootrank,ictxt,root) end if ! root has to gather size information - allocate(displ(nprow),all_dim(nprow),stat=info) - if(info.ne.0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + allocate(displ(np),all_dim(np),stat=info) + if(info /= 0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call mpi_gather(nrow,1,mpi_integer,all_dim,& - & nprow,mpi_integer,rootrank,icomm,info) - + & np,mpi_integer,rootrank,icomm,info) + displ(1)=1 - displ(2:)=all_dim(1:nprow-1)+1 + displ(2:)=all_dim(1:np-1)+1 ! root has to gather loc_glob from each process - if(myrow.eq.root) then - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info.ne.0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + if(me == root) then + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + if(info /= 0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if - + call mpi_gatherv(desc_a%loc_to_glob,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) - + do c=1, k - ! prepare vector to scatter - if(myrow.eq.root) then - do i=1,nprow - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j-1) - scatterv(pos+j-1)=globx(idx,jglobx+c-1) - end do + ! prepare vector to scatter + if(me == root) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j-1) + scatterv(pos+j-1)=globx(idx,jglobx+c-1) end do - end if - - ! scatter !!! - call mpi_scatterv(scatterv,all_dim,displ,& - & mpi_double_complex,locx(1,jlocx+c-1),nrow,& - & mpi_double_complex,rootrank,icomm,info) + end do + end if + + ! scatter !!! + call mpi_scatterv(scatterv,all_dim,displ,& + & mpi_double_complex,locx(1,jlocx+c-1),nrow,& + & mpi_double_complex,rootrank,icomm,info) end do - + deallocate(all_dim, l_t_g_all, displ, scatterv) call psb_erractionrestore(err_act) @@ -257,9 +252,9 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return @@ -326,119 +321,113 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,& & rootrank, c, pos, ilx, jlx complex(kind(1.d0)),pointer :: scatterv(:) integer, pointer :: displ(:), l_t_g_all(:), all_dim(:) - integer :: blacs_pnum character(len=20) :: name, ch_err name='psb_scatterv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (present(iroot)) then - root = iroot - if((root.lt.-1).or.(root.gt.nprow)) then - info=30 - int_err(1:2)=(/5,root/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + root = iroot + if((root.lt.-1).or.(root.gt.np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if else - root = -1 + root = -1 end if - - call blacs_get(ictxt,10,icomm) - myrank = blacs_pnum(ictxt,myrow,mycol) + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) lda_globx = size(globx) lda_locx = size(locx) m = desc_a%matrix_data(psb_m_) n = desc_a%matrix_data(psb_n_) - + k = 1 - if (myrow == iiroot) then - call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1) + if (me == iiroot) then + call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1) else - call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) + call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) end if ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a%matrix_data,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx) - if(info.ne.0) then - info=4010 - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + if(info /= 0) then + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - if ((ilx.ne.1).or.(iglobx.ne.1)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + if ((ilx /= 1).or.(iglobx /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 end if nrow=desc_a%matrix_data(psb_n_row_) - if(root.eq.-1) then - ! extract my chunk - do i=1, nrow - idx=desc_a%loc_to_glob(i) - locx(i)=globx(idx) - end do + if(root == -1) then + ! extract my chunk + do i=1, nrow + idx=desc_a%loc_to_glob(i) + locx(i)=globx(idx) + end do else - rootrank = blacs_pnum(ictxt,root,mycol) + call psb_get_rank(rootrank,ictxt,root) end if ! root has to gather size information - allocate(displ(nprow),all_dim(nprow)) + allocate(displ(np),all_dim(np)) call mpi_gather(nrow,1,mpi_integer,all_dim,& - & nprow,mpi_integer,rootrank,icomm,info) - + & np,mpi_integer,rootrank,icomm,info) + displ(1)=1 - displ(2:)=all_dim(1:nprow-1)+1 + displ(2:)=all_dim(1:np-1)+1 ! root has to gather loc_glob from each process - if(myrow.eq.root) then - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) + if(me == root) then + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) end if - + call mpi_gatherv(desc_a%loc_to_glob,nrow,& & mpi_integer,l_t_g_all,all_dim,& & displ,mpi_integer,rootrank,icomm,info) ! prepare vector to scatter - if(myrow.eq.root) then - do i=1,nprow - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j-1) - scatterv(pos+j-1)=globx(idx) - end do - end do + if(me == root) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j-1) + scatterv(pos+j-1)=globx(idx) + end do + end do end if call mpi_scatterv(scatterv,all_dim,displ,& @@ -453,9 +442,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/internals/Makefile b/src/internals/Makefile index 634d173d4..83a37c00c 100644 --- a/src/internals/Makefile +++ b/src/internals/Makefile @@ -20,7 +20,7 @@ lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(RANLIB) $(LIBDIR)/$(LIBNAME) -mpfobjs: +mpfobjs: psi_gthsct.o (make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)") (make $(MPFOBJS2) F90="$(MPF77)" FC="$(MPF77)" FCOPT="$(FCOPT)") (make $(FOBJS2) F90="$(MPF77)" FC="$(MPF77)" FCOPT="$(FCOPT)") diff --git a/src/internals/psi_compute_size.f90 b/src/internals/psi_compute_size.f90 index 418838c54..5af801e8c 100644 --- a/src/internals/psi_compute_size.f90 +++ b/src/internals/psi_compute_size.f90 @@ -40,8 +40,8 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) ! .....array parameters.... integer :: desc_data(:), index_in(:) ! ....local scalars.... - integer :: i,npcol,nprow,mycol,myrow,proc, max_index - integer :: ictxt, err, err_act, np + integer :: i,np,me,proc, max_index + integer :: ictxt, err, err_act ! ...local array... integer :: exch(2) integer :: int_err(5) @@ -57,19 +57,13 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) info = 0 ictxt = desc_data(psb_ctxt_) - call psb_info(ictxt,myrow,nprow) - if (nprow == -1) then + call psb_info(ictxt,me,np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - np=nprow allocate(counter_dl(0:np-1),counter_recv(0:np-1),stat=info) if (info /= 0) then call psb_errpush(4010,name,a_err='Allocate') diff --git a/src/internals/psi_crea_bnd_elem.f90 b/src/internals/psi_crea_bnd_elem.f90 index 6a20998ff..da689d768 100644 --- a/src/internals/psi_crea_bnd_elem.f90 +++ b/src/internals/psi_crea_bnd_elem.f90 @@ -44,40 +44,40 @@ subroutine psi_crea_bnd_elem(desc_a,info) info = 0 name='psi_crea_bnd_elem' call psb_erractionsave(err_act) - + allocate(work(size(desc_a%halo_index)),stat=info) if (info /= 0 ) then - info = 4000 - call psb_errpush(info,name) - goto 9999 + info = 4000 + call psb_errpush(info,name) + goto 9999 end if i=0 j=1 do while(desc_a%halo_index(j) /= -1) - nr = desc_a%halo_index(j+1) - ns = desc_a%halo_index(j+1+nr+1) - do k=1, ns - i = i + 1 - work(i) = desc_a%halo_index(j+1+nr+1+k) - enddo - j = j + 1 + ns + 1 + nr + 1 + nr = desc_a%halo_index(j+1) + ns = desc_a%halo_index(j+1+nr+1) + do k=1, ns + i = i + 1 + work(i) = desc_a%halo_index(j+1+nr+1+k) + enddo + j = j + 1 + ns + 1 + nr + 1 enddo if (i>0) then - call isr(i,work) - j=1 - irv = work(1) - do k=2, i - if (work(k) /= irv) then - irv = work(k) - j = j + 1 - work(j) = work(k) - endif - enddo + call isr(i,work) + j=1 + irv = work(1) + do k=2, i + if (work(k) /= irv) then + irv = work(k) + j = j + 1 + work(j) = work(k) + endif + enddo else - j = 0 + j = 0 endif allocate(desc_a%bnd_elem(j+1),stat=info) @@ -87,22 +87,22 @@ subroutine psi_crea_bnd_elem(desc_a,info) end if if (.false.) then - desc_a%bnd_elem(1) = j - desc_a%bnd_elem(2:j+1) = work(1:j) + desc_a%bnd_elem(1) = j + desc_a%bnd_elem(2:j+1) = work(1:j) else - desc_a%bnd_elem(1:j) = work(1:j) - desc_a%bnd_elem(j+1) = -1 + desc_a%bnd_elem(1:j) = work(1:j) + desc_a%bnd_elem(j+1) = -1 endif deallocate(work) call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error() - return + call psb_error() + return end if return end subroutine psi_crea_bnd_elem diff --git a/src/internals/psi_crea_index.f90 b/src/internals/psi_crea_index.f90 index b9a4b76ae..a792517a9 100644 --- a/src/internals/psi_crea_index.f90 +++ b/src/internals/psi_crea_index.f90 @@ -29,10 +29,11 @@ !!$ !!$ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) - + use psb_realloc_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -40,48 +41,48 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) integer, intent(in) :: index_in(:) integer, pointer :: index_out(:) logical :: glob_idx - -! ....local scalars... - integer :: me,npcol,mycol,nprow,i,j,k,& - & mode, int_err(5), err, err_act, np,& + + ! ....local scalars... + integer :: me,np,i,j,k,& + & mode, int_err(5), err, err_act,& & dl_lda, ictxt, proc, nerv, nesd -! ...parameters... + ! ...parameters... integer, pointer :: dep_list(:,:), length_dl(:) integer,parameter :: root=0,no_comm=-1 logical,parameter :: debug=.false. character(len=20) :: name, ch_err interface - subroutine psi_compute_size(desc_data,& - & index_in, dl_lda, info) - integer :: info, dl_lda - integer :: desc_data(:), index_in(:) - end subroutine psi_compute_size + subroutine psi_compute_size(desc_data,& + & index_in, dl_lda, info) + integer :: info, dl_lda + integer :: desc_data(:), index_in(:) + end subroutine psi_compute_size end interface interface - subroutine psi_sort_dl(dep_list,l_dep_list,np,info) - integer :: np,dep_list(:,:), l_dep_list(:), info - end subroutine psi_sort_dl + subroutine psi_sort_dl(dep_list,l_dep_list,np,info) + integer :: np,dep_list(:,:), l_dep_list(:), info + end subroutine psi_sort_dl end interface interface - subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) - integer :: np,dl_lda,length_dl(0:np) - integer :: dep_list(dl_lda,0:np) - end subroutine psi_dl_check + subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) + integer :: np,dl_lda,length_dl(0:np) + integer :: dep_list(dl_lda,0:np) + end subroutine psi_dl_check end interface interface - subroutine psi_desc_index(desc_data,index_in,dep_list,& - & length_dl,loc_to_glob,glob_to_loc,desc_index,& - & isglob_in,info) - integer :: desc_data(:),index_in(:),dep_list(:) - integer :: loc_to_glob(:),glob_to_loc(:) - integer,pointer :: desc_index(:) - integer :: length_dl, info - logical :: isglob_in - end subroutine psi_desc_index + subroutine psi_desc_index(desc_data,index_in,dep_list,& + & length_dl,loc_to_glob,glob_to_loc,desc_index,& + & isglob_in,info) + integer :: desc_data(:),index_in(:),dep_list(:) + integer :: loc_to_glob(:),glob_to_loc(:) + integer,pointer :: desc_index(:) + integer :: length_dl, info + logical :: isglob_in + end subroutine psi_desc_index end interface info = 0 @@ -89,16 +90,11 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) call psb_erractionsave(err_act) ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,np,npcol,me,mycol) + call psb_info(ictxt,me,np) if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ! allocate dependency list @@ -121,8 +117,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) call psi_extract_dep_list(desc_a%matrix_data,index_in,& & dep_list,length_dl,np,max(1,dl_lda),mode,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='extrct_dl') - goto 9999 + call psb_errpush(4010,name,a_err='extrct_dl') + goto 9999 end if if (debug) write(*,*) 'crea_index: from extract_dep_list',& @@ -136,8 +132,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) ! ....now i can sort dependence list...... call psi_sort_dl(dep_list,length_dl,np,info) if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_sort_dl') - goto 9999 + call psb_errpush(4010,name,a_err='psi_sort_dl') + goto 9999 end if ! ...create desc_halo array..... @@ -148,19 +144,19 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) & index_out,glob_idx,info) if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_desc_index') - goto 9999 + call psb_errpush(4010,name,a_err='psi_desc_index') + goto 9999 end if - + deallocate(dep_list,length_dl) call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psi_crea_index diff --git a/src/internals/psi_crea_ovr_elem.f90 b/src/internals/psi_crea_ovr_elem.f90 index 236b816c4..75e62be32 100644 --- a/src/internals/psi_crea_ovr_elem.f90 +++ b/src/internals/psi_crea_ovr_elem.f90 @@ -51,40 +51,40 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem) pnt_new_elem=1 if (usetree) call initpairsearchtree(info) do while (desc_overlap(i).ne.-1) - ! ...loop over all procs of desc_overlap list.... + ! ...loop over all procs of desc_overlap list.... - i=i+1 - do j=1,desc_overlap(i) - ! ....loop over all overlap indices referred to act proc..... - if (usetree) then - call searchinskeyval(desc_overlap(i+j),pnt_new_elem,& - & ret,info) - if (ret == pnt_new_elem) ret=-1 - else - ret=psi_exist_ovr_elem(ovr_elem,pnt_new_elem-2,& - & desc_overlap(i+j)) + i=i+1 + do j=1,desc_overlap(i) + ! ....loop over all overlap indices referred to act proc..... + if (usetree) then + call searchinskeyval(desc_overlap(i+j),pnt_new_elem,& + & ret,info) + if (ret == pnt_new_elem) ret=-1 + else + ret=psi_exist_ovr_elem(ovr_elem,pnt_new_elem-2,& + & desc_overlap(i+j)) + endif + if (ret.eq.-1) then + + ! ...this point not exist in ovr_elem list: + ! add to it............................. + ovr_elem(pnt_new_elem)=desc_overlap(i+j) + ovr_elem(pnt_new_elem+1)=2 + pnt_new_elem=pnt_new_elem+2 + + ! ...check if overflow element_d array...... + if (pnt_new_elem.gt.dim_ovr_elem) then + dim_ovr_elem=(3*size(ovr_elem))/2+2 + write(0,*) 'calling realloc crea_ovr_elem',dim + call psb_realloc(dim_ovr_elem,ovr_elem,info) endif - if (ret.eq.-1) then - - ! ...this point not exist in ovr_elem list: - ! add to it............................. - ovr_elem(pnt_new_elem)=desc_overlap(i+j) - ovr_elem(pnt_new_elem+1)=2 - pnt_new_elem=pnt_new_elem+2 - - ! ...check if overflow element_d array...... - if (pnt_new_elem.gt.dim_ovr_elem) then - dim_ovr_elem=(3*size(ovr_elem))/2+2 - write(0,*) 'calling realloc crea_ovr_elem',dim - call psb_realloc(dim_ovr_elem,ovr_elem,info) - endif - else - ! ....this point already exist in ovr_elem list - ! its position is ret............................ - ovr_elem(ret+1)=ovr_elem(ret+1)+1 - endif - enddo - i=i+2*desc_overlap(i)+2 + else + ! ....this point already exist in ovr_elem list + ! its position is ret............................ + ovr_elem(ret+1)=ovr_elem(ret+1)+1 + endif + enddo + i=i+2*desc_overlap(i)+2 enddo ! ...add -1 at the end of output list...... diff --git a/src/internals/psi_desc_index.f90 b/src/internals/psi_desc_index.f90 index 093ed5e22..216035fdb 100644 --- a/src/internals/psi_desc_index.f90 +++ b/src/internals/psi_desc_index.f90 @@ -36,6 +36,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& use psb_error_mod use psb_const_mod use mpi + use psb_penv_mod implicit none !c ...array parameters..... @@ -45,7 +46,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& integer :: length_dl, info logical :: isglob_in !c ....local scalars... - integer :: j,me,np,npcol,mycol,i,proc,dim + integer :: j,me,np,i,proc,dim !c ...parameters... integer :: ictxt integer :: no_comm,err @@ -68,24 +69,19 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& !c if mode == 1 then we can use glob_to_loc array !c else we can't utilize it ictxt=desc_data(psb_ctxt_) - call blacs_gridinfo(ictxt,np,npcol,me,mycol) + call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (debug) then - write(0,*) me,'start desc_index' - call blacs_barrier(ictxt,'all') + write(0,*) me,'start desc_index' + call psb_barrier(ictxt) endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) !c !c first, find out the total sizes to be exchanged. !c note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things @@ -94,9 +90,9 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& !c allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) if(info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if sdsz(:) = 0 @@ -105,92 +101,92 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& brvindx(:) = 0 i = 1 do - if (index_in(i) == -1) exit - proc = index_in(i) - i = i + 1 - nerv = index_in(i) - sdsz(proc+1) = sdsz(proc+1) + nerv - i = i + nerv + 1 + if (index_in(i) == -1) exit + proc = index_in(i) + i = i + 1 + nerv = index_in(i) + sdsz(proc+1) = sdsz(proc+1) + nerv + i = i + nerv + 1 end do ihinsz=i call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='mpi_alltoall') - goto 9999 + call psb_errpush(4010,name,a_err='mpi_alltoall') + goto 9999 end if i = 1 idxs = 0 idxr = 0 do i=1, length_dl - proc = dep_list(i) - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) + proc = dep_list(i) + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) end do iszs = sum(sdsz) iszr = sum(rvsz) if ((iszs /= idxs).or.(iszr /= idxr)) then - write(0,*) 'strange results???', iszs,idxs,iszr,idxr + write(0,*) 'strange results???', iszs,idxs,iszr,idxr end if if (debug) then - write(0,*) me,'computed sizes ',iszr,iszs - call blacs_barrier(ictxt,'all') + write(0,*) me,'computed sizes ',iszr,iszs + call psb_barrier(ictxt) endif ntot = (3*(max(count(sdsz>0),count(rvsz>0)))+ iszs + iszr) + 1 if (size(desc_index) < ntot) then - !c$$$ write(0,*) 'potential error on desc_index :', - !c$$$ + length_dh, size(desc_index),ntot - write(0,*) 'calling irealloc psi_desc_index ',ntot - call psb_realloc(ntot,desc_index,info) + !c$$$ write(0,*) 'potential error on desc_index :', + !c$$$ + length_dh, size(desc_index),ntot + write(0,*) 'calling irealloc psi_desc_index ',ntot + call psb_realloc(ntot,desc_index,info) endif if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') - goto 9999 + call psb_errpush(4010,name,a_err='psb_realloc') + goto 9999 end if if (debug) then - write(0,*) me,'computed allocated workspace ',iszr,iszs - call blacs_barrier(ictxt,'all') + write(0,*) me,'computed allocated workspace ',iszr,iszs + call psb_barrier(ictxt) endif allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) if(info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if i = 1 do - if (i > ihinsz) then - write(0,*) me,' did not find index_in end??? ',i,ihinsz - exit - end if - if (index_in(i) == -1) exit - proc = index_in(i) - i = i + 1 - nerv = index_in(i) - ! c - ! c note that here bsdinx is zero-based, hence the following loop - ! c - if (isglob_in) then - do j=1, nerv - sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) - end do - else - do j=1, nerv - sndbuf(bsdindx(proc+1)+j) = loc_to_glob(index_in(i+j)) - end do - endif - bsdindx(proc+1) = bsdindx(proc+1) + nerv - i = i + nerv + 1 + if (i > ihinsz) then + write(0,*) me,' did not find index_in end??? ',i,ihinsz + exit + end if + if (index_in(i) == -1) exit + proc = index_in(i) + i = i + 1 + nerv = index_in(i) + ! c + ! c note that here bsdinx is zero-based, hence the following loop + ! c + if (isglob_in) then + do j=1, nerv + sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) + end do + else + do j=1, nerv + sndbuf(bsdindx(proc+1)+j) = loc_to_glob(index_in(i+j)) + end do + endif + bsdindx(proc+1) = bsdindx(proc+1) + nerv + i = i + nerv + 1 end do if (debug) then - write(0,*) me,' prepared send buffer ' - call blacs_barrier(ictxt,'all') + write(0,*) me,' prepared send buffer ' + call psb_barrier(ictxt) endif !c !c now have to regenerate bsdindx @@ -198,18 +194,18 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& idxs = 0 idxr = 0 do i=1, length_dl - proc = dep_list(i) - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) + proc = dep_list(i) + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) end do call mpi_alltoallv(sndbuf,sdsz,bsdindx,mpi_integer,& & rcvbuf,rvsz,brvindx,mpi_integer,icomm,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='mpi_alltoallv') - goto 9999 + call psb_errpush(4010,name,a_err='mpi_alltoallv') + goto 9999 end if !c @@ -218,34 +214,34 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& !c i = 1 do k = 1, length_dl - proc = dep_list(k) - desc_index(i) = proc - i = i + 1 - nerv = sdsz(proc+1) - desc_index(i) = nerv - do j=1, nerv - desc_index(i+j) = glob_to_loc(sndbuf(bsdindx(proc+1)+j)) - end do - i = i + nerv + 1 - nesd = rvsz(proc+1) - desc_index(i) = nesd - do j=1, nesd - desc_index(i+j) = glob_to_loc(rcvbuf(brvindx(proc+1)+j)) - end do - i = i + nesd + 1 + proc = dep_list(k) + desc_index(i) = proc + i = i + 1 + nerv = sdsz(proc+1) + desc_index(i) = nerv + do j=1, nerv + desc_index(i+j) = glob_to_loc(sndbuf(bsdindx(proc+1)+j)) + end do + i = i + nerv + 1 + nesd = rvsz(proc+1) + desc_index(i) = nesd + do j=1, nesd + desc_index(i+j) = glob_to_loc(rcvbuf(brvindx(proc+1)+j)) + end do + i = i + nesd + 1 end do desc_index(i) = - 1 deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info) if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if if (debug) then - write(0,*) me,'end desc_index' - call blacs_barrier(ictxt,'all') + write(0,*) me,'end desc_index' + call psb_barrier(ictxt) endif call psb_erractionrestore(err_act) @@ -254,8 +250,8 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psi_desc_index diff --git a/src/internals/psi_dswapdata.f90 b/src/internals/psi_dswapdata.f90 index 5acc778d9..00f957d6a 100644 --- a/src/internals/psi_dswapdata.f90 +++ b/src/internals/psi_dswapdata.f90 @@ -32,7 +32,9 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod use mpi + use psi_gthsct_mod implicit none integer, intent(in) :: flag, n @@ -43,13 +45,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& & err_act, totxch, ixrec, i, lw, idx_pt,& & snd_pt, rcv_pt - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) @@ -57,80 +59,37 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 - name='psi_dswap_data' + name='psi_swap_data' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then + call psb_info(ictxt,me,np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif + + call psb_get_mpicomm(ictxt,icomm) - call blacs_get(ictxt,10,icomm) - - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_) .ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then + if(data == psb_comm_halo_) then d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index else d_idx => desc_a%halo_index @@ -147,12 +106,12 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) ptp(proc_to_comm) = point_to_proc brvidx(proc_to_comm) = idxr @@ -167,13 +126,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then + if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) all=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -186,7 +145,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) ! gather elements into sendbuffer for swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -204,7 +163,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_double_precision,rcvbuf,rvsz,& & brvidx,mpi_double_precision,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -214,7 +173,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) ! scatter elements from receivebuffer after swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -231,30 +190,30 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then + if (proc_to_comm < me) then ! First I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call dgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) ! Then I receive rcv_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + else if (proc_to_comm > me) then ! First I receive rcv_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) ! Then I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call dgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + else if (proc_to_comm == me) then ! I send to myself idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) @@ -268,11 +227,11 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& @@ -292,17 +251,17 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) ! First I post all the non blocking receives point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) rcv_pt = brvidx(proc_to_comm) call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),& & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -317,7 +276,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) ! Then I post all the blocking sends point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -327,12 +286,12 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),& & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -345,16 +304,16 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) if(.false.) then do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index point_to_proc = ptp(ixrec) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) nerv = d_idx(point_to_proc+psb_n_elem_recv_) @@ -374,11 +333,11 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm .eq. myrow) then + if(proc_to_comm == me) then idx_pt = point_to_proc+psb_elem_recv_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& @@ -392,13 +351,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -427,7 +386,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -435,7 +394,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call dgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) @@ -445,13 +404,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then rcv_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& @@ -473,7 +432,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -483,7 +442,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -525,6 +484,8 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -536,7 +497,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -545,87 +506,44 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid integer :: int_err(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,all real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 name='psi_dswap_datav' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then + call psb_info(ictxt,me,np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then + if(data == psb_comm_halo_) then d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index else d_idx => desc_a%halo_index @@ -643,12 +561,12 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) ptp(proc_to_comm) = point_to_proc brvidx(proc_to_comm) = idxr @@ -663,13 +581,13 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then + if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) all=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -682,7 +600,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) ! gather elements into sendbuffer for swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -699,7 +617,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_double_precision,rcvbuf,rvsz,& & brvidx,mpi_double_precision,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -709,7 +627,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) ! scatter elements from receivebuffer after swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -726,30 +644,30 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then + if (proc_to_comm < me) then ! First I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call dgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) ! Then I receive rcv_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then ! First I receive rcv_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) ! Then I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call dgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then ! I send to myself idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) @@ -763,11 +681,11 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& @@ -787,17 +705,17 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) ! First I post all the non blocking receives point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) rcv_pt = brvidx(proc_to_comm) call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),& & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -812,7 +730,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) ! Then I post all the blocking sends point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -821,12 +739,12 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),& & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -840,15 +758,15 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) if(.false.) then do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index point_to_proc = ptp(ixrec) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) nerv = d_idx(point_to_proc+psb_n_elem_recv_) @@ -868,11 +786,11 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm .eq. myrow) then + if(proc_to_comm == me) then idx_pt = point_to_proc+psb_elem_recv_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& @@ -887,13 +805,13 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -922,7 +840,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -930,7 +848,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call dgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) @@ -940,13 +858,13 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then rcv_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& @@ -968,7 +886,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -978,7 +896,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/internals/psi_dswaptran.f90 b/src/internals/psi_dswaptran.f90 index 9729f667e..6a1c82b77 100644 --- a/src/internals/psi_dswaptran.f90 +++ b/src/internals/psi_dswaptran.f90 @@ -32,6 +32,8 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -43,7 +45,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -53,74 +55,31 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid logical :: swap_mpi, swap_sync, swap_send, swap_recv, all real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 name='psi_dswaptranm' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 + call psb_errpush(4000,name) + goto 9999 end if swap_mpi = iand(flag,psb_swap_mpi_) /= 0 @@ -129,15 +88,15 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data == psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data == psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index end if idxs = 1 @@ -149,323 +108,323 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) do while (proc_to_comm /= -1) - if(proc_to_comm /= myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = n*nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = n*nesd + idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_double_precision,sndbuf,sdsz,& + & bsdidx,mpi_double_precision,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + ! Then I receive + snd_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = bsdidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_precision,sndbuf,sdsz,& - & bsdidx,mpi_double_precision,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call dgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call dgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call dgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm == myrow) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + snd_pt = brvidx(proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_double_precision,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_double_precision,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm /= myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do + else - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - if(proc_to_comm /= myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call dgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm /= myrow) then - snd_pt = bsdidx(proc_to_comm) - call dgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - idx_pt = point_to_proc+nerv+psb_elem_send_ - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if + if(proc_to_comm /= me) then + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + idx_pt = point_to_proc+nerv+psb_elem_send_ + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if @@ -484,8 +443,8 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) if (err_act == act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psi_dswaptranm @@ -530,6 +489,8 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -541,7 +502,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -551,74 +512,31 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid logical :: swap_mpi, swap_sync, swap_send, swap_recv, all real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 name='psi_dswaptranv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 + call psb_errpush(4000,name) + goto 9999 end if swap_mpi = iand(flag,psb_swap_mpi_) /= 0 @@ -627,15 +545,15 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data == psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data == psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index end if idxs = 1 @@ -648,324 +566,323 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) do while (proc_to_comm /= -1) - if(proc_to_comm /= myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = nesd + idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_double_precision,sndbuf,sdsz,& + & bsdidx,mpi_double_precision,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + ! Then I receive + snd_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = bsdidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_precision,sndbuf,sdsz,& - & bsdidx,mpi_double_precision,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call dgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call dgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call dgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call dgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm == myrow) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if (proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + snd_pt = brvidx(proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_double_precision,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_double_precision,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm /= myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - snd_pt = brvidx(proc_to_comm) -!!$ write(0,*) myrow,'Swaptran ',snd_pt,' to',proc_to_comm - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) + else + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - if(proc_to_comm /= myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call dgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm /= myrow) then - snd_pt = bsdidx(proc_to_comm) - call dgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if + if(proc_to_comm /= me) then + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if @@ -973,7 +890,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if ((info==0).and. (all)) then - write(0,*) myrow, 'Deallocating sndbuf? ' + write(0,*) me, 'Deallocating sndbuf? ' deallocate(sndbuf,rcvbuf,stat=info) end if @@ -990,8 +907,8 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) if (err_act == act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/src/internals/psi_gthsct.f90 b/src/internals/psi_gthsct.f90 index a79773f85..7680759ea 100644 --- a/src/internals/psi_gthsct.f90 +++ b/src/internals/psi_gthsct.f90 @@ -28,637 +28,322 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_dgthm(n,k,idx,x,y) +module psi_gthsct_mod - implicit none + interface psi_gth + module procedure psi_igthm, psi_igthv,& + & psi_dgthm, psi_dgthv,& + & psi_zgthm, psi_zgthv + end interface - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) + interface psi_sct + module procedure psi_isctm, psi_isctv,& + & psi_dsctm, psi_dsctv,& + & psi_zsctm, psi_zsctv + end interface - ! Locals - integer :: i, j, pt +contains + subroutine psi_dgthm(n,k,idx,x,y) - pt=0 - do j=1,k - do i=1,n + implicit none + + integer :: n, k, idx(:) + real(kind(1.d0)) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n pt=pt+1 y(pt)=x(idx(i),j) - end do - end do + end do + end do -end subroutine psi_dgthm + end subroutine psi_dgthm + + subroutine psi_dgthv(n,idx,x,y) + + implicit none + + integer :: n, idx(:) + real(kind(1.d0)) :: x(:), y(:) + + ! Locals + integer :: i, j + + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_dgthv -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_dgthv(n,idx,x,y) + subroutine psi_dsctm(n,k,idx,x,beta,y) - implicit none + implicit none - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) + integer :: n, k, idx(:) + real(kind(1.d0)) :: beta, x(:), y(:,:) - ! Locals - integer :: i, j + ! Locals + integer :: i, j, pt - do i=1,n - y(i)=x(idx(i)) - end do - -end subroutine psi_dgthv - -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -subroutine psi_dsctm(n,k,idx,x,beta,y) - - implicit none - - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta.eq.0.d0) then - pt=0 - do j=1,k + if (beta.eq.0.d0) then + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) + pt=pt+1 + y(idx(i),j) = x(pt) end do - end do - else if (beta.eq.1.d0) then - pt=0 - do j=1,k + end do + else if (beta.eq.1.d0) then + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) end do - end do - else - pt=0 - do j=1,k + end do + else + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) end do - end do - end if -end subroutine psi_dsctm + end do + end if + end subroutine psi_dsctm -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_dsctv(n,idx,x,beta,y) - implicit none + subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) + implicit none - ! Locals - integer :: i, j, pt + integer :: n, k, idx(:) + real(kind(1.d0)) :: beta, x(:), y(:) - if (beta.eq.0.d0) then - do i=1,n + ! Locals + integer :: i, j, pt + + if (beta.eq.0.d0) then + do i=1,n y(idx(i)) = x(i) - end do - else if (beta.eq.1.d0) then - do i=1,n + end do + else if (beta.eq.1.d0) then + do i=1,n y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n + end do + else + do i=1,n y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if -end subroutine psi_dsctv + end do + end if + end subroutine psi_dsctv + subroutine psi_igthm(n,k,idx,x,y) -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ + implicit none -subroutine psi_igthm(n,k,idx,x,y) + integer :: n, k, idx(:) + integer :: x(:,:), y(:) - implicit none + ! Locals + integer :: i, j, pt - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n + pt=0 + do j=1,k + do i=1,n pt=pt+1 y(pt)=x(idx(i),j) - end do - end do + end do + end do -end subroutine psi_igthm - -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -subroutine psi_igthv(n,idx,x,y) - - implicit none - - integer :: n, idx(:) - integer :: x(:), y(:) - - ! Locals - integer :: i, j - - do i=1,n - y(i)=x(idx(i)) - end do - -end subroutine psi_igthv + end subroutine psi_igthm -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_isctm(n,k,idx,x,beta,y) + subroutine psi_igthv(n,idx,x,y) - implicit none + implicit none - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) + integer :: n, idx(:) + integer :: x(:), y(:) - ! Locals - integer :: i, j, pt + ! Locals + integer :: i, j - if (beta.eq.0.d0) then - pt=0 - do j=1,k + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_igthv + + + + subroutine psi_isctm(n,k,idx,x,beta,y) + + implicit none + + integer :: n, k, idx(:) + integer :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta.eq.0.d0) then + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) + pt=pt+1 + y(idx(i),j) = x(pt) end do - end do - else if (beta.eq.1.d0) then - pt=0 - do j=1,k + end do + else if (beta.eq.1.d0) then + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) end do - end do - else - pt=0 - do j=1,k + end do + else + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) end do - end do - end if -end subroutine psi_isctm + end do + end if + end subroutine psi_isctm -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_isctv(n,idx,x,beta,y) + subroutine psi_isctv(n,idx,x,beta,y) - implicit none + implicit none - integer :: n, k, idx(:) - integer :: beta, x(:), y(:) + integer :: n, k, idx(:) + integer :: beta, x(:), y(:) - ! Locals - integer :: i, j, pt + ! Locals + integer :: i, j, pt - if (beta.eq.0.d0) then - do i=1,n + if (beta.eq.0.d0) then + do i=1,n y(idx(i)) = x(i) - end do - else if (beta.eq.1.d0) then - do i=1,n + end do + else if (beta.eq.1.d0) then + do i=1,n y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n + end do + else + do i=1,n y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if -end subroutine psi_isctv + end do + end if + end subroutine psi_isctv + subroutine psi_zgthm(n,k,idx,x,y) -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_zgthm(n,k,idx,x,y) + implicit none - implicit none + integer :: n, k, idx(:) + complex(kind(1.d0)) :: x(:,:), y(:) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: x(:,:), y(:) + ! Locals + integer :: i, j, pt - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n + pt=0 + do j=1,k + do i=1,n pt=pt+1 y(pt)=x(idx(i),j) - end do - end do + end do + end do -end subroutine psi_zgthm + end subroutine psi_zgthm -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_zgthv(n,idx,x,y) + subroutine psi_zgthv(n,idx,x,y) - implicit none + implicit none - integer :: n, idx(:) - complex(kind(1.d0)) :: x(:), y(:) + integer :: n, idx(:) + complex(kind(1.d0)) :: x(:), y(:) - ! Locals - integer :: i, j + ! Locals + integer :: i, j - do i=1,n - y(i)=x(idx(i)) - end do - -end subroutine psi_zgthv + do i=1,n + y(i)=x(idx(i)) + end do -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ + end subroutine psi_zgthv -subroutine psi_zsctm(n,k,idx,x,beta,y) + subroutine psi_zsctm(n,k,idx,x,beta,y) - implicit none + implicit none - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:,:) + integer :: n, k, idx(:) + complex(kind(1.d0)) :: beta, x(:), y(:,:) - ! Locals - integer :: i, j, pt + ! Locals + integer :: i, j, pt - if (beta.eq.0.d0) then - pt=0 - do j=1,k + if (beta.eq.0.d0) then + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) + pt=pt+1 + y(idx(i),j) = x(pt) end do - end do - else if (beta.eq.1.d0) then - pt=0 - do j=1,k + end do + else if (beta.eq.1.d0) then + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) end do - end do - else - pt=0 - do j=1,k + end do + else + pt=0 + do j=1,k do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) end do - end do - end if -end subroutine psi_zsctm + end do + end if + end subroutine psi_zsctm -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psi_zsctv(n,idx,x,beta,y) - implicit none + subroutine psi_zsctv(n,idx,x,beta,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:) + implicit none - ! Locals - integer :: i, j, pt + integer :: n, k, idx(:) + complex(kind(1.d0)) :: beta, x(:), y(:) - if (beta.eq.0.d0) then - do i=1,n + ! Locals + integer :: i, j, pt + + if (beta.eq.0.d0) then + do i=1,n y(idx(i)) = x(i) - end do - else if (beta.eq.1.d0) then - do i=1,n + end do + else if (beta.eq.1.d0) then + do i=1,n y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n + end do + else + do i=1,n y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if -end subroutine psi_zsctv + end do + end if + end subroutine psi_zsctv + +end module psi_gthsct_mod diff --git a/src/internals/psi_iswapdata.f90 b/src/internals/psi_iswapdata.f90 index a6261259e..b75a0ca95 100644 --- a/src/internals/psi_iswapdata.f90 +++ b/src/internals/psi_iswapdata.f90 @@ -32,6 +32,8 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -43,13 +45,13 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& & err_act, totxch, ixrec, i, lw, idx_pt,& & snd_pt, rcv_pt - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) @@ -57,84 +59,41 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 name='psi_dswap_data' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif + + call psb_get_mpicomm(ictxt,icomm) - call blacs_get(ictxt,10,icomm) - - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_) .ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else d_idx => desc_a%halo_index end if @@ -147,325 +106,325 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = n*nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = n*nesd + idxs = idxs+sdsz(proc_to_comm) point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & mpi_integer,rcvbuf,rvsz,& + & brvidx,mpi_integer,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + ! Then I receive + rcv_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + rcv_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & mpi_integer,rcvbuf,rvsz,& - & brvidx,mpi_integer,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + else + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call igesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call igesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + rcv_pt = brvidx(proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do + else - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + else + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm .eq. myrow) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call igesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - rcv_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if + if(proc_to_comm /= me) then + rcv_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + else + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if @@ -473,7 +432,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -483,9 +442,9 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return end subroutine psi_iswapdatam @@ -525,6 +484,8 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -536,7 +497,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -545,93 +506,50 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid integer :: int_err(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv, all integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 name='psi_dswap_datav' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index end if idxs = 1 @@ -643,324 +561,324 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = n*nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = n*nesd + idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & mpi_integer,rcvbuf,rvsz,& + & brvidx,mpi_integer,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + ! Then I receive + rcv_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + rcv_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & mpi_integer,rcvbuf,rvsz,& - & brvidx,mpi_integer,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + else + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call igesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call igesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + rcv_pt = brvidx(proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + else + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + else + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm .eq. myrow) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end do + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call igesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - rcv_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if + if(proc_to_comm /= me) then + rcv_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + else + idx_pt = point_to_proc+psb_elem_recv_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if @@ -968,7 +886,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -978,9 +896,9 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return end subroutine psi_iswapdatav diff --git a/src/internals/psi_iswaptran.f90 b/src/internals/psi_iswaptran.f90 index 0ffd2ce77..e048dc6c3 100644 --- a/src/internals/psi_iswaptran.f90 +++ b/src/internals/psi_iswaptran.f90 @@ -32,6 +32,8 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -43,7 +45,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -53,91 +55,48 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid logical :: swap_mpi, swap_sync, swap_send, swap_recv, all integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface - info = 0 name='psi_dswaptranm' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index end if idxs = 1 @@ -148,324 +107,324 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = n*nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = n*nesd + idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_integer,sndbuf,sdsz,& + & bsdidx,mpi_integer,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + ! Then I receive + snd_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = bsdidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_integer,sndbuf,sdsz,& - & bsdidx,mpi_integer,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call igesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call igerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call igesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + snd_pt = brvidx(proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do + else - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm .eq. myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call igesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - snd_pt = bsdidx(proc_to_comm) - call igerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - idx_pt = point_to_proc+nerv+psb_elem_send_ - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if + if(proc_to_comm /= me) then + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + idx_pt = point_to_proc+nerv+psb_elem_send_ + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if @@ -473,7 +432,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -483,9 +442,9 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return end subroutine psi_iswaptranm @@ -527,6 +486,8 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -538,7 +499,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -548,91 +509,49 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid logical :: swap_mpi, swap_sync, swap_send, swap_recv, all integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - end interface info = 0 name='psi_dswaptranv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index end if idxs = 1 @@ -644,332 +563,338 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = nesd + idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_integer,sndbuf,sdsz,& + & bsdidx,mpi_integer,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + ! Then I receive + snd_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = bsdidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_integer,sndbuf,sdsz,& - & bsdidx,mpi_integer,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call igesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call igerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call igerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call igesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if (proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + snd_pt = brvidx(proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_integer,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + else + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm .eq. myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call igesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - snd_pt = bsdidx(proc_to_comm) - call igerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if + if(proc_to_comm /= me) then + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if deallocate(sdsz,rvsz,bsdidx,& & brvidx,rvhd,prcid,& & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if ((info==0).and. (all)) then + write(0,*) me, 'Deallocating sndbuf? ' + deallocate(sndbuf,rcvbuf,stat=info) + + end if + + if(info /= 0) then + write(0,*) 'Error on deallocate ',info call psb_errpush(4000,name) goto 9999 end if @@ -979,9 +904,9 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return end subroutine psi_iswaptranv diff --git a/src/internals/psi_zswapdata.f90 b/src/internals/psi_zswapdata.f90 index fc7e3b937..e1834688f 100644 --- a/src/internals/psi_zswapdata.f90 +++ b/src/internals/psi_zswapdata.f90 @@ -32,6 +32,8 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -43,13 +45,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& & err_act, totxch, ixrec, i, lw, idx_pt,& & snd_pt, rcv_pt - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) @@ -57,96 +59,37 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - subroutine psi_zgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_zgthm - subroutine psi_zgthv(n,idx,x,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: x(:), y(:) - end subroutine psi_zgthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - subroutine psi_zsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_zsctm - subroutine psi_zsctv(n,idx,x,beta,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_zsctv - end interface - info = 0 name='psi_zswap_data' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then + call psb_info(ictxt,me,np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif + + call psb_get_mpicomm(ictxt,icomm) - call blacs_get(ictxt,10,icomm) - - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_) .ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then + if(data == psb_comm_halo_) then d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index else d_idx => desc_a%halo_index @@ -163,12 +106,12 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) ptp(proc_to_comm) = point_to_proc brvidx(proc_to_comm) = idxr @@ -183,13 +126,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then + if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) all=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -202,7 +145,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) ! gather elements into sendbuffer for swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -220,7 +163,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_double_complex,rcvbuf,rvsz,& & brvidx,mpi_double_complex,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -230,7 +173,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) ! scatter elements from receivebuffer after swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -247,30 +190,30 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then + if (proc_to_comm < me) then ! First I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call zgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) ! Then I receive rcv_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + else if (proc_to_comm > me) then ! First I receive rcv_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) ! Then I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call zgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + else if (proc_to_comm == me) then ! I send to myself idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) @@ -284,11 +227,11 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& @@ -308,17 +251,17 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) ! First I post all the non blocking receives point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) rcv_pt = brvidx(proc_to_comm) call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),& & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -333,7 +276,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) ! Then I post all the blocking sends point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -343,12 +286,12 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),& & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -361,16 +304,16 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) if(.false.) then do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index point_to_proc = ptp(ixrec) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) nerv = d_idx(point_to_proc+psb_n_elem_recv_) @@ -390,11 +333,11 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm .eq. myrow) then + if(proc_to_comm == me) then idx_pt = point_to_proc+psb_elem_recv_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& @@ -408,13 +351,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -443,7 +386,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -451,7 +394,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call zgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) @@ -461,13 +404,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then rcv_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& @@ -489,7 +432,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -499,7 +442,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -541,6 +484,8 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -552,7 +497,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -561,103 +506,44 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid integer :: int_err(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,all complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - subroutine psi_zgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_zgthm - subroutine psi_zgthv(n,idx,x,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: x(:), y(:) - end subroutine psi_zgthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - subroutine psi_zsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_zsctm - subroutine psi_zsctv(n,idx,x,beta,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_zsctv - end interface - info = 0 name='psi_zswap_datav' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then + call psb_info(ictxt,me,np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then + if(data == psb_comm_halo_) then d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index else d_idx => desc_a%halo_index @@ -675,12 +561,12 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) ptp(proc_to_comm) = point_to_proc brvidx(proc_to_comm) = idxr @@ -695,13 +581,13 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then + if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) all=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -714,7 +600,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) ! gather elements into sendbuffer for swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -731,7 +617,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_double_complex,rcvbuf,rvsz,& & brvidx,mpi_double_complex,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -741,7 +627,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) ! scatter elements from receivebuffer after swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -758,30 +644,30 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then + if (proc_to_comm < me) then ! First I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call zgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) ! Then I receive rcv_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then ! First I receive rcv_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) ! Then I send idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call zgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then ! I send to myself idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) @@ -795,11 +681,11 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& @@ -819,17 +705,17 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) ! First I post all the non blocking receives point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) rcv_pt = brvidx(proc_to_comm) call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),& & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -844,7 +730,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) ! Then I post all the blocking sends point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -853,12 +739,12 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),& & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -872,15 +758,15 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) if(.false.) then do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index point_to_proc = ptp(ixrec) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) nerv = d_idx(point_to_proc+psb_n_elem_recv_) @@ -900,11 +786,11 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm .eq. myrow) then + if(proc_to_comm == me) then idx_pt = point_to_proc+psb_elem_recv_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& @@ -919,13 +805,13 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -954,7 +840,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -962,7 +848,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) snd_pt = bsdidx(proc_to_comm) call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - call zgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) @@ -972,13 +858,13 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then rcv_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& @@ -1000,7 +886,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -1010,7 +896,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/internals/psi_zswaptran.f90 b/src/internals/psi_zswaptran.f90 index 0b7b65670..cde85c2a4 100644 --- a/src/internals/psi_zswaptran.f90 +++ b/src/internals/psi_zswaptran.f90 @@ -32,6 +32,8 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -43,7 +45,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -53,101 +55,42 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid logical :: swap_mpi, swap_sync, swap_send, swap_recv, all complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - subroutine psi_zgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_zgthm - subroutine psi_zgthv(n,idx,x,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: x(:), y(:) - end subroutine psi_zgthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - subroutine psi_zsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_zsctm - subroutine psi_zsctv(n,idx,x,beta,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_zsctv - end interface - info = 0 name='psi_zswaptranm' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then + call psb_info(ictxt,me,np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then + if(data == psb_comm_halo_) then d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index else d_idx => desc_a%halo_index @@ -164,12 +107,12 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) ptp(proc_to_comm) = point_to_proc brvidx(proc_to_comm) = idxr @@ -184,13 +127,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then + if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) all=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -203,7 +146,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) ! gather elements into sendbuffer for swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -221,7 +164,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) call mpi_alltoallv(rcvbuf,rvsz,brvidx,& & mpi_double_complex,sndbuf,sdsz,& & bsdidx,mpi_double_complex,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -231,7 +174,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) ! scatter elements from receivebuffer after swapping point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -248,30 +191,30 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then + if (proc_to_comm < me) then ! First I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call zgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) ! Then I receive snd_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + else if (proc_to_comm > me) then ! First I receive snd_pt = bsdidx(proc_to_comm) - call zgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) ! Then I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call zgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + else if (proc_to_comm == me) then ! I send to myself idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = bsdidx(proc_to_comm) @@ -285,11 +228,11 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& @@ -310,17 +253,17 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) ! First I post all the non blocking receives point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),& + call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),& & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -335,7 +278,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) ! Then I post all the blocking sends point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -344,12 +287,12 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),& & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -362,16 +305,16 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) if(.false.) then do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index point_to_proc = ptp(ixrec) proc_to_comm = d_idx(point_to_proc+psb_proc_id_) nerv = d_idx(point_to_proc+psb_n_elem_recv_) @@ -391,11 +334,11 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm .eq. myrow) then + if(proc_to_comm == me) then idx_pt = point_to_proc+nerv+psb_elem_send_ rcv_pt = brvidx(proc_to_comm) call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& @@ -409,13 +352,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then + if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) @@ -444,7 +387,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) @@ -452,7 +395,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call zgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) @@ -462,13 +405,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) point_to_proc = 1 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then + if(proc_to_comm /= me) then snd_pt = bsdidx(proc_to_comm) - call zgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) idx_pt = point_to_proc+nerv+psb_elem_send_ call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) @@ -489,7 +432,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) & brvidx,rvhd,prcid,& & ptp,stat=info) if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if @@ -499,7 +442,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -546,6 +489,8 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type + use psb_penv_mod + use psi_gthsct_mod use mpi implicit none @@ -557,7 +502,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) integer, optional :: data ! locals - integer :: ictxt, nprow, npcol, myrow,& + integer :: ictxt, np, npcol, me,& & mycol, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, errlen, ifcomm, rank,& @@ -567,107 +512,48 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) integer, pointer, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, ptp, rvhd, d_idx integer :: int_err(5) - integer :: blacs_pnum, krecvid, ksendid + integer :: krecvid, ksendid logical :: swap_mpi, swap_sync, swap_send, swap_recv, all complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name, ch_err - interface psi_gth - subroutine psi_dgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_dgthm - subroutine psi_dgthv(n,idx,x,y) - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - end subroutine psi_dgthv - subroutine psi_igthm(n,k,idx,x,y) - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - end subroutine psi_igthm - subroutine psi_igthv(n,idx,x,y) - integer :: n, idx(:) - integer :: x(:), y(:) - end subroutine psi_igthv - subroutine psi_zgthm(n,k,idx,x,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: x(:,:), y(:) - end subroutine psi_zgthm - subroutine psi_zgthv(n,idx,x,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: x(:), y(:) - end subroutine psi_zgthv - end interface - - interface psi_sct - subroutine psi_dsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_dsctm - subroutine psi_dsctv(n,idx,x,beta,y) - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_dsctv - subroutine psi_isctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - end subroutine psi_isctm - subroutine psi_isctv(n,idx,x,beta,y) - integer :: n, idx(:) - integer :: beta, x(:), y(:) - end subroutine psi_isctv - subroutine psi_zsctm(n,k,idx,x,beta,y) - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:,:) - end subroutine psi_zsctm - subroutine psi_zsctv(n,idx,x,beta,y) - integer :: n, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:) - end subroutine psi_zsctv - end interface - info = 0 name='psi_zswaptranv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - call blacs_get(ictxt,10,icomm) + call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& - & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& - & ptp(0:nprow-1), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& + & ptp(0:np-1), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 end if - swap_mpi = iand(flag,psb_swap_mpi_).ne.0 - swap_sync = iand(flag,psb_swap_sync_).ne.0 - swap_send = iand(flag,psb_swap_send_).ne.0 - swap_recv = iand(flag,psb_swap_recv_).ne.0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 if(present(data)) then - if(data.eq.psb_comm_halo_) then - d_idx => desc_a%halo_index - else if(data.eq.psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - else - d_idx => desc_a%halo_index - end if + if(data == psb_comm_halo_) then + d_idx => desc_a%halo_index + else if(data == psb_comm_ovr_) then + d_idx => desc_a%ovrlap_index + else + d_idx => desc_a%halo_index + end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index end if idxs = 1 @@ -679,332 +565,338 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) ! prepare info for communications proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm.ne.-1) - if(proc_to_comm .ne. myrow) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + do while (proc_to_comm /= -1) + if(proc_to_comm /= me) totxch = totxch+1 + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol) - ptp(proc_to_comm) = point_to_proc + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = idxr + rvsz(proc_to_comm) = nerv + idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = nesd - idxs = idxs+sdsz(proc_to_comm) + bsdidx(proc_to_comm) = idxs + sdsz(proc_to_comm) = nesd + idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - if((idxr+idxs).lt.size(work)) then - sndbuf => work(1:idxs) - rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + if((idxr+idxs) < size(work)) then + sndbuf => work(1:idxs) + rcvbuf => work(idxs+1:idxs+idxr) + all=.false. else - allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) - if(info.ne.0) then - call psb_errpush(4000,name) - goto 9999 - end if - all=.true. + allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + all=.true. end if ! Case SWAP_MPI if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! gather elements into sendbuffer for swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_double_complex,sndbuf,sdsz,& + & bsdidx,mpi_double_complex,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + ! scatter elements from receivebuffer after swapping + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + else if (swap_sync) then + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then + ! First I send idx_pt = point_to_proc+psb_elem_recv_ rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + ! Then I receive + snd_pt = brvidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + ! First I receive + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + ! Then I send + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + ! I send to myself + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = bsdidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_complex,sndbuf,sdsz,& - & bsdidx,mpi_double_complex,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if(proc_to_comm /= me) then idx_pt = point_to_proc+nerv+psb_elem_send_ snd_pt = bsdidx(proc_to_comm) call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else if (swap_sync) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if (proc_to_comm .lt. myrow) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call zgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call zgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - else if (proc_to_comm .gt. myrow) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call zgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call zgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) - else if (proc_to_comm .eq. myrow) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + ! First I post all the non blocking receives + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + if (proc_to_comm /= me) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + snd_pt = brvidx(proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& + & mpi_double_complex,prcid(proc_to_comm),& + & p2ptag, icomm,rvhd(proc_to_comm),iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + ! Then I post all the blocking sends + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + if(proc_to_comm /= me) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& + & mpi_double_complex,prcid(proc_to_comm),& + & p2ptag,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do + + if(.false.) then + do i=1, totxch + call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (ixrec /= mpi_undefined) then + ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index + point_to_proc = ptp(ixrec) + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + else + int_err(1) = ixrec + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end do + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - p2ptag = krecvid(ictxt,proc_to_comm,myrow) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + if(proc_to_comm == me) then + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) end if point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) + else + + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) nerv = d_idx(point_to_proc+psb_n_elem_recv_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + if(proc_to_comm /= me) then + call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + idx_pt = point_to_proc+nerv+psb_elem_send_ + snd_pt = bsdidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - if(proc_to_comm .ne. myrow) then - p2ptag=ksendid(ictxt,proc_to_comm,myrow) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag,icomm,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if + point_to_proc = point_to_proc+nerv+nesd+3 proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec .ne. mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm .eq. myrow) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm.ne.myrow) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret.ne.mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - call zgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm .ne. -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + point_to_proc = 1 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + do while (proc_to_comm /= -1) + nerv = d_idx(point_to_proc+psb_n_elem_recv_) + nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - if(proc_to_comm.ne.myrow) then - snd_pt = bsdidx(proc_to_comm) - call zgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if + if(proc_to_comm /= me) then + snd_pt = bsdidx(proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + idx_pt = point_to_proc+psb_elem_recv_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + else + idx_pt = point_to_proc+nerv+psb_elem_send_ + rcv_pt = brvidx(proc_to_comm) + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + point_to_proc = point_to_proc+nerv+nesd+3 + proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + end do end if deallocate(sdsz,rvsz,bsdidx,& & brvidx,rvhd,prcid,& & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) - if(info.ne.0) then + if ((info==0).and. (all)) then + write(0,*) me, 'Deallocating sndbuf? ' + deallocate(sndbuf,rcvbuf,stat=info) + + end if + + if(info /= 0) then + write(0,*) 'Error on deallocate ',info call psb_errpush(4000,name) goto 9999 end if @@ -1014,9 +906,9 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return end subroutine psi_zswaptranv diff --git a/src/methd/psb_dbicg.f90 b/src/methd/psb_dbicg.f90 index b374c8157..42042b60d 100644 --- a/src/methd/psb_dbicg.f90 +++ b/src/methd/psb_dbicg.f90 @@ -83,6 +83,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod implicit none !!$ parameters @@ -103,7 +104,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,& integer, pointer :: iperm(:), ipnull(:), ipsave(:), int_err(:) real(kind(1.d0)) ::rerr integer ::litmax, liter, naux, m, mglob, it, itrace_,& - & nprows,npcols,me,mecol, n_row, n_col, istop_, err_act + & np,me, n_row, n_col, istop_, err_act character ::diagl, diagu logical, parameter :: debug = .false. logical, parameter :: exchange=.true., noexchange=.false. @@ -120,8 +121,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,& if (debug) write(*,*) 'entering psb_dbicg' ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprows,npcols,me,mecol) - if (debug) write(*,*) 'psb_dbicg: from gridinfo',nprows,npcols,me + call psb_info(ictxt, me, np) + if (debug) write(*,*) 'psb_dbicg: from gridinfo',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) diff --git a/src/methd/psb_dcg.f90 b/src/methd/psb_dcg.f90 index f4a607ce9..f30f4977f 100644 --- a/src/methd/psb_dcg.f90 +++ b/src/methd/psb_dcg.f90 @@ -83,6 +83,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod implicit none !!$ Parameters @@ -103,7 +104,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,& real(kind(1.d0)) ::alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& & sigma integer :: litmax, liter, istop_, naux, m, mglob, it, itx, itrace_,& - & nprows,npcols,me,mecol, n_col, isvch, ich, ictxt, n_row,err_act, int_err(5) + & np,me, n_col, isvch, ich, ictxt, n_row,err_act, int_err(5) character ::diagl, diagu logical, parameter :: exchange=.true., noexchange=.false. character(len=20) :: name,ch_err @@ -114,7 +115,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,& ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprows,npcols,me,mecol) + call psb_info(ictxt, me, np) mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) diff --git a/src/methd/psb_dcgs.f90 b/src/methd/psb_dcgs.f90 index e4ca086c0..70a1df762 100644 --- a/src/methd/psb_dcgs.f90 +++ b/src/methd/psb_dcgs.f90 @@ -81,6 +81,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod implicit none !!$ parameters @@ -101,7 +102,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& Integer, Pointer :: iperm(:), ipnull(:), ipsave(:) Real(Kind(1.d0)) ::rerr Integer ::litmax, liter, naux, m, mglob, it, itrace_,int_err(5),& - & nprows,npcols,me,mecol, n_row, n_col,istop_, err_act + & np,me,mecol, n_row, n_col,istop_, err_act Character ::diagl, diagu Logical, Parameter :: exchange=.True., noexchange=.False. Integer, Parameter :: irmax = 8 @@ -118,8 +119,8 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& If (debug) Write(*,*) 'entering psb_dcgs' ictxt = desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol) - If (debug) Write(*,*) 'psb_dcgs: from gridinfo',nprows,npcols,me + Call psb_info(ictxt, me, np) + If (debug) Write(*,*) 'psb_dcgs: from gridinfo',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) diff --git a/src/methd/psb_dcgstab.f90 b/src/methd/psb_dcgstab.f90 index 64626d2a6..3f8a6cff7 100644 --- a/src/methd/psb_dcgstab.f90 +++ b/src/methd/psb_dcgstab.f90 @@ -82,6 +82,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod Implicit None !!$ parameters Type(psb_dspmat_type), Intent(in) :: a @@ -101,7 +102,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& Integer, Pointer :: iperm(:), ipnull(:), ipsave(:) Real(Kind(1.d0)) ::rerr Integer ::litmax, liter, naux, m, mglob, it,itrace_,& - & nprows,npcols,myrow,mycol, n_row, n_col + & np,me, n_row, n_col Character ::diagl, diagu Logical, Parameter :: debug = .false. Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. @@ -121,8 +122,8 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& If (debug) Write(*,*) 'Entering PSB_DCGSTAB',present(istop) ictxt = desc_a%matrix_data(psb_ctxt_) - CALL blacs_gridinfo(ictxt,nprows,npcols,myrow,mycol) - if (debug) write(*,*) 'PSB_DCGSTAB: From GRIDINFO',nprows,npcols,myrow + call psb_info(ictxt, me, np) + if (debug) write(*,*) 'PSB_DCGSTAB: From GRIDINFO',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) @@ -246,7 +247,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& End If If (rn0 == 0.d0 ) Then If (itrace_ > 0 ) Then - If (myrow == 0) Write(*,*) 'BiCGSTAB: ',itx,rn0 + If (me == 0) Write(*,*) 'BiCGSTAB: ',itx,rn0 Endif Exit restart End If @@ -268,7 +269,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& End If If (itrace_ > 0) then - if (((itx==0).or.(mod(itx,itrace_)==0)).and.(myrow == 0)) & + if (((itx==0).or.(mod(itx,itrace_)==0)).and.(me == 0)) & & write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr Endif @@ -278,9 +279,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& If (debug) Write(*,*) 'Iteration: ',itx rho_old = rho rho = psb_gedot(q,r,desc_a,info) -!!$ call blacs_barrier(ictxt,'All') ! to be removed -!!$ write(0,'(i2," rho old ",2(f,2x))')myrow,rho,rho_old -!!$ call blacs_barrier(ictxt,'All') ! to be removed +!!$ write(0,'(i2," rho old ",2(f,2x))')me,rho,rho_old If (rho==dzero) Then If (debug) Write(0,*) 'Bi-CGSTAB Itxation breakdown R',rho Exit iteration @@ -366,7 +365,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& If (itx.Ge.litmax) Exit restart If (itrace_ > 0) then - if ((mod(itx,itrace_)==0).and.(myrow == 0)) & + if ((mod(itx,itrace_)==0).and.(me == 0)) & & write(*,'(a,i4,3(2x,es10.4)))') & & 'bicgstab: ',itx,rerr Endif @@ -375,7 +374,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& End Do restart If (itrace_ > 0) then - if (myrow == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr + if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr Endif If (Present(err)) err=rerr diff --git a/src/methd/psb_dcgstabl.f90 b/src/methd/psb_dcgstabl.f90 index ca87a7df9..99bfa777a 100644 --- a/src/methd/psb_dcgstabl.f90 +++ b/src/methd/psb_dcgstabl.f90 @@ -88,6 +88,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod implicit none !!$ parameters @@ -110,7 +111,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& Integer, Pointer :: iperm(:), ipnull(:), ipsave(:) Real(Kind(1.d0)) ::rerr Integer ::litmax, liter, naux, m, mglob, it, itrace_,& - & nprows,npcols,me,mecol, n_row, n_col, nl, err_act + & np,me, n_row, n_col, nl, err_act Character ::diagl, diagu Logical, Parameter :: exchange=.True., noexchange=.False. Integer, Parameter :: irmax = 8 @@ -127,9 +128,9 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& If (debug) Write(0,*) 'entering psb_dbicgstabl' ictxt = desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol) + Call psb_info(ictxt, me, np) - If (debug) Write(0,*) 'psb_dbicgstabl: from gridinfo',nprows,npcols,me + If (debug) Write(0,*) 'psb_dbicgstabl: from gridinfo',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) diff --git a/src/methd/psb_dgmresr.f90 b/src/methd/psb_dgmresr.f90 index 5bcb59288..01c637069 100644 --- a/src/methd/psb_dgmresr.f90 +++ b/src/methd/psb_dgmresr.f90 @@ -90,6 +90,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod implicit none !!$ Parameters @@ -112,7 +113,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,& Integer, Pointer :: iperm(:), ipnull(:), ipsave(:), ierrv(:) Real(Kind(1.d0)) :: rerr, scal, gm Integer ::litmax, liter, naux, m, mglob, it,k, itrace_,& - & nprows,npcols,me,mecol, n_row, n_col, nl, int_err(5) + & np,me, n_row, n_col, nl, int_err(5) Character ::diagl, diagu Logical, Parameter :: exchange=.True., noexchange=.False. Integer, Parameter :: irmax = 8 @@ -130,9 +131,9 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,& If (debug) Write(0,*) 'entering psb_dgmres' ictxt = desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol) + Call psb_info(ictxt, me, np) - If (debug) Write(0,*) 'psb_dgmres: from gridinfo',nprows,npcols,me + If (debug) Write(0,*) 'psb_dgmres: from gridinfo',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) diff --git a/src/methd/psb_zcgs.f90 b/src/methd/psb_zcgs.f90 index a95c471ed..172bbe8a2 100644 --- a/src/methd/psb_zcgs.f90 +++ b/src/methd/psb_zcgs.f90 @@ -81,6 +81,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod implicit none !!$ parameters @@ -101,7 +102,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,& Integer, Pointer :: iperm(:), ipnull(:), ipsave(:) Real(Kind(1.d0)) ::rerr Integer ::litmax, liter, naux, m, mglob, it, itrace_,int_err(5),& - & nprows,npcols,me,mecol, n_row, n_col,istop_, err_act + & np,me, n_row, n_col,istop_, err_act Character ::diagl, diagu Logical, Parameter :: exchange=.True., noexchange=.False. Integer, Parameter :: irmax = 8 @@ -118,8 +119,8 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,& If (debug) Write(*,*) 'entering psb_zcgs' ictxt = desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol) - If (debug) Write(*,*) 'psb_zcgs: from gridinfo',nprows,npcols,me + Call psb_info(ictxt, me, np) + If (debug) Write(*,*) 'psb_zcgs: from gridinfo',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) diff --git a/src/methd/psb_zcgstab.f90 b/src/methd/psb_zcgstab.f90 index a10664112..e6cf3f7fa 100644 --- a/src/methd/psb_zcgstab.f90 +++ b/src/methd/psb_zcgstab.f90 @@ -82,6 +82,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& use psb_const_mod use psb_prec_mod use psb_error_mod + use psb_penv_mod Implicit None !!$ parameters Type(psb_zspmat_type), Intent(in) :: a @@ -101,7 +102,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& Integer, Pointer :: iperm(:), ipnull(:), ipsave(:) Real(Kind(1.d0)) :: rerr Integer :: litmax, liter, naux, m, mglob, it,itrace_,& - & nprows,npcols,myrow,mycol, n_row, n_col + & np,me, n_row, n_col Character ::diagl, diagu Logical, Parameter :: debug = .false. Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. @@ -121,8 +122,8 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& If (debug) Write(*,*) 'Entering PSB_ZCGSTAB',present(istop) ictxt = desc_a%matrix_data(psb_ctxt_) - CALL blacs_gridinfo(ictxt,nprows,npcols,myrow,mycol) - if (debug) write(*,*) 'PSB_ZCGSTAB: From GRIDINFO',nprows,npcols,myrow + CALL psb_info(ictxt, me, np) + if (debug) write(*,*) 'PSB_ZCGSTAB: From GRIDINFO',np,me mglob = desc_a%matrix_data(psb_m_) n_row = desc_a%matrix_data(psb_n_row_) @@ -256,7 +257,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& End If If (itrace_ > 0) then - if ((mod(itx,itrace_)==0).and.(myrow == 0))& + if ((mod(itx,itrace_)==0).and.(me == 0))& & write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr end If @@ -352,14 +353,14 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& If (itx.Ge.litmax) Exit restart If (itrace_ > 0) then - if ((mod(itx,itrace_)==0).and.(myrow == 0))& + if ((mod(itx,itrace_)==0).and.(me == 0))& & write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr end If End Do iteration End Do restart If (itrace_ > 0) then - if (myrow == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr + if (me == 0) write(*,'(a,i4,3(2x,es10.4))') 'bicgstab: ',itx,rerr end If If (Present(err)) err=rerr diff --git a/src/modules/extra_env.f90 b/src/modules/extra_env.f90 index 4f7e27b4c..4a17f8bbc 100644 --- a/src/modules/extra_env.f90 +++ b/src/modules/extra_env.f90 @@ -13,3 +13,8 @@ subroutine psb_get_mpicomm(ictxt,comm) integer :: ictxt, comm call blacs_get(ictxt,10,comm) end subroutine psb_get_mpicomm +subroutine psb_get_rank(rank,ictxt,id) + integer :: rank,ictxt, id + integer :: blacs_pnum + rank = blacs_pnum(ictxt,id,0) +end subroutine psb_get_rank diff --git a/src/prec/psb_dasmatbld.f90 b/src/prec/psb_dasmatbld.f90 index c2fbe3165..ce79e459a 100644 --- a/src/prec/psb_dasmatbld.f90 +++ b/src/prec/psb_dasmatbld.f90 @@ -59,6 +59,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) use psb_tools_mod use psb_const_mod use psb_error_mod + use psb_penv_mod Implicit None ! .. Array Arguments .. @@ -173,7 +174,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) call blacs_get(ictxt,10,icomm ) - Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + Call psb_info(ictxt, me, nprow) If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr t1 = mpi_wtime() diff --git a/src/prec/psb_dbaseprc_aply.f90 b/src/prec/psb_dbaseprc_aply.f90 index 08da46fc0..25a1e65a5 100644 --- a/src/prec/psb_dbaseprc_aply.f90 +++ b/src/prec/psb_dbaseprc_aply.f90 @@ -46,6 +46,7 @@ subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info) use psb_psblas_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -60,32 +61,32 @@ subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info) integer :: n_row,n_col, int_err(5) real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) character ::diagl, diagu - integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg, err_act + integer :: ictxt,np,npcol,me,mycol,i, isz, nrg, err_act real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime logical,parameter :: debug=.false., debugprt=.false. external mpi_wtime character(len=20) :: name, ch_err interface psb_bjac_aply - subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type - use psb_prec_type - type(psb_desc_type), intent(in) :: desc_data - type(psb_dbaseprc_type), intent(in) :: prec - real(kind(0.d0)),intent(inout) :: x(:), y(:) - real(kind(0.d0)),intent(in) :: beta - character(len=1) :: trans - real(kind(0.d0)),target :: work(:) - integer, intent(out) :: info - end subroutine psb_dbjac_aply + subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) + use psb_descriptor_type + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_dbaseprc_type), intent(in) :: prec + real(kind(0.d0)),intent(inout) :: x(:), y(:) + real(kind(0.d0)),intent(in) :: beta + character(len=1) :: trans + real(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dbjac_aply end interface - + name='psb_dbaseprc_aply' info = 0 call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) diagl='U' diagu='U' @@ -94,10 +95,10 @@ subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info) case('N','n') case('T','t','C','c') case default - info=40 - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 end select select case(prec%iprcparm(p_type_)) @@ -132,9 +133,9 @@ subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info) call psb_bjac_aply(prec,x,beta,y,desc_data,trans,work,info) if(info.ne.0) then - info=4010 - ch_err='psb_bjac_aply' - goto 9999 + info=4010 + ch_err='psb_bjac_aply' + goto 9999 end if case(asm_,ras_,ash_,rash_) diff --git a/src/prec/psb_dbaseprc_bld.f90 b/src/prec/psb_dbaseprc_bld.f90 index b6ef7594d..d15da26c3 100644 --- a/src/prec/psb_dbaseprc_bld.f90 +++ b/src/prec/psb_dbaseprc_bld.f90 @@ -45,6 +45,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod Implicit None type(psb_dspmat_type), target :: a @@ -111,7 +112,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) ! Local scalars Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,& - & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act + & me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)),pointer :: gd(:), work(:) integer :: int_err(5) @@ -135,7 +136,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) n_col = desc_a%matrix_data(psb_n_col_) mglob = desc_a%matrix_data(psb_m_) if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + call psb_info(ictxt, me, np) if (present(upd)) then if (debug) write(0,*) 'UPD ', upd @@ -195,14 +196,14 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) & f_ilu_n_,is_legal_ml_fact) if (debug) write(0,*)me, ': Calling PSB_ILU_BLD' - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) select case(p%iprcparm(f_type_)) case(f_ilu_n_,f_ilu_e_) call psb_ilu_bld(a,desc_a,p,iupd,info) if(debug) write(0,*)me,': out of psb_ilu_bld' - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) if(info /= 0) then info=4010 ch_err='psb_ilu_bld' diff --git a/src/prec/psb_dbjac_aply.f90 b/src/prec/psb_dbjac_aply.f90 index 3e2f37bad..2d7ae364d 100644 --- a/src/prec/psb_dbjac_aply.f90 +++ b/src/prec/psb_dbjac_aply.f90 @@ -48,6 +48,7 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) use psb_psblas_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -62,7 +63,7 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) integer :: n_row,n_col real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:) character ::diagl, diagu - integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg, err_act, int_err(5) + integer :: ictxt,np,npcol,me,mycol,i, isz, nrg, err_act, int_err(5) real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime logical,parameter :: debug=.false., debugprt=.false. external mpi_wtime @@ -73,7 +74,7 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) diagl='U' diagu='U' @@ -100,7 +101,7 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - + endif else allocate(ww(n_col),aux(4*n_col),stat=info) @@ -251,7 +252,7 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info) end do end select - + if (beta == dzero) then y(1:n_row) = tx(1:n_row) else if (beta==done) then diff --git a/src/prec/psb_dbldaggrmat.f90 b/src/prec/psb_dbldaggrmat.f90 index a827c8491..3cf1971ce 100644 --- a/src/prec/psb_dbldaggrmat.f90 +++ b/src/prec/psb_dbldaggrmat.f90 @@ -53,7 +53,7 @@ subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info) integer, intent(out) :: info logical, parameter :: aggr_dump=.false. - integer ::ictxt,nprow,npcol,me,mycol, err_act + integer ::ictxt,np,npcol,me,mycol, err_act character(len=20) :: name, ch_err name='psb_dbldaggrmat' if(psb_get_errstatus().ne.0) return @@ -61,7 +61,7 @@ subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info) call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) select case (p%iprcparm(smth_kind_)) case (no_smth_) @@ -115,7 +115,7 @@ contains type(psb_dspmat_type) :: b, tmp integer, pointer :: nzbr(:), idisp(:) integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,& - & naggr, np, myprow, mypcol, nprows, npcols,nzt,irs,jl,nzl,nlr,& + & naggr, np, me, mypcol, nprows, npcols,nzt,irs,jl,nzl,nlr,& & icomm,naggrm1, mtype, i, j, k, err_act name='raw_aggregate' if(psb_get_errstatus().ne.0) return @@ -126,13 +126,12 @@ contains call psb_nullify_sp(b) ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprows,npcols,myprow,mypcol) - np = nprows*npcols + call psb_info(ictxt, me, np) nglob = desc_a%matrix_data(psb_m_) nrow = desc_a%matrix_data(psb_n_row_) ncol = desc_a%matrix_data(psb_n_col_) - naggr = p%nlaggr(myprow+1) + naggr = p%nlaggr(me+1) ntaggr = sum(p%nlaggr) allocate(nzbr(np), idisp(np),stat=info) @@ -141,7 +140,7 @@ contains goto 9999 end if - naggrm1=sum(p%nlaggr(1:myprow)) + naggrm1=sum(p%nlaggr(1:me)) if (p%iprcparm(coarse_mat_) == mat_repl_) then do i=1, nrow @@ -249,7 +248,7 @@ contains call psb_cdrep(ntaggr,ictxt,desc_p,info) nzbr(:) = 0 - nzbr(myprow+1) = irs + nzbr(me+1) = irs call psb_sum(ictxt,nzbr(1:np)) nzbg = sum(nzbr) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) @@ -258,11 +257,11 @@ contains goto 9999 end if - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm) do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo - ndx = nzbr(myprow+1) + ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,bg%aspk,nzbr,idisp,& & mpi_double_precision,icomm,info) @@ -392,7 +391,7 @@ contains type(psb_dspmat_type) :: b integer, pointer :: nzbr(:), idisp(:), ivall(:) integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,& - & naggr, np, myprow, mypcol, nprows, npcols,& + & naggr, np, me, mypcol, nprows, npcols,& & icomm, naggrm1,naggrp1,mtype,i,j,err_act,k,nzl type(psb_dspmat_type), pointer :: am1,am2 type(psb_dspmat_type) :: am3,am4 @@ -410,7 +409,7 @@ contains call psb_erractionsave(err_act) ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprows,npcols,myprow,mypcol) + call psb_info(ictxt, me, np) bg => ac call psb_nullify_sp(b) @@ -420,13 +419,11 @@ contains am2 => p%av(sm_pr_t_) am1 => p%av(sm_pr_) - - np = nprows*npcols nglob = desc_a%matrix_data(psb_m_) nrow = desc_a%matrix_data(psb_n_row_) ncol = desc_a%matrix_data(psb_n_col_) - naggr = p%nlaggr(myprow+1) + naggr = p%nlaggr(me+1) ntaggr = sum(p%nlaggr) allocate(nzbr(np), idisp(np),stat=info) @@ -436,8 +433,8 @@ contains end if - naggrm1 = sum(p%nlaggr(1:myprow)) - naggrp1 = sum(p%nlaggr(1:myprow+1)) + naggrm1 = sum(p%nlaggr(1:me)) + naggrp1 = sum(p%nlaggr(1:me+1)) ml_global_nmb = ( (p%iprcparm(smth_kind_) == smth_omg_).or.& & ( (p%iprcparm(smth_kind_) == smth_biz_).and.& @@ -899,7 +896,7 @@ contains ! ! nzbr(:) = 0 - nzbr(myprow+1) = b%infoa(psb_nnz_) + nzbr(me+1) = b%infoa(psb_nnz_) call psb_cdrep(ntaggr,ictxt,desc_p,info) @@ -909,11 +906,11 @@ contains if(info /= 0) goto 9999 - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm) do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo - ndx = nzbr(myprow+1) + ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,bg%aspk,nzbr,idisp,& & mpi_double_precision,icomm,info) @@ -968,7 +965,7 @@ contains ! ! nzbr(:) = 0 - nzbr(myprow+1) = b%infoa(psb_nnz_) + nzbr(me+1) = b%infoa(psb_nnz_) call psb_cdrep(ntaggr,ictxt,desc_p,info) @@ -981,11 +978,11 @@ contains goto 9999 end if - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm) do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo - ndx = nzbr(myprow+1) + ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,bg%aspk,nzbr,idisp,& & mpi_double_precision,icomm,info) diff --git a/src/prec/psb_ddiagsc_bld.f90 b/src/prec/psb_ddiagsc_bld.f90 index ff3d8c3c3..c77fb4645 100644 --- a/src/prec/psb_ddiagsc_bld.f90 +++ b/src/prec/psb_ddiagsc_bld.f90 @@ -45,6 +45,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod Implicit None type(psb_dspmat_type), target :: a @@ -56,7 +57,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) ! Local scalars Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,& - & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act + & me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)),pointer :: gd(:), work(:) integer :: int_err(5) @@ -80,7 +81,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) n_col = desc_a%matrix_data(psb_n_col_) mglob = desc_a%matrix_data(psb_m_) if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + call psb_info(ictxt, me, np) if (debug) write(0,*) 'Precond: Diagonal scaling' ! diagonal scaling @@ -146,9 +147,9 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) end if if (me.eq.iroot) then - write(iout+nprow,*) 'VDIAG CHECK ',mglob + write(iout+np,*) 'VDIAG CHECK ',mglob do i=1,mglob - write(iout+nprow,*) i,gd(i) + write(iout+np,*) i,gd(i) enddo endif deallocate(gd) diff --git a/src/prec/psb_dgenaggrmap.f90 b/src/prec/psb_dgenaggrmap.f90 index 10e8ea32a..b0bcf905e 100644 --- a/src/prec/psb_dgenaggrmap.f90 +++ b/src/prec/psb_dgenaggrmap.f90 @@ -52,7 +52,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) logical :: recovery logical, parameter :: debug=.false. - integer ::ictxt,nprow,npcol,me,mycol,err_act + integer ::ictxt,np,npcol,me,mycol,err_act integer :: nrow, ncol, n_ne integer, parameter :: one=1, two=2 character(len=20) :: name, ch_err @@ -67,7 +67,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) ! change in the future. ! ictxt=desc_a%matrix_data(psb_ctxt_) - call psb_info(ictxt,me,nprow) + call psb_info(ictxt,me,np) nrow = desc_a%matrix_data(psb_n_row_) ncol = desc_a%matrix_data(psb_n_col_) @@ -271,7 +271,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if - allocate(nlaggr(nprow),stat=info) + allocate(nlaggr(np),stat=info) if (info/=0) then info=4000 call psb_errpush(info,name) @@ -280,7 +280,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) nlaggr(:) = 0 nlaggr(me+1) = naggr - call psb_sum(ictxt,nlaggr(1:nprow)) + call psb_sum(ictxt,nlaggr(1:np)) call psb_erractionrestore(err_act) return diff --git a/src/prec/psb_dilu_bld.f90 b/src/prec/psb_dilu_bld.f90 index db622fd3b..2050e8d87 100644 --- a/src/prec/psb_dilu_bld.f90 +++ b/src/prec/psb_dilu_bld.f90 @@ -58,6 +58,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) use psb_tools_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod implicit none ! ! .. Scalar Arguments .. @@ -81,7 +82,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,& & nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, & & ind, iind, pi,nr,ns - integer ::ictxt,nprow,npcol,me,mycol + integer ::ictxt,np,npcol,me,mycol character(len=20) :: name, ch_err interface psb_ilu_fct @@ -133,7 +134,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) m = a%m if (m < 0) then @@ -153,7 +154,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) goto 9999 endif - ! call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + ! call psb_info(ictxt, me, np) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -163,7 +164,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) t1= mpi_wtime() if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info) if(info/=0) then @@ -174,7 +175,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) end if t2= mpi_wtime() if (debug) write(0,*)me,': out of psb_asmatbld' - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) if (associated(p%av)) then if (size(p%av) < bp_ilu_avsz) then @@ -195,7 +196,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) goto 9999 end if if (debug) write(0,*)me,': out spinfo',nztota - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) n_col = desc_a%matrix_data(psb_n_col_) nhalo = n_col-nrow_a @@ -231,7 +232,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) if (debug) then write(0,*) me,'Done psb_asmatbld' - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif @@ -264,7 +265,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) t3 = mpi_wtime() if (debugprt) then - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) open(40+me) call psb_csprt(40+me,atmp,head='% Local matrix') close(40+me) @@ -301,7 +302,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) if (debugprt) then open(40+me) - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,& & head='% Local matrix') if (p%iprcparm(p_type_)==asm_) then @@ -312,8 +313,8 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) endif t5= mpi_wtime() - if (debug) write(0,*) me,' Going for dilu_fct' - if (debug) call blacs_barrier(ictxt,'All') + if (debug) write(0,*) me,' Going for ilu_fct' + if (debug) call psb_barrier(ictxt) call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck) if(info/=0) then info=4010 diff --git a/src/prec/psb_dmlprc_aply.f90 b/src/prec/psb_dmlprc_aply.f90 index 246c282ab..f3f63b196 100644 --- a/src/prec/psb_dmlprc_aply.f90 +++ b/src/prec/psb_dmlprc_aply.f90 @@ -47,6 +47,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) use psb_penv_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -63,7 +64,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) real(kind(1.d0)), allocatable :: tx(:),ty(:),t2l(:),w2l(:),& & x2l(:),b2l(:),tz(:),tty(:) character ::diagl, diagu - integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5) + integer :: ictxt,np,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5) real(kind(1.d0)) :: omega real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime logical, parameter :: debug=.false., debugprt=.false. @@ -72,17 +73,17 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) character(len=20) :: name, ch_err interface psb_baseprc_aply - subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info) - use psb_descriptor_type - use psb_prec_type - type(psb_desc_type),intent(in) :: desc_data - type(psb_dbaseprc_type), intent(in) :: prec - real(kind(0.d0)),intent(inout) :: x(:), y(:) - real(kind(0.d0)),intent(in) :: beta - character(len=1) :: trans - real(kind(0.d0)),target :: work(:) - integer, intent(out) :: info - end subroutine psb_dbaseprc_aply + subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info) + use psb_descriptor_type + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_dbaseprc_type), intent(in) :: prec + real(kind(0.d0)),intent(inout) :: x(:), y(:) + real(kind(0.d0)),intent(in) :: beta + character(len=1) :: trans + real(kind(0.d0)),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dbaseprc_aply end interface name='psb_dmlprc_aply' @@ -91,7 +92,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) omega=baseprecv(2)%dprcparm(smooth_omega_) ismth=baseprecv(2)%iprcparm(smth_kind_) @@ -163,8 +164,8 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then call psb_sum(ictxt,t2l(1:nrg)) else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then - write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& - & baseprecv(2)%iprcparm(coarse_mat_) + write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& + & baseprecv(2)%iprcparm(coarse_mat_) endif w2l=t2l @@ -488,7 +489,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) enddo end if - + call psb_geaxpby(done,x,dzero,tx,desc_data,info) if(info /=0) goto 9999 @@ -498,7 +499,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) call psb_geaxpby(done,tty,beta,y,desc_data,info) - + deallocate(t2l,w2l,tx,ty,tty) diff --git a/src/prec/psb_dprc_aply.f90 b/src/prec/psb_dprc_aply.f90 index a292c1cd3..ff959fa98 100644 --- a/src/prec/psb_dprc_aply.f90 +++ b/src/prec/psb_dprc_aply.f90 @@ -42,6 +42,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) use psb_psblas_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -54,7 +55,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) ! Local variables character :: trans_ real(kind(1.d0)), pointer :: work_(:) - integer :: ictxt,nprow,npcol,me,mycol,err_act, int_err(5) + integer :: ictxt,np,npcol,me,mycol,err_act, int_err(5) logical,parameter :: debug=.false., debugprt=.false. external mpi_wtime character(len=20) :: name, ch_err @@ -92,7 +93,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) if (present(trans)) then trans_=trans @@ -191,6 +192,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) use psb_psblas_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -218,7 +220,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) ! Local variables character :: trans_ - integer :: ictxt,nprow,npcol,me,mycol,i, isz, err_act, int_err(5) + integer :: ictxt,np,npcol,me,mycol,i, isz, err_act, int_err(5) real(kind(1.d0)), pointer :: WW(:), w1(:) character(len=20) :: name, ch_err name='psb_dprec1' @@ -227,7 +229,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) if (present(trans)) then trans_=trans else diff --git a/src/prec/psb_dprecbld.f90 b/src/prec/psb_dprecbld.f90 index 687da0fc2..5beb3d96c 100644 --- a/src/prec/psb_dprecbld.f90 +++ b/src/prec/psb_dprecbld.f90 @@ -45,6 +45,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod Implicit None type(psb_dspmat_type), target :: a @@ -83,7 +84,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) ! Local scalars Integer :: err, nnzero, I,j,k,ictxt,& - & me,mycol,nprow,npcol,lw, mtype, nrg, nzg, err_act + & me,mycol,np,npcol,lw, mtype, nrg, nzg, err_act real(kind(1.d0)) :: temp, real_err(5) integer :: int_err(5) character :: iupd @@ -103,8 +104,8 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) int_err(1) = 0 ictxt = desc_a%matrix_data(psb_ctxt_) - if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + if (debug) write(0,*) 'Preconditioner psb_info' + call psb_info(ictxt, me, np) if (present(upd)) then if (debug) write(0,*) 'UPD ', upd @@ -119,10 +120,10 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) if (.not.associated(p%baseprecv)) then !! Error 1: should call precset - info=4010 - ch_err='unassociated bpv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='unassociated bpv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if ! ! Should add check to ensure all procs have the same... @@ -138,14 +139,14 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) call psb_errpush(info,name,a_err=ch_err) goto 9999 endif - + call psb_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd) else - info=4010 - ch_err='size bpv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='size bpv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 endif @@ -184,7 +185,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) call psb_mlprc_bld(p%baseprecv(i-1)%av(ac_),p%baseprecv(i-1)%desc_data,& & p%baseprecv(i),info) end do - + endif call psb_erractionrestore(err_act) diff --git a/src/prec/psb_dslu_bld.f90 b/src/prec/psb_dslu_bld.f90 index dc5a51f12..28c91c90f 100644 --- a/src/prec/psb_dslu_bld.f90 +++ b/src/prec/psb_dslu_bld.f90 @@ -40,6 +40,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info) use psb_prec_type use psb_tools_mod use psb_const_mod + use psb_penv_mod implicit none type(psb_dspmat_type), intent(inout) :: a @@ -51,7 +52,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info) type(psb_dspmat_type) :: blck, atmp character(len=5) :: fmt character :: upd='F' - integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act + integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,np,npcol,err_act logical, parameter :: debug=.false. character(len=20) :: name, ch_err @@ -77,8 +78,8 @@ subroutine psb_dslu_bld(a,desc_a,p,info) call psb_erractionsave(err_act) ictxt = desc_A%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + call psb_info(ictxt, me, np) fmt = 'COO' call psb_nullify_sp(blck) @@ -87,7 +88,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info) atmp%fida='COO' if (Debug) then write(0,*) me, 'SPLUBLD: Calling csdp' - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif call psb_csdp(a,atmp,info) @@ -100,7 +101,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info) nza = atmp%infoa(psb_nnz_) if (Debug) then write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info,outfmt=fmt) @@ -114,7 +115,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info) nzb = blck%infoa(psb_nnz_) if (Debug) then write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif if (nzb > 0 ) then if (size(atmp%aspk) 0 ) then if (size(atmp%aspk) ac call psb_nullify_sp(b) @@ -420,13 +419,11 @@ contains am2 => p%av(sm_pr_t_) am1 => p%av(sm_pr_) - - np = nprows*npcols nglob = desc_a%matrix_data(psb_m_) nrow = desc_a%matrix_data(psb_n_row_) ncol = desc_a%matrix_data(psb_n_col_) - naggr = p%nlaggr(myprow+1) + naggr = p%nlaggr(me+1) ntaggr = sum(p%nlaggr) allocate(nzbr(np), idisp(np),stat=info) @@ -436,8 +433,8 @@ contains end if - naggrm1 = sum(p%nlaggr(1:myprow)) - naggrp1 = sum(p%nlaggr(1:myprow+1)) + naggrm1 = sum(p%nlaggr(1:me)) + naggrp1 = sum(p%nlaggr(1:me+1)) ml_global_nmb = ( (p%iprcparm(smth_kind_) == smth_omg_).or.& & ( (p%iprcparm(smth_kind_) == smth_biz_).and.& @@ -899,7 +896,7 @@ contains ! ! nzbr(:) = 0 - nzbr(myprow+1) = b%infoa(psb_nnz_) + nzbr(me+1) = b%infoa(psb_nnz_) call psb_cdrep(ntaggr,ictxt,desc_p,info) @@ -909,11 +906,11 @@ contains if(info /= 0) goto 9999 - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm) do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo - ndx = nzbr(myprow+1) + ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,bg%aspk,nzbr,idisp,& & mpi_double_complex,icomm,info) @@ -968,7 +965,7 @@ contains ! ! nzbr(:) = 0 - nzbr(myprow+1) = b%infoa(psb_nnz_) + nzbr(me+1) = b%infoa(psb_nnz_) call psb_cdrep(ntaggr,ictxt,desc_p,info) @@ -981,11 +978,11 @@ contains goto 9999 end if - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm) do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo - ndx = nzbr(myprow+1) + ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,bg%aspk,nzbr,idisp,& & mpi_double_complex,icomm,info) diff --git a/src/prec/psb_zdiagsc_bld.f90 b/src/prec/psb_zdiagsc_bld.f90 index a7db771d6..5fc587a5d 100644 --- a/src/prec/psb_zdiagsc_bld.f90 +++ b/src/prec/psb_zdiagsc_bld.f90 @@ -45,6 +45,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod Implicit None type(psb_zspmat_type), target :: a @@ -56,7 +57,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) ! Local scalars Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,& - & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act + & me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act real(kind(1.d0)) :: temp, real_err(5) complex(kind(1.d0)),pointer :: gd(:), work(:) integer :: int_err(5) @@ -80,7 +81,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) n_col = desc_a%matrix_data(psb_n_col_) mglob = desc_a%matrix_data(psb_m_) if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + call psb_info(ictxt, me, np) if (debug) write(0,*) 'Precond: Diagonal scaling' ! diagonal scaling @@ -146,9 +147,9 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) end if if (me.eq.iroot) then - write(iout+nprow,*) 'VDIAG CHECK ',mglob + write(iout+np,*) 'VDIAG CHECK ',mglob do i=1,mglob - write(iout+nprow,*) i,gd(i) + write(iout+np,*) i,gd(i) enddo endif deallocate(gd) diff --git a/src/prec/psb_zgenaggrmap.f90 b/src/prec/psb_zgenaggrmap.f90 index 92e23db9e..490c06401 100644 --- a/src/prec/psb_zgenaggrmap.f90 +++ b/src/prec/psb_zgenaggrmap.f90 @@ -52,7 +52,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) logical :: recovery logical, parameter :: debug=.false. - integer ::ictxt,nprow,npcol,me,mycol,err_act + integer ::ictxt,np,npcol,me,mycol,err_act integer :: nrow, ncol, n_ne integer, parameter :: one=1, two=2 character(len=20) :: name, ch_err @@ -67,7 +67,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) ! change in the future. ! ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt,me,np) nrow = desc_a%matrix_data(psb_n_row_) ncol = desc_a%matrix_data(psb_n_col_) @@ -271,7 +271,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if - allocate(nlaggr(nprow),stat=info) + allocate(nlaggr(np),stat=info) if (info/=0) then info=4000 call psb_errpush(info,name) @@ -280,7 +280,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info) nlaggr(:) = 0 nlaggr(me+1) = naggr - call psb_sum(ictxt,nlaggr(1:nprow)) + call psb_sum(ictxt,nlaggr(1:np)) call psb_erractionrestore(err_act) return diff --git a/src/prec/psb_zilu_bld.f90 b/src/prec/psb_zilu_bld.f90 index c203064ad..8a4d54627 100644 --- a/src/prec/psb_zilu_bld.f90 +++ b/src/prec/psb_zilu_bld.f90 @@ -58,6 +58,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) use psb_tools_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod implicit none ! ! .. Scalar Arguments .. @@ -80,7 +81,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,& & nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, & & ind, iind, pi,nr,ns - integer ::ictxt,nprow,npcol,me,mycol + integer ::ictxt,np,npcol,me,mycol character(len=20) :: name, ch_err interface psb_ilu_fct @@ -132,7 +133,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) m = a%m if (m < 0) then @@ -152,7 +153,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) goto 9999 endif - ! call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + ! call psb_info(ictxt, me, np) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -162,7 +163,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) t1= mpi_wtime() if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info) if(info/=0) then @@ -173,7 +174,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) end if t2= mpi_wtime() if (debug) write(0,*)me,': out of psb_asmatbld' - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) if (associated(p%av)) then if (size(p%av) < bp_ilu_avsz) then @@ -194,7 +195,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) goto 9999 end if if (debug) write(0,*)me,': out spinfo',nztota - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) n_col = desc_a%matrix_data(psb_n_col_) nhalo = n_col-nrow_a @@ -230,7 +231,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) if (debug) then write(0,*) me,'Done psb_asmatbld' - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif @@ -263,7 +264,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) t3 = mpi_wtime() if (debugprt) then - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) open(40+me) call psb_csprt(40+me,atmp,head='% Local matrix') close(40+me) @@ -300,7 +301,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) if (debugprt) then open(40+me) - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,& & head='% Local matrix') if (p%iprcparm(p_type_)==asm_) then @@ -312,7 +313,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) t5= mpi_wtime() if (debug) write(0,*) me,' Going for ilu_fct' - if (debug) call blacs_barrier(ictxt,'All') + if (debug) call psb_barrier(ictxt) call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck) if(info/=0) then info=4010 diff --git a/src/prec/psb_zmlprc_aply.f90 b/src/prec/psb_zmlprc_aply.f90 index 13b07b5a7..8175af004 100644 --- a/src/prec/psb_zmlprc_aply.f90 +++ b/src/prec/psb_zmlprc_aply.f90 @@ -47,6 +47,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) use psb_penv_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -63,7 +64,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) complex(kind(1.d0)), allocatable :: tx(:),ty(:),t2l(:),w2l(:),& & x2l(:),b2l(:),tz(:),tty(:) character ::diagl, diagu - integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5) + integer :: ictxt,np,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5) real(kind(1.d0)) :: omega real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime logical, parameter :: debug=.false., debugprt=.false. @@ -91,7 +92,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) omega=baseprecv(2)%dprcparm(smooth_omega_) ismth=baseprecv(2)%iprcparm(smth_kind_) diff --git a/src/prec/psb_zprc_aply.f90 b/src/prec/psb_zprc_aply.f90 index 0be4b8d95..98ba726da 100644 --- a/src/prec/psb_zprc_aply.f90 +++ b/src/prec/psb_zprc_aply.f90 @@ -42,6 +42,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) use psb_psblas_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -54,7 +55,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) ! Local variables character :: trans_ complex(kind(1.d0)), pointer :: work_(:) - integer :: ictxt,nprow,npcol,me,mycol,err_act, int_err(5) + integer :: ictxt,np,npcol,me,mycol,err_act, int_err(5) logical,parameter :: debug=.false., debugprt=.false. external mpi_wtime character(len=20) :: name, ch_err @@ -92,7 +93,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) if (present(trans)) then trans_=trans @@ -191,6 +192,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) use psb_psblas_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type),intent(in) :: desc_data @@ -218,7 +220,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) ! Local variables character :: trans_ - integer :: ictxt,nprow,npcol,me,mycol,i, isz, err_act, int_err(5) + integer :: ictxt,np,npcol,me,mycol,i, isz, err_act, int_err(5) complex(kind(1.d0)), pointer :: WW(:), w1(:) character(len=20) :: name, ch_err name='psb_zprec1' @@ -227,7 +229,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) ictxt=desc_data%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + call psb_info(ictxt, me, np) if (present(trans)) then trans_=trans else diff --git a/src/prec/psb_zprecbld.f90 b/src/prec/psb_zprecbld.f90 index 85769020b..087c68131 100644 --- a/src/prec/psb_zprecbld.f90 +++ b/src/prec/psb_zprecbld.f90 @@ -45,6 +45,7 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod Implicit None type(psb_zspmat_type), target :: a @@ -83,7 +84,7 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) ! Local scalars Integer :: err, nnzero, I,j,k,ictxt,& - & me,mycol,nprow,npcol,lw, mtype, nrg, nzg, err_act + & me,mycol,np,npcol,lw, mtype, nrg, nzg, err_act real(kind(1.d0)) :: temp, real_err(5) integer :: int_err(5) character :: iupd @@ -103,8 +104,8 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) int_err(1) = 0 ictxt = desc_a%matrix_data(psb_ctxt_) - if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + if (debug) write(0,*) 'Preconditioner psb_info' + call psb_info(ictxt, me, np) if (present(upd)) then if (debug) write(0,*) 'UPD ', upd diff --git a/src/prec/psb_zslu_bld.f90 b/src/prec/psb_zslu_bld.f90 index ea151e126..a849ac4d2 100644 --- a/src/prec/psb_zslu_bld.f90 +++ b/src/prec/psb_zslu_bld.f90 @@ -40,9 +40,10 @@ subroutine psb_zslu_bld(a,desc_a,p,info) use psb_prec_type use psb_tools_mod use psb_const_mod + use psb_penv_mod implicit none - type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(inout) :: a type(psb_desc_type), intent(in) :: desc_a type(psb_zbaseprc_type), intent(inout) :: p integer, intent(out) :: info @@ -51,7 +52,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info) type(psb_zspmat_type) :: blck, atmp character(len=5) :: fmt character :: upd='F' - integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act + integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,np,npcol,err_act logical, parameter :: debug=.false. character(len=20) :: name, ch_err @@ -77,8 +78,8 @@ subroutine psb_zslu_bld(a,desc_a,p,info) call psb_erractionsave(err_act) ictxt = desc_A%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mycol) + call psb_info(ictxt, me, np) fmt = 'COO' call psb_nullify_sp(blck) @@ -86,8 +87,8 @@ subroutine psb_zslu_bld(a,desc_a,p,info) atmp%fida='COO' if (Debug) then - write(0,*) me, 'ZSLUBLD: Calling csdp' - call blacs_barrier(ictxt,'All') + write(0,*) me, 'SPLUBLD: Calling csdp' + call psb_barrier(ictxt) endif call psb_csdp(a,atmp,info) @@ -100,7 +101,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info) nza = atmp%infoa(psb_nnz_) if (Debug) then write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& & blck,desc_a,upd,p%desc_data,info,outfmt=fmt) @@ -114,7 +115,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info) nzb = blck%infoa(psb_nnz_) if (Debug) then write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif if (nzb > 0 ) then if (size(atmp%aspk) 0 ) then if (size(atmp%aspk) work endif - if (debug) write(0,*) myrow,name,' Allocated work ', info + if (debug) write(0,*) me,name,' Allocated work ', info ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) if(info /= 0) then @@ -549,7 +539,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if (debug) write(0,*) myrow,name,' Checkmat ', info + if (debug) write(0,*) me,name,' Checkmat ', info if (itrans == 'N') then ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then @@ -628,10 +618,10 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) yp(nrow+1:ncol)=dzero - if (debug) write(0,*) myrow,name,' checkvect ', info + if (debug) write(0,*) me,name,' checkvect ', info ! local Matrix-vector product call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans) - if (debug) write(0,*) myrow,name,' csmm ', info + if (debug) write(0,*) me,name,' csmm ', info if(info /= 0) then info = 4010 ch_err='dcsmm' @@ -642,7 +632,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if(idoswap /= 0)& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info) - if (debug) write(0,*) myrow,name,' swaptran ', info + if (debug) write(0,*) me,name,' swaptran ', info if(info /= 0) then info = 4010 ch_err='PSI_dSwapTran' @@ -653,7 +643,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& end if if (aliw) deallocate(iwork,stat=info) - if (debug) write(0,*) myrow,name,' deallocat ',aliw, info + if (debug) write(0,*) me,name,' deallocat ',aliw, info if(info /= 0) then info = 4010 ch_err='Deallocate iwork' @@ -664,8 +654,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& nullify(iwork) call psb_erractionrestore(err_act) - if (debug) call blacs_barrier(ictxt,'A') - if (debug) write(0,*) myrow,name,' Returning ' + if (debug) call psb_barrier(ictxt) + if (debug) write(0,*) me,name,' Returning ' return 9999 continue diff --git a/src/psblas/psb_dspsm.f90 b/src/psblas/psb_dspsm.f90 index a9b6b7788..f1371e9ca 100644 --- a/src/psblas/psb_dspsm.f90 +++ b/src/psblas/psb_dspsm.f90 @@ -82,6 +82,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& use psb_check_mod use psb_error_mod use psb_string_mod + use psb_penv_mod implicit none real(kind(1.D0)), intent(in) :: alpha, beta @@ -97,7 +98,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: k, jx, jy ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & ix, iy, ik, ijx, ijy, i, lld,& & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy @@ -116,17 +117,11 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ! just this case right now @@ -390,6 +385,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& use psb_check_mod use psb_error_mod use psb_string_mod + use psb_penv_mod + implicit none real(kind(1.D0)), intent(in) :: alpha, beta real(kind(1.d0)), intent(in), target :: x(:) @@ -403,7 +400,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: choice ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & ix, iy, ik, jx, jy, i, lld,& & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy @@ -422,17 +419,11 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ! just this case right now diff --git a/src/psblas/psb_zamax.f90 b/src/psblas/psb_zamax.f90 index f3f523099..20179e20d 100644 --- a/src/psblas/psb_zamax.f90 +++ b/src/psblas/psb_zamax.f90 @@ -58,7 +58,7 @@ function psb_zamax (x,desc_a, info, jx) real(kind(1.d0)) :: psb_zamax ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, ijx, m, i, k, imax, izamax real(kind(1.d0)) :: amax character(len=20) :: name, ch_err @@ -75,17 +75,11 @@ function psb_zamax (x,desc_a, info, jx) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -192,7 +186,7 @@ function psb_zamaxv (x,desc_a, info) real(kind(1.d0)) :: psb_zamaxv ! locals - integer :: int_err(5), err, ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), err, ictxt, np, me, mycol,& & err_act, n, iix, jjx, jx, temp(2), ix, ijx, m, imax, izamax real(kind(1.d0)) :: amax complex(kind(1.d0)) :: cmax @@ -210,17 +204,11 @@ function psb_zamaxv (x,desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -326,7 +314,7 @@ subroutine psb_zamaxvs (res,x,desc_a, info) real(kind(1.D0)), intent(out) :: res ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, izamax real(kind(1.d0)) :: amax character(len=20) :: name, ch_err @@ -344,17 +332,11 @@ subroutine psb_zamaxvs (res,x,desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -459,7 +441,7 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx) real(kind(1.d0)), intent(out) :: res(:) ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, me, mycol,& & err_act, n, iix, jjx, ix, temp(2), ijx, m, imax, i, k, izamax real(kind(1.d0)) :: amax character(len=20) :: name, ch_err @@ -477,17 +459,11 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 diff --git a/src/psblas/psb_zasum.f90 b/src/psblas/psb_zasum.f90 index 7aa5f0238..1e6c44630 100644 --- a/src/psblas/psb_zasum.f90 +++ b/src/psblas/psb_zasum.f90 @@ -59,7 +59,7 @@ function psb_zasum (x,desc_a, info, jx) real(kind(1.d0)) :: psb_zasum ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, ijx, m, i real(kind(1.d0)) :: asum, dzasum character(len=20) :: name, ch_err @@ -77,17 +77,11 @@ function psb_zasum (x,desc_a, info, jx) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -213,7 +207,7 @@ function psb_zasumv (x,desc_a, info) real(kind(1.d0)) :: psb_zasumv ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i real(kind(1.d0)) :: asum, dzasum character(len=20) :: name, ch_err @@ -231,17 +225,11 @@ function psb_zasumv (x,desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 @@ -363,7 +351,7 @@ subroutine psb_zasumvs (res,x,desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i real(kind(1.d0)) :: asum, dzasum character(len=20) :: name, ch_err @@ -381,17 +369,11 @@ subroutine psb_zasumvs (res,x,desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = 1 diff --git a/src/psblas/psb_zaxpby.f90 b/src/psblas/psb_zaxpby.f90 index c3960277e..115f6ef02 100644 --- a/src/psblas/psb_zaxpby.f90 +++ b/src/psblas/psb_zaxpby.f90 @@ -54,6 +54,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) use psb_check_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none integer, intent(in), optional :: n, jx, jy @@ -64,7 +65,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) complex(kind(1.D0)), intent(inout) :: y(:,:) ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, iix, jjx, temp(2), ix, iy, ijx, ijy, m, iiy, in, jjy character(len=20) :: name, ch_err @@ -75,48 +76,42 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -ione) then + call psb_info(ictxt, me, np) + if (np == -ione) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= ione) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = ione if (present(jx)) then - ijx = jx + ijx = jx else - ijx = ione + ijx = ione endif iy = ione if (present(jy)) then - ijy = jy + ijy = jy else - ijy = ione + ijy = ione endif if (present(n)) then - if(((ijx+n).le.size(x,2)).and.& - & ((ijy+n).le.size(y,2))) then - in = n - else - in = min(size(x,2),size(y,2)) - end if + if(((ijx+n).le.size(x,2)).and.& + & ((ijy+n).le.size(y,2))) then + in = n + else + in = min(size(x,2),size(y,2)) + end if else - in = min(size(x,2),size(y,2)) + in = min(size(x,2),size(y,2)) endif if(ijx.ne.ijy) then - info=3050 - call psb_errpush(info,name) - goto 9999 + info=3050 + call psb_errpush(info,name) + goto 9999 end if m = desc_a%matrix_data(psb_m_) @@ -125,26 +120,26 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((iix.ne.ione).or.(iiy.ne.ione)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if - + if ((in.ne.0)) then - if(desc_a%matrix_data(psb_n_row_).gt.0) then - call zaxpby(desc_a%matrix_data(psb_n_col_),in,& - & alpha,x(iix,jjx),size(x,1),beta,& - & y(iiy,jjy),size(y,1),info) - end if + if(desc_a%matrix_data(psb_n_row_).gt.0) then + call zaxpby(desc_a%matrix_data(psb_n_col_),in,& + & alpha,x(iix,jjx),size(x,1),beta,& + & y(iiy,jjy),size(y,1),info) + end if end if - + call psb_erractionrestore(err_act) return @@ -152,8 +147,8 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zaxpby @@ -211,6 +206,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) use psb_const_mod use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none integer, intent(out) :: info @@ -220,7 +216,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) complex(kind(1.D0)), intent(inout) :: y(:) ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, iy, ijx, m, iiy, in, jjy character(len=20) :: name, ch_err logical, parameter :: debug=.false. @@ -232,51 +228,45 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -ione) then + call psb_info(ictxt, me, np) + if (np == -ione) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= ione) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = ione iy = ione m = desc_a%matrix_data(psb_m_) - + ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect 1' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call psb_chkvect(m,ione,size(y),iy,ione,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect 2' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((iix.ne.ione).or.(iiy.ne.ione)) then - info=3040 - call psb_errpush(info,name) + info=3040 + call psb_errpush(info,name) end if - + if(desc_a%matrix_data(psb_n_row_).gt.0) then - call zaxpby(desc_a%matrix_data(psb_n_col_),ione,& - & alpha,x,size(x),beta,& - & y,size(y),info) + call zaxpby(desc_a%matrix_data(psb_n_col_),ione,& + & alpha,x,size(x),beta,& + & y,size(y),info) end if - + call psb_erractionrestore(err_act) return @@ -284,8 +274,8 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zaxpbyv diff --git a/src/psblas/psb_zdot.f90 b/src/psblas/psb_zdot.f90 index 6bd077038..4c77d53d4 100644 --- a/src/psblas/psb_zdot.f90 +++ b/src/psblas/psb_zdot.f90 @@ -61,7 +61,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy) complex(kind(1.D0)) :: psb_zdot ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k complex(kind(1.D0)) :: dot_local complex(kind(1.d0)) :: zdotc @@ -74,37 +74,31 @@ function psb_zdot(x, y,desc_a, info, jx, jy) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -ione) then + call psb_info(ictxt, me, np) + if (np == -ione) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= ione) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = ione if (present(jx)) then - ijx = jx + ijx = jx else - ijx = ione + ijx = ione endif iy = ione if (present(jy)) then - ijy = jy + ijy = jy else - ijy = ione + ijy = ione endif if(ijx.ne.ijy) then - info=3050 - call psb_errpush(info,name) - goto 9999 + info=3050 + call psb_errpush(info,name) + goto 9999 end if m = desc_a%matrix_data(psb_m_) @@ -113,41 +107,41 @@ function psb_zdot(x, y,desc_a, info, jx, jy) call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((iix.ne.ione).or.(iiy.ne.ione)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if if(m.ne.0) then - if(desc_a%matrix_data(psb_n_row_).gt.0) then - dot_local = zdotc(desc_a%matrix_data(psb_n_row_),& - & x(iix,jjx),ione,y(iiy,jjy),ione) - ! adjust dot_local because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - dot_local = dot_local -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & conjg(x(iix+desc_a%ovrlap_elem(i)-1,jjx))*& - & y(iiy+desc_a%ovrlap_elem(i)-1,jjy) - i = i+2 - end do - else - dot_local=0.d0 - end if + if(desc_a%matrix_data(psb_n_row_).gt.0) then + dot_local = zdotc(desc_a%matrix_data(psb_n_row_),& + & x(iix,jjx),ione,y(iiy,jjy),ione) + ! adjust dot_local because overlapped elements are computed more than once + i=1 + do while (desc_a%ovrlap_elem(i).ne.-ione) + dot_local = dot_local -& + & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& + & conjg(x(iix+desc_a%ovrlap_elem(i)-1,jjx))*& + & y(iiy+desc_a%ovrlap_elem(i)-1,jjy) + i = i+2 + end do + else + dot_local=0.d0 + end if else - dot_local=0.d0 + dot_local=0.d0 end if ! compute global sum call psb_sum(ictxt, dot_local) - + psb_zdot = dot_local call psb_erractionrestore(err_act) @@ -157,8 +151,8 @@ function psb_zdot(x, y,desc_a, info, jx, jy) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end function psb_zdot @@ -220,7 +214,7 @@ function psb_zdotv(x, y,desc_a, info) complex(kind(1.D0)) :: psb_zdotv ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, jx, iy, jy, iiy, jjy, i, m, j, k complex(kind(1.D0)) :: dot_local complex(kind(1.d0)) :: zdotc @@ -233,17 +227,11 @@ function psb_zdotv(x, y,desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -ione) then + call psb_info(ictxt, me, np) + if (np == -ione) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= ione) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = ione @@ -256,41 +244,41 @@ function psb_zdotv(x, y,desc_a, info) call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((iix.ne.ione).or.(iiy.ne.ione)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if if(m.ne.0) then - if(desc_a%matrix_data(psb_n_row_).gt.0) then - dot_local = zdotc(desc_a%matrix_data(psb_n_row_),& - & x,ione,y,ione) - ! adjust dot_local because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - dot_local = dot_local -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & conjg(x(desc_a%ovrlap_elem(i)))*& - & y(desc_a%ovrlap_elem(i)) - i = i+2 - end do - else - dot_local=0.d0 - end if + if(desc_a%matrix_data(psb_n_row_).gt.0) then + dot_local = zdotc(desc_a%matrix_data(psb_n_row_),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + i=1 + do while (desc_a%ovrlap_elem(i).ne.-ione) + dot_local = dot_local -& + & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& + & conjg(x(desc_a%ovrlap_elem(i)))*& + & y(desc_a%ovrlap_elem(i)) + i = i+2 + end do + else + dot_local=0.d0 + end if else - dot_local=0.d0 + dot_local=0.d0 end if ! compute global sum call psb_sum(ictxt, dot_local) - + psb_zdotv = dot_local call psb_erractionrestore(err_act) @@ -300,8 +288,8 @@ function psb_zdotv(x, y,desc_a, info) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end function psb_zdotv @@ -363,7 +351,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k complex(kind(1.D0)) :: dot_local complex(kind(1.d0)) :: zdotc @@ -376,17 +364,11 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -ione) then + call psb_info(ictxt, me, np) + if (np == -ione) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= ione) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = ione @@ -397,41 +379,41 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((iix.ne.ione).or.(iiy.ne.ione)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if if(m.ne.0) then - if(desc_a%matrix_data(psb_n_row_).gt.0) then - dot_local = zdotc(desc_a%matrix_data(psb_n_row_),& - & x,ione,y,ione) - ! adjust dot_local because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - dot_local = dot_local -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & conjg(x(desc_a%ovrlap_elem(i)))*& - & y(desc_a%ovrlap_elem(i)) - i = i+2 - end do - else - dot_local=0.d0 - end if + if(desc_a%matrix_data(psb_n_row_).gt.0) then + dot_local = zdotc(desc_a%matrix_data(psb_n_row_),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + i=1 + do while (desc_a%ovrlap_elem(i).ne.-ione) + dot_local = dot_local -& + & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& + & conjg(x(desc_a%ovrlap_elem(i)))*& + & y(desc_a%ovrlap_elem(i)) + i = i+2 + end do + else + dot_local=0.d0 + end if else - dot_local=0.d0 + dot_local=0.d0 end if ! compute global sum call psb_sum(ictxt, dot_local) - + res = dot_local call psb_erractionrestore(err_act) @@ -441,8 +423,8 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zdotvs @@ -509,7 +491,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k complex(kind(1.d0)),allocatable :: dot_local(:) complex(kind(1.d0)) :: zdotc @@ -522,17 +504,11 @@ subroutine psb_zmdots(res, x, y, desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -ione) then + call psb_info(ictxt, me, np) + if (np == -ione) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= ione) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ix = ione @@ -543,53 +519,53 @@ subroutine psb_zmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if ((ix.ne.ione).or.(iy.ne.ione)) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if k = min(size(x,2),size(y,2)) allocate(dot_local(k)) if(m.ne.0) then - if(desc_a%matrix_data(psb_n_row_).gt.0) then - do j=1,k - dot_local(j) = zdotc(desc_a%matrix_data(psb_n_row_),& - & x(1,j),ione,y(1,j),ione) - ! adjust dot_local because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - dot_local(j) = dot_local(j) -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & conjg(x(desc_a%ovrlap_elem(i)-1,j))*& - & y(desc_a%ovrlap_elem(i)-1,j) - i = i+2 - end do + if(desc_a%matrix_data(psb_n_row_).gt.0) then + do j=1,k + dot_local(j) = zdotc(desc_a%matrix_data(psb_n_row_),& + & x(1,j),ione,y(1,j),ione) + ! adjust dot_local because overlapped elements are computed more than once + i=1 + do while (desc_a%ovrlap_elem(i).ne.-ione) + dot_local(j) = dot_local(j) -& + & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& + & conjg(x(desc_a%ovrlap_elem(i)-1,j))*& + & y(desc_a%ovrlap_elem(i)-1,j) + i = i+2 end do - else - dot_local(:)=0.d0 - end if + end do + else + dot_local(:)=0.d0 + end if else - dot_local(:)=0.d0 + dot_local(:)=0.d0 end if ! compute global sum call psb_sum(ictxt, dot_local(1:k)) - + res(1:k) = dot_local(1:k) @@ -600,8 +576,8 @@ subroutine psb_zmdots(res, x, y, desc_a, info) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_zmdots diff --git a/src/psblas/psb_znrm2.f90 b/src/psblas/psb_znrm2.f90 index 41b30fe4f..471bd7589 100644 --- a/src/psblas/psb_znrm2.f90 +++ b/src/psblas/psb_znrm2.f90 @@ -47,6 +47,7 @@ function psb_znrm2(x, desc_a, info, jx) use psb_descriptor_type use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(in) :: x(:,:) @@ -56,7 +57,7 @@ function psb_znrm2(x, desc_a, info, jx) real(kind(1.D0)) :: psb_znrm2 ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ndim, ix, ijx, i, m, id real(kind(1.d0)) :: nrm2, dznrm2, dd @@ -70,67 +71,61 @@ function psb_znrm2(x, desc_a, info, jx) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%matrix_data(psb_m_) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if if(m.ne.0) then - if (desc_a%matrix_data(psb_n_row_) .gt. 0) then - ndim = desc_a%matrix_data(psb_n_row_) - nrm2 = dznrm2( ndim, x(iix,jjx), ione ) - i=1 - do while (desc_a%ovrlap_elem(i) .ne. -1) - id = desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - dd = dble(id-1)/dble(id) - nrm2 = nrm2 * sqrt(& - & done - dd * (abs(x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_), jjx)) & - & / nrm2 & - & ) ** 2 & - & ) - i = i+2 - end do - else - nrm2 = dzero - end if + if (desc_a%matrix_data(psb_n_row_) .gt. 0) then + ndim = desc_a%matrix_data(psb_n_row_) + nrm2 = dznrm2( ndim, x(iix,jjx), ione ) + i=1 + do while (desc_a%ovrlap_elem(i) .ne. -1) + id = desc_a%ovrlap_elem(i+psb_n_dom_ovr_) + dd = dble(id-1)/dble(id) + nrm2 = nrm2 * sqrt(& + & done - dd * (abs(x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_), jjx)) & + & / nrm2 & + & ) ** 2 & + & ) + i = i+2 + end do + else + nrm2 = dzero + end if else - nrm2 = dzero + nrm2 = dzero end if - + call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) - + psb_znrm2 = nrm2 - + call psb_erractionrestore(err_act) return @@ -138,8 +133,8 @@ function psb_znrm2(x, desc_a, info, jx) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end function psb_znrm2 @@ -190,6 +185,7 @@ function psb_znrm2v(x, desc_a, info) use psb_descriptor_type use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(in) :: x(:) @@ -198,7 +194,7 @@ function psb_znrm2v(x, desc_a, info) real(kind(1.D0)) :: psb_znrm2v ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id real(kind(1.d0)) :: nrm2, dznrm2, dd @@ -212,19 +208,13 @@ function psb_znrm2v(x, desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - + ix = 1 jx=1 @@ -233,43 +223,43 @@ function psb_znrm2v(x, desc_a, info) call psb_chkvect(m,1,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if if(m.ne.0) then - if (desc_a%matrix_data(psb_n_row_) .gt. 0) then - ndim = desc_a%matrix_data(psb_n_row_) - nrm2 = dznrm2( ndim, x, ione ) - i=1 - do while (desc_a%ovrlap_elem(i) .ne. -1) - id = desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - dd = dble(id-1)/dble(id) - nrm2 = nrm2 * sqrt(& - & done - dd * (abs(x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))) & - & / nrm2 & - & ) ** 2 & - & ) - i = i+2 - end do - else - nrm2 = dzero - end if + if (desc_a%matrix_data(psb_n_row_) .gt. 0) then + ndim = desc_a%matrix_data(psb_n_row_) + nrm2 = dznrm2( ndim, x, ione ) + i=1 + do while (desc_a%ovrlap_elem(i) .ne. -1) + id = desc_a%ovrlap_elem(i+psb_n_dom_ovr_) + dd = dble(id-1)/dble(id) + nrm2 = nrm2 * sqrt(& + & done - dd * (abs(x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))) & + & / nrm2 & + & ) ** 2 & + & ) + i = i+2 + end do + else + nrm2 = dzero + end if else - nrm2 = dzero + nrm2 = dzero end if - + call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) - + psb_znrm2v = nrm2 - + call psb_erractionrestore(err_act) return @@ -277,8 +267,8 @@ function psb_znrm2v(x, desc_a, info) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end function psb_znrm2v @@ -331,6 +321,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) use psb_descriptor_type use psb_check_mod use psb_error_mod + use psb_penv_mod implicit none complex(kind(1.d0)), intent(in) :: x(:) @@ -339,7 +330,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id real(kind(1.d0)) :: nrm2, dznrm2, dd @@ -353,60 +344,54 @@ subroutine psb_znrm2vs(res, x, desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif - + ix = 1 jx = 1 m = desc_a%matrix_data(psb_m_) call psb_chkvect(m,1,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then - info=4010 - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) end if if (iix.ne.1) then - info=3040 - call psb_errpush(info,name) - goto 9999 + info=3040 + call psb_errpush(info,name) + goto 9999 end if if(m.ne.0) then - if (desc_a%matrix_data(psb_n_row_) .gt. 0) then - ndim = desc_a%matrix_data(psb_n_row_) - nrm2 = dznrm2( ndim, x, ione ) - i=1 - do while (desc_a%ovrlap_elem(i) .ne. -1) - id = desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - dd = dble(id-1)/dble(id) - nrm2 = nrm2 * sqrt(& - & done-dd*(abs(x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)))/nrm2)**2 & - & ) - i = i+2 - end do - else - nrm2 = dzero - end if + if (desc_a%matrix_data(psb_n_row_) .gt. 0) then + ndim = desc_a%matrix_data(psb_n_row_) + nrm2 = dznrm2( ndim, x, ione ) + i=1 + do while (desc_a%ovrlap_elem(i) .ne. -1) + id = desc_a%ovrlap_elem(i+psb_n_dom_ovr_) + dd = dble(id-1)/dble(id) + nrm2 = nrm2 * sqrt(& + & done-dd*(abs(x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)))/nrm2)**2 & + & ) + i = i+2 + end do + else + nrm2 = dzero + end if else - nrm2 = dzero + nrm2 = dzero end if - + call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2) - + res = nrm2 - + call psb_erractionrestore(err_act) return @@ -414,8 +399,8 @@ subroutine psb_znrm2vs(res, x, desc_a, info) call psb_erractionrestore(err_act) if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return end subroutine psb_znrm2vs diff --git a/src/psblas/psb_znrmi.f90 b/src/psblas/psb_znrmi.f90 index 74635843d..9b507f7bf 100644 --- a/src/psblas/psb_znrmi.f90 +++ b/src/psblas/psb_znrmi.f90 @@ -54,8 +54,8 @@ function psb_znrmi(a,desc_a,info) real(kind(1.d0)) :: psb_znrmi ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& - & err_act, n, iia, jja, ia, ja, temp(2), mdim, ndim, m + integer :: int_err(5), ictxt, np, npcol, me, mycol,& + & err_act, n, iia, jja, ia, ja, mdim, ndim, m real(kind(1.d0)) :: nrmi, zcsnmi character(len=20) :: name, ch_err @@ -66,17 +66,11 @@ function psb_znrmi(a,desc_a,info) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call psb_info(ictxt, myrow, nprow) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ia = 1 diff --git a/src/psblas/psb_zspmm.f90 b/src/psblas/psb_zspmm.f90 index 0b710dce5..3d97955dc 100644 --- a/src/psblas/psb_zspmm.f90 +++ b/src/psblas/psb_zspmm.f90 @@ -87,6 +87,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& use psi_mod use psb_check_mod use psb_error_mod + use psb_string_mod + use psb_penv_mod implicit none complex(kind(1.D0)), intent(in) :: alpha, beta @@ -100,7 +102,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: k, jx, jy,doswap ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,& & idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, iiy, jjy,& & i, ib, ib1 @@ -111,23 +113,17 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_zspmm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ia = 1 @@ -161,7 +157,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& endif if (present(trans)) then - if ( (toupper(trans).eq.'N').or.(toupper(trans).eq.'T').or. (toupper(trans).eq.'C')) then + if ( (toupper(trans) == 'N').or.(toupper(trans) == 'T').or. (toupper(trans) == 'C')) then itrans = toupper(trans) else info = 70 @@ -195,7 +191,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) @@ -209,7 +205,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) @@ -217,9 +213,9 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& end if - if (itrans.eq.'N') then + if (itrans == 'N') then ! Matrix is not transposed - if((ja.ne.ix).or.(ia.ne.iy)) then + if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented info = 3030 call psb_errpush(info,name) @@ -229,14 +225,14 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if((iix.ne.1).or.(iiy.ne.1)) then + if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented info = 3040 call psb_errpush(info,name) @@ -246,7 +242,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ib1=min(nb,ik) xp => x(iix:lldx,jjx:jjx+ib1-1) - if(idoswap.gt.0)& + if(idoswap > 0)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,zzero,xp,desc_a,iwork,info) @@ -255,26 +251,26 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ib=ib1 ib1 = max(0,min(nb,(ik)-(i-1+ib))) xp => x(iix:lldx,jjx+i+ib-1:jjx+i+ib+ib1-2) - if((ib1.gt.0).and.(idoswap.gt.0))& + if((ib1 > 0).and.(idoswap > 0))& & call psi_swapdata(psb_swap_send_,ib1,& & zzero,xp,desc_a,iwork,info) - if(info.ne.0) exit blk + if(info /= 0) exit blk ! local Matrix-vector product call psb_csmm(alpha,a,x(iix:lldx,jjx:jjx+ib-1),& & beta,y(iiy:lldy,jjy:jjy+ib-1),info,trans=itrans) - if(info.ne.0) exit blk + if(info /= 0) exit blk - if((ib1.gt.0).and.(idoswap.gt.0))& + if((ib1 > 0).and.(idoswap > 0))& & call psi_swapdata(psb_swap_send_,ib1,& & zzero,xp,desc_a,iwork,info) - if(info.ne.0) exit blk + if(info /= 0) exit blk end do blk - if(info.ne.0) then + if(info /= 0) then info = 4011 call psb_errpush(info,name) goto 9999 @@ -282,14 +278,14 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& else ! Matrix is transposed - if((ja.ne.iy).or.(ia.ne.ix)) then + if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented info = 3030 call psb_errpush(info,name) goto 9999 end if - if(desc_a%ovrlap_elem(1).ne.-1) then + if(desc_a%ovrlap_elem(1) /= -1) then info = 3070 call psb_errpush(info,name) goto 9999 @@ -298,14 +294,14 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if((iix.ne.1).or.(iiy.ne.1)) then + if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented info = 3040 call psb_errpush(info,name) @@ -319,7 +315,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& call psb_csmm(alpha,a,x(iix:lldx,jjx:jjx+ik-1),& & beta,y(iiy:lldy,jjy:jjy+ik-1),info,trans=itrans) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='csmm' call psb_errpush(info,name,a_err=ch_err) @@ -331,7 +327,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,zone,yp,desc_a,iwork,info) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) @@ -349,7 +345,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -422,6 +418,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& use psi_mod use psb_check_mod use psb_error_mod + use psb_string_mod + use psb_penv_mod implicit none complex(kind(1.D0)), intent(in) :: alpha, beta @@ -435,7 +433,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: doswap ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,& & idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, jx, jy, iiy, jjy,& & i, ib, ib1 @@ -446,23 +444,17 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_zspmv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ia = 1 @@ -481,7 +473,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& endif if (present(trans)) then - if ( (toupper(trans).eq.'N').or.(toupper(trans).eq.'T') .or.(toupper(trans).eq.'C')) then + if ( (toupper(trans) == 'N').or.(toupper(trans) == 'T') .or.(toupper(trans) == 'C')) then itrans = toupper(trans) else info = 70 @@ -517,13 +509,13 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& aliw=.true. if (aliw) then - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if else iwork => work endif @@ -531,7 +523,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) @@ -539,9 +531,9 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& end if - if (itrans.eq.'N') then + if (itrans == 'N') then ! Matrix is not transposed - if((ja.ne.ix).or.(ia.ne.iy)) then + if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented info = 3030 call psb_errpush(info,name) @@ -551,14 +543,14 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(n,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if((iix.ne.1).or.(iiy.ne.1)) then + if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented info = 3040 call psb_errpush(info,name) @@ -575,7 +567,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! local Matrix-vector product call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info) - if(info.ne.0) then + if(info /= 0) then info = 4011 call psb_errpush(info,name) goto 9999 @@ -583,14 +575,14 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& else ! Matrix is transposed - if((ja.ne.iy).or.(ia.ne.ix)) then + if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented info = 3030 call psb_errpush(info,name) goto 9999 end if - if(desc_a%ovrlap_elem(1).ne.-1) then + if(desc_a%ovrlap_elem(1) /= -1) then info = 3070 call psb_errpush(info,name) goto 9999 @@ -599,14 +591,14 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(n,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if((iix.ne.1).or.(iiy.ne.1)) then + if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented info = 3040 call psb_errpush(info,name) @@ -621,7 +613,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! local Matrix-vector product call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='dcsmm' call psb_errpush(info,name,a_err=ch_err) @@ -631,7 +623,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if(idoswap /= 0)& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & zone,yp,desc_a,iwork,info) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) @@ -644,12 +636,13 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& nullify(iwork) call psb_erractionrestore(err_act) + return 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/psblas/psb_zspsm.f90 b/src/psblas/psb_zspsm.f90 index 285ebd055..925d93a14 100644 --- a/src/psblas/psb_zspsm.f90 +++ b/src/psblas/psb_zspsm.f90 @@ -81,6 +81,8 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& use psi_mod use psb_check_mod use psb_error_mod + use psb_string_mod + use psb_penv_mod implicit none complex(kind(1.D0)), intent(in) :: alpha, beta @@ -96,7 +98,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: k, jx, jy ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & ix, iy, ik, ijx, ijy, i, lld,& & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy @@ -115,17 +117,11 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ! just this case right now @@ -393,6 +389,8 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& use psb_check_mod use psb_error_mod use psb_string_mod + use psb_penv_mod + implicit none complex(kind(1.D0)), intent(in) :: alpha, beta complex(kind(1.d0)), intent(in), target :: x(:) @@ -406,7 +404,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: choice ! locals - integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& + integer :: int_err(5), ictxt, np, npcol, me, mycol,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & ix, iy, ik, jx, jy, i, lld,& & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy @@ -425,17 +423,11 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif ! just this case right now diff --git a/src/tools/psb_cdall.f90 b/src/tools/psb_cdall.f90 index 54ef6577a..232241009 100644 --- a/src/tools/psb_cdall.f90 +++ b/src/tools/psb_cdall.f90 @@ -47,6 +47,7 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) use psb_realloc_mod use psb_serial_mod use psb_const_mod + use psb_penv_mod implicit None include 'parts.fh' !....Parameters... @@ -55,7 +56,7 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) integer, intent(out) :: info !locals - Integer :: counter,i,j,nprow,npcol,myrow,mycol,& + Integer :: counter,i,j,np,npcol,me,mycol,& & loc_row,err,loc_col,nprocs,& & l_ov_ix,l_ov_el,idx, err_act, itmpov, k Integer :: INT_ERR(5),TEMP(1),EXCH(2) @@ -64,76 +65,67 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) logical, parameter :: debug=.false. character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 err=0 name = 'psb_cdall' call psb_erractionsave(err_act) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (debug) write(*,*) 'psb_cdall: ',nprow,npcol,myrow,mycol + call psb_info(ictxt, me, np) + if (debug) write(*,*) 'psb_cdall: ',np,me ! ....verify blacs grid correctness.. - if (npcol /= 1) then - info = 2030 - err=info - int_err(1) = npcol - call psb_errpush(err,name,int_err) - goto 9999 - endif - !... check m and n parameters.... - if (m.lt.1) then - info = 10 - err=info - int_err(1) = 1 - int_err(2) = m - call psb_errpush(err,name,int_err) - goto 9999 - else if (n.lt.1) then - info = 10 - err=info - int_err(1) = 2 - int_err(2) = n - call psb_errpush(err,name,int_err) - goto 9999 + if (m < 1) then + info = 10 + err=info + int_err(1) = 1 + int_err(2) = m + call psb_errpush(err,name,int_err) + goto 9999 + else if (n < 1) then + info = 10 + err=info + int_err(1) = 2 + int_err(2) = n + call psb_errpush(err,name,int_err) + goto 9999 endif if (debug) write(*,*) 'psb_cdall: doing global checks' !global check on m and n parameters - if (myrow.eq.psb_root_) then - exch(1)=m - exch(2)=n - call igebs2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo) + if (me == psb_root_) then + exch(1)=m + exch(2)=n + call psb_bcast(ictxt,exch(1:2),root=psb_root_) else - call igebr2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,& - & 0) - if (exch(1) /= m) then - err=550 - int_err(1)=1 - call psb_errpush(err,name,int_err) - goto 9999 - else if (exch(2) /= n) then - err=550 - int_err(1)=2 - call psb_errpush(err,name,int_err) - goto 9999 - endif + call psb_bcast(ictxt,exch(1:2),root=psb_root_) + if (exch(1) /= m) then + err=550 + int_err(1)=1 + call psb_errpush(err,name,int_err) + goto 9999 + else if (exch(2) /= n) then + err=550 + int_err(1)=2 + call psb_errpush(err,name,int_err) + goto 9999 + endif endif call psb_nullify_desc(desc_a) !count local rows number ! allocate work vector - allocate(prc_v(nprow),desc_a%glob_to_loc(m),& + allocate(prc_v(np),desc_a%glob_to_loc(m),& &desc_a%matrix_data(psb_mdata_size_),temp_ovrlap(m),stat=info) if (info /= no_err) then - info=2025 - err=info - int_err(1)=m - call psb_errpush(err,name,int_err) - goto 9999 + info=2025 + err=info + int_err(1)=m + call psb_errpush(err,name,int_err) + goto 9999 endif @@ -142,70 +134,70 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) itmpov = 0 temp_ovrlap(:) = -1 do i=1,m - if (info.eq.0) then - call parts(i,m,nprow,prc_v,nprocs) - if (nprocs.gt.nprow) then - info=570 - int_err(1)=3 - int_err(2)=nprow - int_err(3)=nprocs - int_err(4)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else if (nprocs.le.0) then - info=575 - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else - do j=1,nprocs - if ((prc_v(j).gt.nprow-1).or.(prc_v(j).lt.0)) then - info=580 - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) - goto 9999 - end if - end do - endif - desc_a%glob_to_loc(i) = -(nprow+prc_v(1)+1) - j=1 -!!$ do while ((j.le.nprocs).and.(prc_v(j).ne.myrow)) - do - if (j > nprocs) exit - if (prc_v(j) == myrow) exit - j=j+1 - enddo - if (j.le.nprocs) then - if (prc_v(j).eq.myrow) then - ! this point belongs to myrow - counter=counter+1 - desc_a%glob_to_loc(i) = counter - if (nprocs.gt.1) then - if ((itmpov+2+nprocs).gt.m) then - info=2025 - int_err(1)=m - err=info - call psb_errpush(err,name,int_err) - goto 9999 - else - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i - itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) - itmpov = itmpov + nprocs - endif - endif - end if + if (info == 0) then + call parts(i,m,np,prc_v,nprocs) + if (nprocs > np) then + info=570 + int_err(1)=3 + int_err(2)=np + int_err(3)=nprocs + int_err(4)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else if (nprocs <= 0) then + info=575 + int_err(1)=3 + int_err(2)=nprocs + int_err(3)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else + do j=1,nprocs + if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then + info=580 + int_err(1)=3 + int_err(2)=prc_v(j) + int_err(3)=i + err=info + call psb_errpush(err,name,int_err) + goto 9999 + end if + end do + endif + desc_a%glob_to_loc(i) = -(np+prc_v(1)+1) + j=1 +!!$ do while ((j <= nprocs).and.(prc_v(j) /= me)) + do + if (j > nprocs) exit + if (prc_v(j) == me) exit + j=j+1 + enddo + if (j <= nprocs) then + if (prc_v(j) == me) then + ! this point belongs to me + counter=counter+1 + desc_a%glob_to_loc(i) = counter + if (nprocs > 1) then + if ((itmpov+2+nprocs) > m) then + info=2025 + int_err(1)=m + err=info + call psb_errpush(err,name,int_err) + goto 9999 + else + itmpov = itmpov + 1 + temp_ovrlap(itmpov) = i + itmpov = itmpov + 1 + temp_ovrlap(itmpov) = nprocs + temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) + itmpov = itmpov + nprocs + endif + endif end if - endif + end if + endif enddo loc_row=counter @@ -219,13 +211,13 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) l_ov_el=0 i = 1 do while (temp_ovrlap(i) /= -1) - idx = temp_ovrlap(i) - i=i+1 - nprocs = temp_ovrlap(i) - i = i + 1 - l_ov_ix = l_ov_ix+3*(nprocs-1) - l_ov_el = l_ov_el + 2 - i = i + nprocs + idx = temp_ovrlap(i) + i=i+1 + nprocs = temp_ovrlap(i) + i = i + 1 + l_ov_ix = l_ov_ix+3*(nprocs-1) + l_ov_el = l_ov_el + 2 + i = i + nprocs enddo l_ov_ix = l_ov_ix+3 @@ -234,32 +226,32 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) if (debug) write(*,*) 'PSB_CDALL: Ov len',l_ov_ix,l_ov_el allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info) if (info /= no_err) then - info=4010 - char_err='psb_realloc' - err=info - call psb_errpush(err,name,a_err=char_err) - goto 9999 + info=4010 + char_err='psb_realloc' + err=info + call psb_errpush(err,name,a_err=char_err) + goto 9999 end if l_ov_ix=0 l_ov_el=0 i = 1 do while (temp_ovrlap(i) /= -1) - idx = temp_ovrlap(i) - i = i+1 - nprocs = temp_ovrlap(i) - ov_el(l_ov_el+1) = idx - ov_el(l_ov_el+2) = nprocs - l_ov_el = l_ov_el+2 - do j=1, nprocs - if (temp_ovrlap(i+j) /= myrow) then - ov_idx(l_ov_ix+1) = temp_ovrlap(i+j) - ov_idx(l_ov_ix+2) = 1 - ov_idx(l_ov_ix+3) = idx - l_ov_ix = l_ov_ix+3 - endif - enddo - i = i + nprocs +1 + idx = temp_ovrlap(i) + i = i+1 + nprocs = temp_ovrlap(i) + ov_el(l_ov_el+1) = idx + ov_el(l_ov_el+2) = nprocs + l_ov_el = l_ov_el+2 + do j=1, nprocs + if (temp_ovrlap(i+j) /= me) then + ov_idx(l_ov_ix+1) = temp_ovrlap(i+j) + ov_idx(l_ov_ix+2) = 1 + ov_idx(l_ov_ix+3) = idx + l_ov_ix = l_ov_ix+3 + endif + enddo + i = i + nprocs +1 enddo l_ov_el = l_ov_el + 1 ov_el(l_ov_el) = -1 @@ -270,10 +262,10 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) desc_a%ovrlap_elem => ov_el deallocate(prc_v,temp_ovrlap,stat=info) if (info /= no_err) then - info=4000 - err=info - call psb_errpush(err,name) - Goto 9999 + info=4000 + err=info + call psb_errpush(err,name) + Goto 9999 endif ! estimate local cols number loc_col=int((psb_colrow_+1.d0)*loc_row)+1 @@ -288,10 +280,10 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) desc_a%lprm(1) = 0 desc_a%loc_to_glob(:) = -1 do i=1,m - k = desc_a%glob_to_loc(i) - if (k.gt.0) then - desc_a%loc_to_glob(k) = i - endif + k = desc_a%glob_to_loc(i) + if (k > 0) then + desc_a%loc_to_glob(k) = i + endif enddo nullify(desc_a%bnd_elem,desc_a%halo_index) @@ -302,10 +294,10 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) call psb_realloc(1,desc_a%halo_index, info) if (info /= no_err) then - info=2025 - char_err='psb_realloc' - call psb_errpush(err,name,a_err=char_err) - Goto 9999 + info=2025 + char_err='psb_realloc' + call psb_errpush(err,name,a_err=char_err) + Goto 9999 end if desc_a%halo_index(:) = -1 @@ -315,16 +307,16 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info) desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_a%matrix_data(psb_ctxt_) = ictxt - call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_)) + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_cdalv.f90 b/src/tools/psb_cdalv.f90 index 5b94addb5..4d93a7a9f 100644 --- a/src/tools/psb_cdalv.f90 +++ b/src/tools/psb_cdalv.f90 @@ -46,6 +46,7 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit None !....Parameters... Integer, intent(in) :: m,ictxt, v(:) @@ -54,7 +55,7 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) type(psb_desc_type), intent(out) :: desc_a !locals - Integer :: counter,i,j,nprow,npcol,myrow,mycol,& + Integer :: counter,i,j,np,npcol,me,mycol,& & loc_row,err,loc_col,nprocs,n,itmpov, k,& & l_ov_ix,l_ov_el,idx, flag_, err_act Integer :: INT_ERR(5),TEMP(1),EXCH(2) @@ -63,20 +64,13 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 err=0 name = 'psb_cdalv' - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (debug) write(*,*) 'psb_cdall: ',nprow,npcol,myrow,mycol - ! ....verify blacs grid correctness.. - if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif + call psb_info(ictxt, me, np) + if (debug) write(*,*) 'psb_cdall: ',np,me n = m !... check m and n parameters.... @@ -101,13 +95,12 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) if (debug) write(*,*) 'psb_cdall: doing global checks' !global check on m and n parameters - if (myrow.eq.psb_root_) then + if (me == psb_root_) then exch(1)=m exch(2)=n - call igebs2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo) + call psb_bcast(ictxt,exch(1:2),root=psb_root_) else - call igebr2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,& - & 0) + call psb_bcast(ictxt,exch(1:2),root=psb_root_) if (exch(1) /= m) then info=550 int_err(1)=1 @@ -156,7 +149,7 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) temp_ovrlap(:) = -1 do i=1,m - if (((v(i)-flag_) > nprow-1).or.((v(i)-flag_) < 0)) then + if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then info=580 int_err(1)=3 int_err(2)=v(i) - flag_ @@ -164,12 +157,12 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) exit end if - if ((v(i)-flag_) == myrow) then + if ((v(i)-flag_) == me) then ! this point belongs to me counter=counter+1 desc_a%glob_to_loc(i) = counter else - desc_a%glob_to_loc(i) = -(nprow+(v(i)-flag_)+1) + desc_a%glob_to_loc(i) = -(np+(v(i)-flag_)+1) end if enddo @@ -219,7 +212,7 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) ov_el(l_ov_el+2) = nprocs l_ov_el = l_ov_el+2 do j=1, nprocs - if (temp_ovrlap(i+j) /= myrow) then + if (temp_ovrlap(i+j) /= me) then ov_idx(l_ov_ix+1) = temp_ovrlap(i+j) ov_idx(l_ov_ix+2) = 1 ov_idx(l_ov_ix+3) = idx @@ -283,14 +276,14 @@ subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag) desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_a%matrix_data(psb_ctxt_) = ictxt - call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_)) + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_cdasb.f90 b/src/tools/psb_cdasb.f90 index f34916495..46834a198 100644 --- a/src/tools/psb_cdasb.f90 +++ b/src/tools/psb_cdasb.f90 @@ -53,7 +53,7 @@ subroutine psb_cdasb(desc_a,info) !....Locals.... integer :: int_err(5), itemp(2) integer,pointer :: ovrlap_index(:),halo_index(:) - integer :: i,err,nprow,npcol,me,mypcol,& + integer :: i,err,np,me,& & lovrlap,lhalo,nhalo,novrlap,max_size,max_halo,n_col,ldesc_halo,& & ldesc_ovrlap, dectype, err_act integer :: ictxt,n_row @@ -72,16 +72,11 @@ subroutine psb_cdasb(desc_a,info) n_col = desc_a%matrix_data(psb_n_col_) ! check on blacs grid - call psb_info(ictxt, me, nprow) - if (nprow == -1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (.not.psb_is_ok_dec(dectype)) then diff --git a/src/tools/psb_cdcpy.f90 b/src/tools/psb_cdcpy.f90 index 40fb768da..242177f8e 100644 --- a/src/tools/psb_cdcpy.f90 +++ b/src/tools/psb_cdcpy.f90 @@ -44,6 +44,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) use psb_realloc_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -53,31 +54,26 @@ subroutine psb_cdcpy(desc_in, desc_out, info) integer, intent(out) :: info !locals - integer :: nprow,npcol,me,mypcol,& + integer :: np,me,& & ictxt, isz, dectype, err_act, err integer :: int_err(5),temp(1) real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false.,debugprt=.false. character(len=20) :: name, char_err if (debug) write(0,*) me,'Entered CDCPY' - if (psb_get_errstatus().ne.0) return + if (psb_get_errstatus() /= 0) return info = 0 call psb_erractionsave(err_act) name = 'psb_cdcpy' ictxt=desc_in%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) if (debug) write(0,*) me,'Entered CDCPY' - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif call psb_nullify_desc(desc_out) @@ -87,7 +83,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%matrix_data,info) if(debug) write(0,*) 'cdcpy: m_data',isz,':',desc_in%matrix_data(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -103,7 +99,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%halo_index,info) if(debugprt) write(0,*) 'cdcpy: h_idx',isz,':',desc_in%halo_index(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -119,7 +115,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%bnd_elem,info) if(debugprt) write(0,*) 'cdcpy: bnd_elem',isz,':',desc_in%bnd_elem(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -135,7 +131,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%ovrlap_elem,info) if(debugprt) write(0,*) 'cdcpy: ovrlap_elem',isz,':',desc_in%ovrlap_elem(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psrealloc' call psb_errpush(info,name,a_err=char_err) @@ -151,7 +147,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%ovrlap_index,info) if(debugprt) write(0,*) 'cdcpy: ovrlap_index',isz,':',desc_in%ovrlap_index(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psrealloc' call psb_errpush(info,name,a_err=char_err) @@ -167,7 +163,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%loc_to_glob,info) if(debugprt) write(0,*) 'cdcpy: loc_to_glob',isz,':',desc_in%loc_to_glob(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psrealloc' call psb_errpush(info,name,a_err=char_err) @@ -183,7 +179,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%glob_to_loc,info) if(debugprt) write(0,*) 'cdcpy: glob_to_loc',isz,':',desc_in%glob_to_loc(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psrealloc' call psb_errpush(info,name,a_err=char_err) @@ -199,7 +195,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%lprm,info) if(debugprt) write(0,*) 'cdcpy: lprm',isz,':',desc_in%lprm(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -215,7 +211,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) ! allocate(desc_out%matrix_data(isz),stat=info) call psb_realloc(isz,desc_out%idx_space,info) if(debugprt) write(0,*) 'cdcpy: idx_space',isz,':',desc_in%idx_space(:) - if (info.ne.0) then + if (info /= 0) then info=4010 char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -231,7 +227,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_cddec.f90 b/src/tools/psb_cddec.f90 index fedf1e3e2..d08b4c303 100644 --- a/src/tools/psb_cddec.f90 +++ b/src/tools/psb_cddec.f90 @@ -115,7 +115,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) Type(psb_desc_type), intent(out) :: desc_a !locals - Integer :: counter,i,j,nprow,npcol,me,mypcol,& + Integer :: counter,i,j,np,npcol,me,mypcol,& & loc_row,err,loc_col,nprocs,n,itmpov, k,& & l_ov_ix,l_ov_el,idx, flag_, err_act,m, ip Integer :: INT_ERR(5),TEMP(1),EXCH(2) @@ -125,20 +125,13 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 err=0 name = 'psb_cddec' - call psb_info(ictxt, me, nprow) - if (debug) write(*,*) 'psb_cdalll: ',nprow,npcol,me,mypcol - ! ....verify blacs grid correctness.. - if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif + call psb_info(ictxt, me, np) + if (debug) write(*,*) 'psb_cdalll: ',np,me n = nloc !... check nloc and n parameters.... @@ -153,21 +146,21 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) endif if (info /= 0) then - call psb_errpush(info,name,i_err=int_err) - goto 9999 + call psb_errpush(info,name,i_err=int_err) + goto 9999 end if if (debug) write(*,*) 'psb_cdall: doing global checks' !global check on m and n parameters - allocate(nlv(0:nprow-1)) + allocate(nlv(0:np-1)) nlv(:) = 0 nlv(me) = nloc - - call psb_sum(ictxt,nlv(1:nprow)) + + call psb_sum(ictxt,nlv(1:np)) m = sum(nlv) - + call psb_nullify_desc(desc_a) @@ -186,9 +179,9 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) endif - + j = 1 - do ip=0, nprow-1 + do ip=0, np-1 if (ip==me) then do i=1, nlv(ip) desc_a%glob_to_loc(j) = i @@ -197,11 +190,11 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) enddo else do i=1, nlv(ip) - desc_a%glob_to_loc(j) = -(nprow+ip+1) + desc_a%glob_to_loc(j) = -(np+ip+1) j = j + 1 enddo endif - enddo + enddo @@ -218,17 +211,17 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) desc_a%matrix_data(psb_n_col_) = nloc desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ desc_a%matrix_data(psb_ctxt_) = ictxt - call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_)) + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return - + end subroutine psb_cddec diff --git a/src/tools/psb_cdfree.f90 b/src/tools/psb_cdfree.f90 index d089babb3..3f95e1e42 100644 --- a/src/tools/psb_cdfree.f90 +++ b/src/tools/psb_cdfree.f90 @@ -41,6 +41,7 @@ subroutine psb_cdfree(desc_a,info) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... type(psb_desc_type), intent(inout) :: desc_a @@ -49,117 +50,112 @@ subroutine psb_cdfree(desc_a,info) integer :: int_err(5) integer :: temp(1) real(kind(1.d0)) :: real_err(5) - integer :: ictxt,nprow,npcol,me,mypcol, err_act + integer :: ictxt,np,npcol,me,mypcol, err_act character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_cdfree' if (.not.associated(desc_a%matrix_data)) then - info=295 - call psb_errpush(info,name) - return + info=295 + call psb_errpush(info,name) + return end if ictxt=desc_a%matrix_data(psb_ctxt_) deallocate(desc_a%matrix_data) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif !...deallocate desc_a.... if(.not.associated(desc_a%loc_to_glob)) then - info=295 - call psb_errpush(info,name) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if - !deallocate loc_to_glob field - deallocate(desc_a%loc_to_glob,stat=info) - if (info /= 0) then - info=2051 - call psb_errpush(info,name) - goto 9999 - end if + !deallocate loc_to_glob field + deallocate(desc_a%loc_to_glob,stat=info) + if (info /= 0) then + info=2051 + call psb_errpush(info,name) + goto 9999 + end if if (.not.associated(desc_a%glob_to_loc)) then - info=295 - call psb_errpush(info,name) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if - !deallocate glob_to_loc field - deallocate(desc_a%glob_to_loc,stat=info) - if (info /= 0) then - info=2052 - call psb_errpush(info,name) - goto 9999 - end if + !deallocate glob_to_loc field + deallocate(desc_a%glob_to_loc,stat=info) + if (info /= 0) then + info=2052 + call psb_errpush(info,name) + goto 9999 + end if if (.not.associated(desc_a%halo_index)) then - info=295 - call psb_errpush(info,name) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if - !deallocate halo_index field - deallocate(desc_a%halo_index,stat=info) - if (info /= 0) then - info=2053 - call psb_errpush(info,name) - goto 9999 - end if + !deallocate halo_index field + deallocate(desc_a%halo_index,stat=info) + if (info /= 0) then + info=2053 + call psb_errpush(info,name) + goto 9999 + end if if (.not.associated(desc_a%bnd_elem)) then - info=296 - call psb_errpush(info,name) - goto 9999 + info=296 + call psb_errpush(info,name) + goto 9999 end if - !deallocate halo_index field + !deallocate halo_index field deallocate(desc_a%bnd_elem,stat=info) if (info /= 0) then - info=2054 - call psb_errpush(info,name) - goto 9999 + info=2054 + call psb_errpush(info,name) + goto 9999 end if if (.not.associated(desc_a%ovrlap_index)) then - info=295 - call psb_errpush(info,name) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if !deallocate ovrlap_index field deallocate(desc_a%ovrlap_index,stat=info) if (info /= 0) then - info=2055 - call psb_errpush(info,name) - goto 9999 + info=2055 + call psb_errpush(info,name) + goto 9999 end if !deallocate ovrlap_elem field - deallocate(desc_a%ovrlap_elem,stat=info) + deallocate(desc_a%ovrlap_elem,stat=info) if (info /= 0) then info=2056 call psb_errpush(info,name) goto 9999 end if - !deallocate ovrlap_index field - deallocate(desc_a%lprm,stat=info) + !deallocate ovrlap_index field + deallocate(desc_a%lprm,stat=info) if (info /= 0) then info=2057 call psb_errpush(info,name) @@ -174,10 +170,10 @@ subroutine psb_cdfree(desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/src/tools/psb_cdins.f90 b/src/tools/psb_cdins.f90 index 00a777a2e..8df24f2af 100644 --- a/src/tools/psb_cdins.f90 +++ b/src/tools/psb_cdins.f90 @@ -45,6 +45,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....PARAMETERS... @@ -58,7 +59,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) & first_loc_row,j, ierror,locix,locjx,& & dectype,mglob, nnza, nglob,err integer,pointer :: tia1(:),tia2(:), temp(:) - integer :: nprow,npcol, me ,mypcol, iflag, isize, irlc + integer :: np,npcol, me ,mypcol, iflag, isize, irlc integer :: m,n, pnt_halo,nrow,ncol, nh, ip,jp, err_act logical, parameter :: debug=.false. integer, parameter :: relocsz=200 @@ -75,13 +76,8 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) nrow = desc_a%matrix_data(psb_n_row_) ncol = desc_a%matrix_data(psb_n_col_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (npcol.ne.1) then - info = 2030 - call psb_errpush(info,name) - goto 9999 - endif + call psb_info(ictxt, me, np) + if (.not.psb_is_bld_dec(dectype)) then info = 3110 call psb_errpush(info,name) @@ -98,20 +94,20 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) call psb_errpush(info,name) goto 9999 end if - + if (size(ja) < nz) then info = 1111 call psb_errpush(info,name) goto 9999 end if - + if (.not.associated(desc_a%halo_index)) then allocate(desc_a%halo_index(relocsz)) desc_a%halo_index(:) = -1 endif pnt_halo=1 - do while (desc_a%halo_index(pnt_halo) .ne. -1 ) + do while (desc_a%halo_index(pnt_halo) /= -1 ) pnt_halo = pnt_halo + 1 end do isize = size(desc_a%halo_index) @@ -120,15 +116,15 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) ip = ia(i) jp = ja(i) if ((ip < 1 ).or.(ip>mglob).or.(jp<1).or.(jp>mglob)) then -! write(0,*) 'wrong input ',i,ip,jp + ! write(0,*) 'wrong input ',i,ip,jp info = 1133 call psb_errpush(info,name) goto 9999 endif if ((1<=desc_a%glob_to_loc(ip)).and.(desc_a%glob_to_loc(ip))<=nrow) then k = desc_a%glob_to_loc(jp) - if (k.lt.-nprow) then - k = k + nprow + if (k.lt.-np) then + k = k + np k = - k - 1 ncol = ncol + 1 desc_a%glob_to_loc(jp) = ncol @@ -140,10 +136,10 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) if (debug) write(0,*) 'done realloc ',nh end if if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name) - goto 9999 + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name) + goto 9999 end if isize = nh endif @@ -153,10 +149,10 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) nh = isize + max(nz,relocsz) call psb_realloc(nh,desc_a%halo_index,info,pad=-1) if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name) - goto 9999 + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name) + goto 9999 end if isize = nh endif @@ -170,17 +166,17 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info) endif enddo desc_a%matrix_data(psb_n_col_) = ncol - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - + if (err_act.eq.act_ret) then - return + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/src/tools/psb_cdren.f90 b/src/tools/psb_cdren.f90 index 9b1785411..4c79a4054 100644 --- a/src/tools/psb_cdren.f90 +++ b/src/tools/psb_cdren.f90 @@ -44,6 +44,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) use psb_const_mod use psb_error_mod use psb_penv_mod + use psb_string_mod implicit none interface isaperm @@ -59,7 +60,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) character, intent(in) :: trans integer, intent(out) :: info !....locals.... - integer :: i,j,err,nprow,npcol,myrow,mycol, n_col, kh, nh + integer :: i,j,err,np,npcol,me,mycol, n_col, kh, nh integer :: dectype integer :: ictxt,n_row, int_err(5), err_act real(kind(1.d0)) :: time(10), mpi_wtime, real_err(6) @@ -67,7 +68,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) logical, parameter :: debug=.false. character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dcren' @@ -80,16 +81,11 @@ subroutine psb_cdren(trans,iperm,desc_a,info) n_col = desc_a%matrix_data(psb_n_col_) ! check on blacs grid - call psb_info(ictxt, myrow, nprow) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif if (.not.psb_is_asb_dec(dectype)) then @@ -117,14 +113,14 @@ subroutine psb_cdren(trans,iperm,desc_a,info) if (debug) write(0,*) 'spasb: here we go with ',iperm(1) deallocate(desc_a%lprm) allocate(desc_a%lprm(n_col)) - if (trans.eq.'n') then + if (toupper(trans) == 'N') then do i=1, n_row desc_a%lprm(iperm(i)) = i enddo do i=n_row+1,n_col desc_a%lprm(i) = i enddo - else if (trans.eq.'t') then + else if (toupper(trans) == 'T') then do i=1, n_row desc_a%lprm(i) = iperm(i) enddo @@ -190,18 +186,18 @@ subroutine psb_cdren(trans,iperm,desc_a,info) enddo if (debug) write(0,*) 'spasb: done renumbering' if (debug) then - write(60+myrow,*) 'n_row ',n_row,' n_col',n_col, ' trans: ',trans + write(60+me,*) 'n_row ',n_row,' n_col',n_col, ' trans: ',trans do i=1,n_col - write(60+myrow,*)i, ' lprm ', desc_a%lprm(i), ' iperm',iperm(i) + write(60+me,*)i, ' lprm ', desc_a%lprm(i), ' iperm',iperm(i) enddo i=1 kh = desc_a%halo_index(i) do while (kh /= -1) - write(60+myrow,*) i, kh + write(60+me,*) i, kh i = i+1 kh = desc_a%halo_index(i) enddo - close(60+myrow) + close(60+me) end if !!$ iperm(1) = 0 @@ -225,7 +221,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_cdrep.f90 b/src/tools/psb_cdrep.f90 index bfd7ef616..aba3fb2bc 100644 --- a/src/tools/psb_cdrep.f90 +++ b/src/tools/psb_cdrep.f90 @@ -107,6 +107,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit None !....Parameters... Integer, intent(in) :: m,ictxt @@ -114,7 +115,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) Type(psb_desc_type), intent(out) :: desc_a !locals - Integer :: counter,i,j,nprow,npcol,myrow,mycol,& + Integer :: counter,i,j,np,npcol,me,mycol,& & loc_row,err,loc_col,nprocs,n,itmpov, k,& & l_ov_ix,l_ov_el,idx, flag_, err_act Integer :: INT_ERR(5),TEMP(1),EXCH(2) @@ -123,20 +124,13 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 err=0 name = 'psb_cdrep' - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (debug) write(*,*) 'psb_cdrep: ',nprow,npcol,myrow,mycol - ! ....verify blacs grid correctness.. - if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif + call psb_info(ictxt, me, np) + if (debug) write(*,*) 'psb_cdrep: ',np,me n = m !... check m and n parameters.... @@ -151,19 +145,18 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) endif if (info /= 0) then - call psb_errpush(info,name,i_err=int_err) - goto 9999 + call psb_errpush(info,name,i_err=int_err) + goto 9999 end if if (debug) write(*,*) 'psb_dscall: doing global checks' !global check on m and n parameters - if (myrow.eq.psb_root_) then + if (me == psb_root_) then exch(1)=m exch(2)=n - call igebs2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo) + call psb_bcast(ictxt,exch(1:2),root=psb_root_) else - call igebr2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,& - & 0) + call psb_bcast(ictxt,exch(1:2),root=psb_root_) if (exch(1) /= m) then info=550 int_err(1)=1 @@ -213,16 +206,16 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) desc_a%matrix_data(psb_n_col_) = n desc_a%matrix_data(psb_dec_type_) = psb_desc_repl_ desc_a%matrix_data(psb_ctxt_) = ictxt - call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_)) + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_cdtransfer.f90 b/src/tools/psb_cdtransfer.f90 index 6166d696c..4d7104adc 100644 --- a/src/tools/psb_cdtransfer.f90 +++ b/src/tools/psb_cdtransfer.f90 @@ -44,6 +44,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info) use psb_realloc_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -53,7 +54,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info) integer, intent(out) :: info !locals - integer :: nprow,npcol,me,mypcol,& + integer :: np,npcol,me,mypcol,& & ictxt, isz, dectype, err_act, err integer :: int_err(5),temp(1) real(kind(1.d0)) :: real_err(5) @@ -66,18 +67,13 @@ subroutine psb_cdtransfer(desc_in, desc_out, info) name = 'psb_cdtransfer' ictxt=desc_in%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + + call psb_info(ictxt, me, np) if (debug) write(0,*) me,'Entered CDTRANSFER' - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif call psb_nullify_desc(desc_out) @@ -100,7 +96,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_dallc.f90 b/src/tools/psb_dallc.f90 index 2bc65aec3..e75151f34 100644 --- a/src/tools/psb_dallc.f90 +++ b/src/tools/psb_dallc.f90 @@ -44,6 +44,7 @@ subroutine psb_dalloc(x, desc_a, info, n) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none @@ -55,14 +56,14 @@ subroutine psb_dalloc(x, desc_a, info, n) !locals - integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,i,j,jj,err_act + integer :: np,npcol,me,mycol,err,n_col,n_row,i,j,jj,err_act integer :: ictxt,dectype,n_ integer :: int_err(5),temp(1),exch(3) real(kind(1.d0)) :: real_err(5) character(len=20) :: name, ch_err name='psb_dallc' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 err=0 int_err(1)=0 @@ -70,17 +71,11 @@ subroutine psb_dalloc(x, desc_a, info, n) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif dectype=desc_a%matrix_data(psb_dec_type_) @@ -97,12 +92,12 @@ subroutine psb_dalloc(x, desc_a, info, n) n_ = 1 endif !global check on n parameters - if (myrow.eq.psb_root_) then + if (me == psb_root_) then exch(1)=n_ - call igebs2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione) + call psb_bcast(ictxt,exch(1),root=psb_root_) else - call igebr2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0) - if (exch(1).ne.n_) then + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then info=550 int_err(1)=1 call psb_errpush(info,name,int_err) @@ -114,7 +109,7 @@ subroutine psb_dalloc(x, desc_a, info, n) if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then n_col = max(1,desc_a%matrix_data(psb_n_col_)) allocate(x(n_col,n_),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) @@ -128,7 +123,7 @@ subroutine psb_dalloc(x, desc_a, info, n) else if (psb_is_bld_dec(dectype)) then n_row = max(1,desc_a%matrix_data(psb_n_row_)) allocate(x(n_row,n_),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) @@ -146,7 +141,7 @@ subroutine psb_dalloc(x, desc_a, info, n) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -198,6 +193,7 @@ subroutine psb_dallocv(x, desc_a,info,n) use psb_const_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none @@ -208,31 +204,26 @@ subroutine psb_dallocv(x, desc_a,info,n) integer, optional, intent(in) :: n !locals - integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act + integer :: np,npcol,me,mycol,err,n_col,n_row,dectype,i,err_act integer :: ictxt, n_ integer :: int_err(5),temp(1),exch real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_dallcv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif dectype=desc_a%matrix_data(psb_dec_type_) @@ -251,7 +242,7 @@ subroutine psb_dallocv(x, desc_a,info,n) if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then n_col = max(1,desc_a%matrix_data(psb_n_col_)) call psb_realloc(n_col,x,info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) @@ -264,7 +255,7 @@ subroutine psb_dallocv(x, desc_a,info,n) else if (psb_is_bld_dec(dectype)) then n_row = max(1,desc_a%matrix_data(psb_n_row_)) call psb_realloc(n_row,x,info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) @@ -280,7 +271,7 @@ subroutine psb_dallocv(x, desc_a,info,n) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_dasb.f90 b/src/tools/psb_dasb.f90 index e09741d35..96b2db18f 100644 --- a/src/tools/psb_dasb.f90 +++ b/src/tools/psb_dasb.f90 @@ -44,6 +44,7 @@ subroutine psb_dasb(x, desc_a, info) use psb_comm_mod use psb_error_mod use psb_realloc_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -51,46 +52,42 @@ subroutine psb_dasb(x, desc_a, info) integer, intent(out) :: info ! local variables - integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act + integer :: err, ictxt,np,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act integer :: int_err(5), i1sz, i2sz, dectype, i,j double precision :: real_err(5) real(kind(1.d0)),parameter :: one=1 logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_dasb' call psb_erractionsave(err_act) - ictxt=desc_a%matrix_data(psb_ctxt_) - dectype=desc_a%matrix_data(psb_dec_type_) - - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if ((.not.associated(desc_a%matrix_data))) then info=3110 call psb_errpush(info,name) goto 9999 endif - if (debug) write(*,*) 'asb start: ',nprow,npcol,me,& + ictxt=desc_a%matrix_data(psb_ctxt_) + dectype=desc_a%matrix_data(psb_dec_type_) + + call psb_info(ictxt, me, np) + + + if (debug) write(*,*) 'asb start: ',np,npcol,me,& &desc_a%matrix_data(psb_dec_type_) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 else if (.not.psb_is_asb_dec(dectype)) then if (debug) write(*,*) 'asb error ',& &dectype info = 3110 - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name) goto 9999 endif @@ -103,7 +100,7 @@ subroutine psb_dasb(x, desc_a, info) if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol if (i1sz.lt.ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info.ne.0) then + if (info /= 0) then info=2025 int_err(1)=ncol call psb_errpush(info,name,i_err=int_err) @@ -114,25 +111,23 @@ subroutine psb_dasb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) if(info /= 0) then - info=4010 - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else - call psb_error(ictxt) + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return - + end subroutine psb_dasb @@ -180,6 +175,7 @@ subroutine psb_dasbv(x, desc_a, info) use psb_comm_mod use psb_error_mod use psb_realloc_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -187,7 +183,7 @@ subroutine psb_dasbv(x, desc_a, info) integer, intent(out) :: info ! local variables - integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork + integer :: err, ictxt,np,npcol,me,mypcol,temp,lwork integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act double precision :: real_err(5) real(kind(1.d0)),parameter :: one=1 @@ -201,18 +197,13 @@ subroutine psb_dasbv(x, desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) dectype=desc_a%matrix_data(psb_dec_type_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 else if (.not.psb_is_asb_dec(dectype)) then info = 3110 call psb_errpush(info,name) @@ -226,35 +217,33 @@ subroutine psb_dasbv(x, desc_a, info) if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol if (i1sz.lt.ncol) then call psb_realloc(ncol,x,info) - if (info.ne.0) then + if (info /= 0) then info=2025 int_err(1)=ncol call psb_errpush(info,name,i_err=int_err) goto 9999 endif endif - + ! ..update halo elements.. call psb_halo(x,desc_a,info) if(info /= 0) then - info=4010 - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else - call psb_error(ictxt) + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return - + end subroutine psb_dasbv diff --git a/src/tools/psb_dcdovr.f90 b/src/tools/psb_dcdovr.f90 index 292f0a6cb..230e872e8 100644 --- a/src/tools/psb_dcdovr.f90 +++ b/src/tools/psb_dcdovr.f90 @@ -50,6 +50,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Use psb_prec_type Use psb_prec_mod use psb_error_mod + use psb_penv_mod Implicit None ! .. Array Arguments .. @@ -65,33 +66,33 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) !!$ integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event interface psb_cdcpy - subroutine psb_cdcpy(desc_in,desc_out,info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_in - type(psb_desc_type), intent(out) :: desc_out - integer, intent(out) :: info - end subroutine psb_cdcpy + subroutine psb_cdcpy(desc_in,desc_out,info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_in + type(psb_desc_type), intent(out) :: desc_out + integer, intent(out) :: info + end subroutine psb_cdcpy end interface interface psb_cdovrbld - subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,l_tmp_halo,& - & l_tmp_ovr_idx,lworks,lworkr,info) - use psb_prec_type - use psb_spmat_type - type(psb_dspmat_type),intent(in) :: a - type(psb_desc_type),intent(in) :: desc_a - type(psb_desc_type),intent(inout) :: desc_p - integer,intent(in) :: n_ovr - integer, intent(in) :: l_tmp_halo,l_tmp_ovr_idx - integer, intent(inout) :: lworks, lworkr - integer, intent(out) :: info - end subroutine psb_dcdovrbld + subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,l_tmp_halo,& + & l_tmp_ovr_idx,lworks,lworkr,info) + use psb_prec_type + use psb_spmat_type + type(psb_dspmat_type),intent(in) :: a + type(psb_desc_type),intent(in) :: desc_a + type(psb_desc_type),intent(inout) :: desc_p + integer,intent(in) :: n_ovr + integer, intent(in) :: l_tmp_halo,l_tmp_ovr_idx + integer, intent(inout) :: lworks, lworkr + integer, intent(out) :: info + end subroutine psb_dcdovrbld end interface ! .. Local Scalars .. - Integer :: i, j, k, nprow,npcol, me, mycol,m,nnzero,& + Integer :: i, j, k, np,npcol, me, mycol,m,nnzero,& & ictxt, lovr, lelem,lworks,lworkr, n_col, int_err(5),& & n_row,index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Logical,Parameter :: debug=.false. @@ -103,7 +104,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) ictxt=desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + Call psb_info(ictxt, me, np) If(debug) Write(0,*)'in psb_cdovr',novr @@ -113,11 +114,11 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) nhalo = n_col-m If(debug) Write(0,*)'IN CDOVR1',novr ,m,nnzero,n_col if (novr<0) then - info=10 - int_err(1)=1 - int_err(2)=novr - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info=10 + int_err(1)=1 + int_err(2)=novr + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif if (novr==0) then @@ -127,16 +128,16 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) if (debug) write(0,*) 'Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) if (info /= 0) then - info=4010 - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (debug) write(0,*) 'From desccpy' return endif - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm ) !!$ call MPI_Comm_rank(icomm,irank,ierr) !!$ idscb = mpe_log_get_event_number() !!$ idsce = mpe_log_get_event_number() @@ -148,7 +149,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) !!$ endif If(debug) then Write(0,*)'BEGIN cdovr',me,nhalo - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif t1 = mpi_wtime() @@ -162,19 +163,19 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) ! call psb_spinfo(psb_nztotreq_,a,nztot,info) if (info /= 0) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (nztot>0) then - lovr = ((nztot+m-1)/m)*nhalo*novr - lworks = ((nztot+m-1)/m)*nhalo - lworkr = ((nztot+m-1)/m)*nhalo + lovr = ((nztot+m-1)/m)*nhalo*novr + lworks = ((nztot+m-1)/m)*nhalo + lworkr = ((nztot+m-1)/m)*nhalo else - info=-1 - call psb_errpush(info,name) - goto 9999 + info=-1 + call psb_errpush(info,name) + goto 9999 endif If(debug)Write(0,*)'ovr_est done',me,novr,lovr index_dim = size(desc_a%halo_index) @@ -185,9 +186,9 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) & desc_ov%matrix_data(psb_mdata_size_),& & desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO) if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if l_tmp_ovr_idx=novr*(3*Max(2*index_dim,1)+1) @@ -202,16 +203,16 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),& & desc_ov%glob_to_loc(Size(desc_a%glob_to_loc)),stat=info) if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if desc_ov%loc_to_glob(:) = desc_a%loc_to_glob(:) desc_ov%glob_to_loc(:) = desc_a%glob_to_loc(:) If(debug) then Write(0,*)'Start cdovrbld',me,lworks,lworkr - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif ! ! The real work goes on in here.... @@ -219,26 +220,26 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Call psb_cdovrbld(novr,desc_ov,desc_a,a,& & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) if (info /= 0) then - info=4010 - ch_err='psb_cdovrbld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_cdovrbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if desc_ov%matrix_data(psb_dec_type_) = psb_desc_asb_ If(debug) then Write(0,*)'Done cdovrbld',me,lworks,lworkr - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif !!$ ierr = MPE_Log_event( idsce, 0, "st CDASB" ) call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == act_abort) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if Return diff --git a/src/tools/psb_dcdovrbld.f90 b/src/tools/psb_dcdovrbld.f90 index abd61c450..b61490c47 100644 --- a/src/tools/psb_dcdovrbld.f90 +++ b/src/tools/psb_dcdovrbld.f90 @@ -55,6 +55,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& use psb_tools_mod, only : psb_cdprt use psb_error_mod use psb_const_mod + use psb_penv_mod Implicit None include 'mpif.h' @@ -73,7 +74,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& Integer, Pointer :: tmp_halo(:),tmp_ovr_idx(:) Integer :: counter,counter_h, counter_o, counter_e,j,idx,gidx,proc,n_elem_recv,& - & n_elem_send,tot_recv,tot_elem,n_col,m,ictxt,np,npcol,myrow,mycol,dl_lda,lwork,& + & n_elem_send,tot_recv,tot_elem,n_col,m,ictxt,np,npcol,me,mycol,dl_lda,lwork,& & counter_t,n_elem,i_ovr,jj,n,i,proc_id,isz, mglob, glx,n_row, & & idxr, idxs, lx, iszs, iszr, err_act @@ -94,8 +95,9 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& If(debug) Write(0,*)'cdovrbld begin' ictxt = desc_a%matrix_data(psb_ctxt_) -!!$ call blacs_barrier(ictxt,'All') - Call blacs_gridinfo(ictxt,np,npcol,myrow,mycol) + + Call psb_info(ictxt,me,np) + call psb_nullify_sp(blk) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) @@ -106,13 +108,13 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& tl = 0.0 tch = 0.0 t4 = 0.0 - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm ) mglob = desc_a%matrix_data(psb_m_) m = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_) n_col = desc_a%matrix_data(psb_n_col_) - if (debug) write(0,*) myrow,' On entry to CDOVRBLD n_col:',n_col + if (debug) write(0,*) me,' On entry to CDOVRBLD n_col:',n_col dl_lda=np*5 lwork=5*(5*np+2)*np+10 @@ -127,10 +129,10 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& call psb_sp_all(blk,max(lworks,lworkr),info) if (info /= 0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if blk%fida='COO' @@ -153,12 +155,12 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& ! See comment in main loop below. call InitPairSearchTree(info) if (info /= 0) then - info=4010 - ch_err='InitPairSearhTree' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='InitPairSearhTree' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - if (debug) write(0,*) myrow,'Done InitPairSearchTree',info + if (debug) write(0,*) me,'Done InitPairSearchTree',info ! ! A picture is in order to understand what goes on here. @@ -182,438 +184,438 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& ! Do i_ovr=1,n_ovr - if (debug) write(0,*) myrow,'Running on overlap level ',i_ovr,' of ',n_ovr + if (debug) write(0,*) me,'Running on overlap level ',i_ovr,' of ',n_ovr !!$ t_halo_in(:) = -1 - ! - ! At this point, halo contains a valid halo corresponding to the - ! matrix enlarged with the elements in the frontier for I_OVR-1. - ! At the start, this is just the halo for A; the rows for indices in - ! the first halo will contain column indices defining the second halo - ! level and so on. - ! - bsdindx(:) = 0 - sdsz(:) = 0 - brvindx(:) = 0 - rvsz(:) = 0 - idxr = 0 - idxs = 0 - counter = 1 - counter_t = 1 + ! + ! At this point, halo contains a valid halo corresponding to the + ! matrix enlarged with the elements in the frontier for I_OVR-1. + ! At the start, this is just the halo for A; the rows for indices in + ! the first halo will contain column indices defining the second halo + ! level and so on. + ! + bsdindx(:) = 0 + sdsz(:) = 0 + brvindx(:) = 0 + rvsz(:) = 0 + idxr = 0 + idxs = 0 + counter = 1 + counter_t = 1 - t1 = mpi_wtime() - Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) - If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then - info=-1 - call psb_errpush(info,name) - goto 9999 - end If - tot_recv=tot_recv+n_elem_recv - if (debug) write(0,*) myrow,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv - ! - ! While running through the column indices exchanged with other procs - ! we have to keep track of which elements actually are overlap and halo - ! ones to record them in overlap_elem. We do this by maintaining - ! an AVL balanced search tree: at each point counter_e is the next - ! free index element. The search routine for gidx will return - ! glx if gidx was already assigned a local index (glx Size(halo)) then + info=-1 + call psb_errpush(info,name) + goto 9999 + end If + tot_recv=tot_recv+n_elem_recv + if (debug) write(0,*) me,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv + ! + ! While running through the column indices exchanged with other procs + ! we have to keep track of which elements actually are overlap and halo + ! ones to record them in overlap_elem. We do this by maintaining + ! an AVL balanced search tree: at each point counter_e is the next + ! free index element. The search routine for gidx will return + ! glx if gidx was already assigned a local index (glxSize(halo)) then - info=-2 - call psb_errpush(info,name) - goto 9999 - end If - idx = halo(counter+psb_elem_recv_+j) - idx = halo(counter+psb_elem_recv_+j) - If(idx > Size(desc_p%loc_to_glob)) then - info=-3 - call psb_errpush(info,name) - goto 9999 - endif + t3 = mpi_wtime() + ! + ! add recv elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_recv-1 + If((counter+psb_elem_recv_+j)>Size(halo)) then + info=-2 + call psb_errpush(info,name) + goto 9999 + end If + idx = halo(counter+psb_elem_recv_+j) + idx = halo(counter+psb_elem_recv_+j) + If(idx > Size(desc_p%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif - gidx = desc_p%loc_to_glob(idx) + gidx = desc_p%loc_to_glob(idx) - If((counter_o+2) > Size(tmp_ovr_idx)) Then - isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) - if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz - call psb_realloc(isz,tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + If((counter_o+2) > Size(tmp_ovr_idx)) Then + isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) + if (debug) write(0,*) me,'Realloc tmp_ovr',isz + call psb_realloc(isz,tmp_ovr_idx,info,pad=-1) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 - If((counter_h+2) > Size(tmp_halo)) Then - isz = max((3*Size(tmp_halo))/2,(counter_h+3)) - if (debug) write(0,*) myrow,'Realloc tmp_halo',isz - call psb_realloc(isz,tmp_halo,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + If((counter_h+2) > Size(tmp_halo)) Then + isz = max((3*Size(tmp_halo))/2,(counter_h+3)) + if (debug) write(0,*) me,'Realloc tmp_halo',isz + call psb_realloc(isz,tmp_halo,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - tmp_halo(counter_h)=proc - tmp_halo(counter_h+1)=1 - tmp_halo(counter_h+2)=idx - tmp_halo(counter_h+3)=-1 + tmp_halo(counter_h)=proc + tmp_halo(counter_h+1)=1 + tmp_halo(counter_h+2)=idx + tmp_halo(counter_h+3)=-1 - counter_h=counter_h+3 + counter_h=counter_h+3 - call SearchInsKeyVal(gidx,counter_e,glx,info) + call SearchInsKeyVal(gidx,counter_e,glx,info) !!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) myrow,'Realloc ovr_El',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + if (info>=0) then + If (glx < counter_e) Then + desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & + & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 + Else + If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then + isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) + if (debug) write(0,*) me,'Realloc ovr_El',isz + call psb_realloc(isz,desc_p%ovrlap_elem,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If !!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) myrow, 'Cdovrbld From SearchInsKeyVal: ',info - endif - Enddo - if (debug) write(0,*) myrow,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) - counter = counter+n_elem_recv + desc_p%ovrlap_elem(counter_e)=gidx + desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 + desc_p%ovrlap_elem(counter_e+2)=-1 + counter_e = counter_e + 2 + End If + else + write(0,*) me, 'Cdovrbld From SearchInsKeyVal: ',info + endif + Enddo + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + counter = counter+n_elem_recv - ! - ! add send elements in halo_index into ovrlap_index - ! - Do j=0,n_elem_send-1 + ! + ! add send elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_send-1 - idx = halo(counter+psb_elem_send_+j) - gidx = desc_p%loc_to_glob(idx) + idx = halo(counter+psb_elem_send_+j) + gidx = desc_p%loc_to_glob(idx) - If((counter_o+2) > Size(tmp_ovr_idx)) Then - isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) - if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz - call psb_realloc(isz,tmp_ovr_idx,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + If((counter_o+2) > Size(tmp_ovr_idx)) Then + isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) + if (debug) write(0,*) me,'Realloc tmp_ovr',isz + call psb_realloc(isz,tmp_ovr_idx,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 - call SearchInsKeyVal(gidx,counter_e,glx,info) + call SearchInsKeyVal(gidx,counter_e,glx,info) !!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) myrow,'Realloc ovr_el',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + if (info>=0) then + If (glx < counter_e) Then + desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & + & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 + Else + If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then + isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) + if (debug) write(0,*) me,'Realloc ovr_el',isz + call psb_realloc(isz,desc_p%ovrlap_elem,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If !!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) myrow,'Cdovrbld From SearchInsKeyVal: ',info - endif + desc_p%ovrlap_elem(counter_e)=gidx + desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 + desc_p%ovrlap_elem(counter_e+2)=-1 + counter_e = counter_e + 2 + End If + else + write(0,*) me,'Cdovrbld From SearchInsKeyVal: ',info + endif - ! - ! Prepare to exchange the halo rows with the other proc. - ! - If (i_ovr < (n_ovr)) Then - call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) - if (info /= 0) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + ! + ! Prepare to exchange the halo rows with the other proc. + ! + If (i_ovr < (n_ovr)) Then + call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) + if (info /= 0) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if - If((idxs+tot_elem+n_elem) > lworks) Then - isz = max((3*lworks)/2,(idxs+tot_elem+n_elem)) - if (debug) write(0,*) myrow,'Realloc works',isz - call psb_realloc(isz,works,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - lworks = isz - End If - If((n_elem) > size(blk%ia2)) Then - isz = max((3*size(blk%ia2))/2,(n_elem)) - if (debug) write(0,*) myrow,'Realloc blk',isz - call psb_sp_reall(blk,isz,info) - if (info /= 0) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If - - call psb_spgtblk(idx,a,blk,info) - if (info /= 0) then - info=4010 - ch_err='psb_spgtblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - Do jj=1,n_elem - works(idxs+tot_elem+jj)=desc_p%loc_to_glob(blk%ia2(jj)) - End Do - tot_elem=tot_elem+n_elem - End If - - Enddo - - t4 = t4 + mpi_wtime() -t3 - - if (i_ovr < n_ovr) then - if (tot_elem > 1) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - if (tot_elem+2 > size(temp)) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - deallocate(temp) - allocate(temp(tot_elem+2),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - endif - Call mrgsrt(tot_elem,works(idxs+1),temp,info) - If (info.Eq.0) Call ireordv1(tot_elem,works(idxs+1),temp) - lx = works(idxs+1) - i = 1 - j = 1 - do - j = j + 1 - if (j > tot_elem) exit - if (works(idxs+j) /= lx) then - i = i + 1 - works(idxs+i) = works(idxs+j) - lx = works(idxs+i) - end if - end do - tot_elem = i - endif - if (debug) write(0,*) myrow,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) - sdsz(proc+1) = tot_elem - idxs = idxs + tot_elem - end if - counter = counter+n_elem_send+3 - if (debug) write(0,*) myrow,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) - Enddo - if (debug) write(0,*)myrow,'End phase 1 CDOVRBLD', m, n_col, tot_recv - - if (i_ovr < n_ovr) then - ! - ! Exchange data requests with everybody else: so far we have - ! accumulated RECV requests, we have an all-to-all to build - ! matchings SENDs. - ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - idxs = 0 - idxr = 0 - counter = 1 - Do - proc=halo(counter) - if (proc == -1) exit - n_elem_recv = halo(counter+psb_n_elem_recv_) - counter = counter+n_elem_recv - n_elem_send = halo(counter+psb_n_elem_send_) - - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) - counter = counter+n_elem_send+3 - Enddo - - iszr=sum(rvsz) - if (max(iszr,1) > lworkr) then - call psb_realloc(max(iszr,1),workr,info) - if (info /= 0) then + If((idxs+tot_elem+n_elem) > lworks) Then + isz = max((3*lworks)/2,(idxs+tot_elem+n_elem)) + if (debug) write(0,*) me,'Realloc works',isz + call psb_realloc(isz,works,info) + if (info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if - lworkr=max(iszr,1) - end if + end if + lworks = isz + End If + If((n_elem) > size(blk%ia2)) Then + isz = max((3*size(blk%ia2))/2,(n_elem)) + if (debug) write(0,*) me,'Realloc blk',isz + call psb_sp_reall(blk,isz,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) + call psb_spgtblk(idx,a,blk,info) + if (info /= 0) then + info=4010 + ch_err='psb_spgtblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Do jj=1,n_elem + works(idxs+tot_elem+jj)=desc_p%loc_to_glob(blk%ia2(jj)) + End Do + tot_elem=tot_elem+n_elem + End If + + Enddo + + t4 = t4 + mpi_wtime() -t3 + + if (i_ovr < n_ovr) then + if (tot_elem > 1) then +!!$ write(0,*) me,'Realloc temp',tot_elem+2 + if (tot_elem+2 > size(temp)) then +!!$ write(0,*) me,'Realloc temp',tot_elem+2 + deallocate(temp) + allocate(temp(tot_elem+2),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + endif + Call mrgsrt(tot_elem,works(idxs+1),temp,info) + If (info == 0) Call ireordv1(tot_elem,works(idxs+1),temp) + lx = works(idxs+1) + i = 1 + j = 1 + do + j = j + 1 + if (j > tot_elem) exit + if (works(idxs+j) /= lx) then + i = i + 1 + works(idxs+i) = works(idxs+j) + lx = works(idxs+i) + end if + end do + tot_elem = i + endif + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + sdsz(proc+1) = tot_elem + idxs = idxs + tot_elem + end if + counter = counter+n_elem_send+3 + if (debug) write(0,*) me,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) + Enddo + if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv + + if (i_ovr < n_ovr) then + ! + ! Exchange data requests with everybody else: so far we have + ! accumulated RECV requests, we have an all-to-all to build + ! matchings SENDs. + ! + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=halo(counter) + if (proc == -1) exit + n_elem_recv = halo(counter+psb_n_elem_recv_) + counter = counter+n_elem_recv + n_elem_send = halo(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_elem_send+3 + Enddo + + iszr=sum(rvsz) + if (max(iszr,1) > lworkr) then + call psb_realloc(max(iszr,1),workr,info) if (info /= 0) then - info=4010 - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + lworkr=max(iszr,1) + end if + + call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& + & workr,rvsz,brvindx,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Do i=1,iszr + idx=workr(i) + if (idx <1) then + write(0,*) me,'Error in CDOVRBLD ',idx,i,iszr +!!$ write(0,*) me, ' WORKR :',workr(1:iszr) + else If (desc_p%glob_to_loc(idx) < -np) Then + ! + ! This is a new index. Assigning a local index as + ! we receive the guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I Size(desc_p%loc_to_glob)) Then + isz = 3*n_col/2 + if (debug) write(0,*) me,'Realloc loc_to_glob' + call psb_realloc(isz,desc_p%loc_to_glob,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If + desc_p%glob_to_loc(idx)=n_col + desc_p%loc_to_glob(n_col)=idx + If((counter_t+3) > Size(t_halo_in))Write(0,*)'bingo' + t_halo_in(counter_t)=proc_id + t_halo_in(counter_t+1)=1 + t_halo_in(counter_t+2)=n_col + counter_t=counter_t+3 + if (debug) write(0,*) me,' CDOVRBLD: Added into t_halo_in from recv',& + &proc_id,n_col,idx + else if (desc_p%glob_to_loc(idx) < 0) Then + if (debug) write(0,*) me,'Wrong input to cdovrbld??',& + &idx,desc_p%glob_to_loc(idx) + End If + End Do + end if + t2 = mpi_wtime() + n_row=m+tot_recv + desc_p%matrix_data(psb_n_row_)=n_row + desc_p%matrix_data(psb_n_col_)=n_col + + ! + ! Ok, now we have a temporary halo with all the info for the + ! next round. If we need to keep going, convert the halo format + ! from temporary to final, so that we can work out the next iteration. + ! This uses one of the convert_comm internals, i.e. we are doing + ! the equivalent of a partial call to convert_comm + ! + + If (i_ovr < (n_ovr)) Then + + If(lwork < (counter_t/3+np*3)) Then + isz = max((3*lwork)/2,(counter_t/3+np*3)) + if (debug) write(0,*) me,'Realloc work',isz + deallocate(work) + allocate(work(isz),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 end if - Do i=1,iszr - idx=workr(i) - if (idx <1) then - write(0,*) myrow,'Error in CDOVRBLD ',idx,i,iszr -!!$ write(0,*) myrow, ' WORKR :',workr(1:iszr) - else If (desc_p%glob_to_loc(idx) < -np) Then - ! - ! This is a new index. Assigning a local index as - ! we receive the guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I Size(desc_p%loc_to_glob)) Then - isz = 3*n_col/2 - if (debug) write(0,*) myrow,'Realloc loc_to_glob' - call psb_realloc(isz,desc_p%loc_to_glob,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If - desc_p%glob_to_loc(idx)=n_col - desc_p%loc_to_glob(n_col)=idx - If((counter_t+3) > Size(t_halo_in))Write(0,*)'bingo' - t_halo_in(counter_t)=proc_id - t_halo_in(counter_t+1)=1 - t_halo_in(counter_t+2)=n_col - counter_t=counter_t+3 - if (debug) write(0,*) myrow,' CDOVRBLD: Added into t_halo_in from recv',& - &proc_id,n_col,idx - else if (desc_p%glob_to_loc(idx) < 0) Then - if (debug) write(0,*) myrow,'Wrong input to cdovrbld??',& - &idx,desc_p%glob_to_loc(idx) - End If - End Do - end if - t2 = mpi_wtime() - n_row=m+tot_recv - desc_p%matrix_data(psb_n_row_)=n_row - desc_p%matrix_data(psb_n_col_)=n_col - - ! - ! Ok, now we have a temporary halo with all the info for the - ! next round. If we need to keep going, convert the halo format - ! from temporary to final, so that we can work out the next iteration. - ! This uses one of the convert_comm internals, i.e. we are doing - ! the equivalent of a partial call to convert_comm - ! - - If (i_ovr < (n_ovr)) Then - - If(lwork < (counter_t/3+np*3)) Then - isz = max((3*lwork)/2,(counter_t/3+np*3)) - if (debug) write(0,*) myrow,'Realloc work',isz - deallocate(work) - allocate(work(isz),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - lwork=size(work) - Endif - t_halo_in(counter_t)=-1 + lwork=size(work) + Endif + t_halo_in(counter_t)=-1 !!$ !!$ t_halo_out(:)=-1 !!$ ierr = MPE_Log_event( icrhb, 0, "st CRTHAL" ) - if (debug) write(0,*) myrow,'Checktmp_o_i 1',tmp_ovr_idx(1:10) - if (debug) write(0,*) myrow,'Calling Crea_Halo' - - call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) + if (debug) write(0,*) me,'Checktmp_o_i 1',tmp_ovr_idx(1:10) + if (debug) write(0,*) me,'Calling Crea_Halo' + + call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) !!$ Call psi_crea_halo(desc_p%matrix_data,t_halo_in,& !!$ & np,t_halo_out,Size(t_halo_out),dep_list,& !!$ & dl_lda,length_dl,desc_p%loc_to_glob,& !!$ & desc_p%glob_to_loc,work,lwork,info) - if (debug) then - write(0,*) myrow,'Done Crea_Halo' - call blacs_barrier(ictxt,'All') - end if - if (debug) write(0,*) myrow,'Checktmp_o_i 2',tmp_ovr_idx(1:10) - if (debug) write(0,*) myrow,'Done Crea_Halo' + if (debug) then + write(0,*) me,'Done Crea_Halo' + call psb_barrier(ictxt) + end if + if (debug) write(0,*) me,'Checktmp_o_i 2',tmp_ovr_idx(1:10) + if (debug) write(0,*) me,'Done Crea_Halo' !!$ ierr = MPE_Log_event( icrhe, 0, "ed CRHAL " ) - halo => t_halo_out - ! - ! At this point we have built the halo necessary for I_OVR+1. - ! - End If - if (debug) write(0,*) myrow,'Checktmp_o_i ',tmp_ovr_idx(1:10) - t3 = mpi_wtime() - tl = tl +(t2-t1) - tch = tch +(t3-t2) + halo => t_halo_out + ! + ! At this point we have built the halo necessary for I_OVR+1. + ! + End If + if (debug) write(0,*) me,'Checktmp_o_i ',tmp_ovr_idx(1:10) + t3 = mpi_wtime() + tl = tl +(t2-t1) + tch = tch +(t3-t2) End Do t1 = mpi_wtime() call FreePairSearchTree() @@ -632,24 +634,24 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& ! if (debug) then - write(0,*) 'psb_cdasb: converting indexes' - call blacs_barrier(ictxt,'All') + write(0,*) 'psb_cdasb: converting indexes' + call psb_barrier(ictxt) end if !.... convert comunication stuctures.... ! first the halo index call psi_crea_index(desc_p,tmp_halo,& & desc_p%halo_index,.false.,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 end if ! then the overlap index call psi_crea_index(desc_p,tmp_ovr_idx,& & desc_p%ovrlap_index,.true.,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 end if ! next is the ovrlap_elem index @@ -658,8 +660,8 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& ! finally bnd_elem call psi_crea_bnd_elem(desc_p,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') - goto 9999 + call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') + goto 9999 end if ! Ok, register into MATRIX_DATA & free temporary work areas @@ -674,25 +676,25 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& desc_p%lprm(1) = 0 if (debug) then - write(0,*) myrow,'Done Convert_comm' - call blacs_barrier(ictxt,'All') + write(0,*) me,'Done Convert_comm' + call psb_barrier(ictxt) end if if (.false.) then - call psb_cdprt(70+myrow,desc_p,.false.) + call psb_cdprt(70+me,desc_p,.false.) end if - if (debug) write(0,*) myrow,'Done ConvertComm' + if (debug) write(0,*) me,'Done ConvertComm' !!$ ierr = MPE_Log_event( iovre, 0, "ed CNVCRT" ) Deallocate(works,workr,t_halo_in,t_halo_out,work,& & length_dl,dep_list,tmp_ovr_idx,tmp_halo,& & brvindx,rvsz,sdsz,bsdindx,temp,stat=info) if (info == 0) call psb_sp_free(blk,info) if (info /= 0) then - info=4010 - ch_err='sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if t2 = mpi_wtime() @@ -701,9 +703,9 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_dcsrp.f90 b/src/tools/psb_dcsrp.f90 index 5c04eb959..06b3b54c1 100644 --- a/src/tools/psb_dcsrp.f90 +++ b/src/tools/psb_dcsrp.f90 @@ -49,16 +49,16 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) interface dcsrp - subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - double precision, intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsrp + subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& + & infoa,p,work,lwork,ierror) + integer, intent(in) :: m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + double precision, intent(inout) :: work(*) + integer, intent(in) :: p(*) + integer, intent(inout) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine dcsrp end interface @@ -79,7 +79,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) integer :: int_err(5),p(1),infoa(10) real(kind(1.d0)) :: real_err(5) integer,pointer :: ipt(:) - integer :: i,err,nprow,npcol,me,& + integer :: i,err,np,npcol,me,& & mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize integer :: dectype real(kind(1.d0)), pointer :: work_dcsdp(:) @@ -96,23 +96,18 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) dectype=desc_a%matrix_data(psb_dec_type_) n_row = desc_a%matrix_data(psb_n_row_) n_col = desc_a%matrix_data(psb_n_col_) - - if(psb_get_errstatus().ne.0) return + + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psd_csrp' ! check on blacs grid - call psb_info(ictxt, me, nprow) - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif @@ -121,10 +116,10 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) int_err(1) = dectype call psb_errpush(info,name,int_err) goto 9999 - endif + endif ipsize = size(iperm) - if (.not.((ipsize.eq.n_col).or.(ipsize.eq.n_row) )) then + if (.not.((ipsize == n_col).or.(ipsize == n_row) )) then info = 35 int_err(1) = 1 int_err(2) = ipsize @@ -140,17 +135,17 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) endif l_dcsdp = (n_col) - + call psb_realloc(l_dcsdp,work_dcsdp,info) call psb_realloc(n_col,ipt,info) if(info /= no_err) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 + info=4010 + char_err='psrealloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 end if - if (ipsize.eq.n_col) then + if (ipsize == n_col) then do i=1, n_col ipt(i) = iperm(i) enddo @@ -170,19 +165,18 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) call dcsrp(trans,n_row,n_col,a%fida,a%descra,a%ia1,a%ia2,a%infoa,& & ipt,work_dcsdp,size(work_dcsdp),info) if(info /= no_err) then - info=4010 - char_err='dcsrp' - call psb_errpush(info,name,a_err=char_err) - goto 9999 + info=4010 + char_err='dcsrp' + call psb_errpush(info,name,a_err=char_err) + goto 9999 end if - + deallocate(ipt,work_dcsdp) - + time(4) = mpi_wtime() time(4) = time(4) - time(3) if (debug) then call psb_amx(ictxt, time(4)) - write (*, *) ' comm structs assembly: ', time(4)*1.d-3 end if @@ -191,9 +185,9 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error() - return + if (err_act == act_abort) then + call psb_error() + return end if return diff --git a/src/tools/psb_dfree.f90 b/src/tools/psb_dfree.f90 index 8a8cc2b2a..23246caae 100644 --- a/src/tools/psb_dfree.f90 +++ b/src/tools/psb_dfree.f90 @@ -42,6 +42,7 @@ subroutine psb_dfree(x, desc_a, info) use psb_const_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -51,63 +52,55 @@ subroutine psb_dfree(x, desc_a, info) !...locals.... integer :: int_err(5) - integer :: ictxt,nprow,npcol,me,mypcol,err, err_act + integer :: ictxt,np,npcol,me,mypcol,err, err_act character(len=20) :: name - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name='psb_dfree' + if (.not.associated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + return + end if ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - if (.not.associated(desc_a%matrix_data)) then - info=295 - call psb_errpush(info,name) - goto 9999 - end if - if (.not.associated(x)) then - info=295 - call psb_errpush(info,name) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if !deallocate x deallocate(x,stat=info) - if (info.ne.no_err) then - info=4000 - call psb_errpush(info,name) - goto 9999 + if (info /= no_err) then + info=4000 + call psb_errpush(info,name) + goto 9999 else - nullify(x) + nullify(x) endif - + call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else + if (err_act == act_abort) then call psb_error(ictxt) + return end if return @@ -127,70 +120,62 @@ subroutine psb_dfreev(x, desc_a, info) use psb_const_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod implicit none !....parameters... real(kind(1.d0)),pointer :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer :: info - + integer, intent(out) :: info !...locals.... integer :: int_err(5) - integer :: ictxt,nprow,npcol,me,mypcol,err, err_act + integer :: ictxt,np,npcol,me,mypcol,err, err_act character(len=20) :: name - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name='psb_dfreev' - ictxt=desc_a%matrix_data(psb_ctxt_) - + if (.not.associated(desc_a%matrix_data)) then info=295 call psb_errpush(info,name) - goto 9999 + return end if + ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (.not.associated(x)) then - info=295 - call psb_errpush(info,name) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if !deallocate x deallocate(x,stat=info) - if (info.ne.no_err) then - info=4000 - call psb_errpush(info,name) + if (info /= no_err) then + info=4000 + call psb_errpush(info,name) else - nullify(x) + nullify(x) endif - + call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else + if (err_act == act_abort) then call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_dgelp.f90 b/src/tools/psb_dgelp.f90 index bbe694954..3f4827045 100644 --- a/src/tools/psb_dgelp.f90 +++ b/src/tools/psb_dgelp.f90 @@ -45,6 +45,7 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -53,7 +54,7 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info) character, intent(in) :: trans ! local variables - integer :: err, ictxt,nprow, & + integer :: err, ictxt,np, & & npcol,me,mypcol,temp,lwork,nrow,ncol real(kind(1.d0)),pointer :: dtemp(:) integer :: int_err(5), i1sz, i2sz, dectype, i, err_act @@ -62,27 +63,27 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info) logical, parameter :: debug=.false. interface dgelp - subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - double precision, intent(inout) :: b(ldb,*), work(*) - integer, intent(in) :: p(*) - end subroutine dgelp + subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + double precision, intent(inout) :: b(ldb,*), work(*) + integer, intent(in) :: p(*) + end subroutine dgelp end interface interface isaperm - logical function isaperm(n,ip) - integer, intent(in) :: n - integer, intent(inout) :: ip(*) - end function isaperm + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm end interface character(len=20) :: name, ch_err name = 'psb_dgelp' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -93,42 +94,37 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info) i1sz = size(x,dim=1) i2sz = size(x,dim=2) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) - if (debug) write(*,*) 'asb start: ',nprow,npcol,me,& + if (debug) write(*,*) 'asb start: ',np,npcol,me,& &desc_a%matrix_data(psb_dec_type_) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 else if (.not.psb_is_asb_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif if (.not.isaperm(i1sz,iperm)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol allocate(dtemp(i1sz),stat=info) call dgelp(trans,i1sz,i2sz,iperm,x,i1sz,dtemp,i1sz,info) - if(info.ne.0) then - info=4010 - ch_err='dgelp' - call psb_errpush(info,name,a_err=ch_err) + if(info /= 0) then + info=4010 + ch_err='dgelp' + call psb_errpush(info,name,a_err=ch_err) end if deallocate(dtemp) @@ -139,10 +135,10 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return @@ -195,6 +191,7 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -203,7 +200,7 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info) character, intent(in) :: trans ! local variables - integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork + integer :: err, ictxt,np,npcol,me,mypcol,temp,lwork integer :: int_err(5), i1sz,nrow,ncol,dectype, i, err_act real(kind(1.d0)),pointer :: dtemp(:) double precision :: real_err(5) @@ -212,27 +209,27 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info) logical, parameter :: debug=.false. interface dgelp - subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - double precision, intent(inout) :: b(*), work(*) - integer, intent(in) :: p(*) - end subroutine dgelp + subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + double precision, intent(inout) :: b(*), work(*) + integer, intent(in) :: p(*) + end subroutine dgelp end interface interface isaperm - logical function isaperm(n,ip) - integer, intent(in) :: n - integer, intent(inout) :: ip(*) - end function isaperm + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm end interface character(len=20) :: name, ch_err name = 'psb_dgelpv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -243,40 +240,35 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info) nrow=desc_a%matrix_data(psb_n_row_) ncol=desc_a%matrix_data(psb_n_col_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 else if (.not.psb_is_asb_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif if (debug) write(0,*) 'calling isaperm ',i1sz,size(iperm),trans if (.not.isaperm(i1sz,iperm)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif allocate(dtemp(i1sz),stat=info) call dgelp(trans,i1sz,1,iperm,x,i1sz,dtemp,i1sz,info) - if(info.ne.0) then - info=4010 - ch_err='dgelp' - call psb_errpush(info,name,a_err=ch_err) + if(info /= 0) then + info=4010 + ch_err='dgelp' + call psb_errpush(info,name,a_err=ch_err) end if deallocate(dtemp) @@ -287,10 +279,10 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/src/tools/psb_dins.f90 b/src/tools/psb_dins.f90 index 428518788..cd358f624 100644 --- a/src/tools/psb_dins.f90 +++ b/src/tools/psb_dins.f90 @@ -44,11 +44,10 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix ! must be inserted @@ -64,10 +63,10 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) !locals..... integer :: ictxt,i,loc_row,glob_row,row,k,& & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err - integer :: nprow,npcol, me ,mypcol,dupl_ + integer :: np,npcol, me ,mypcol,dupl_ character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dinsvi' @@ -85,21 +84,15 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif !... check parameters.... - if (m.lt.0) then + if (m < 0) then info = 10 int_err(1) = 1 int_err(2) = m @@ -110,7 +103,7 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) int_err(1) = desc_a%matrix_data(psb_dec_type_) call psb_errpush(info,name,int_err) goto 9999 - else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then + else if (size(x, dim=1) < desc_a%matrix_data(psb_n_row_)) then info = 310 int_err(1) = 5 int_err(2) = 4 @@ -176,7 +169,7 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) @@ -231,6 +224,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none ! m rows number of submatrix belonging to val to be inserted @@ -252,10 +246,10 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) !locals..... integer :: ictxt,i,loc_row,glob_row,row,k,j,n,& & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err - integer :: nprow,npcol, me ,mypcol,dupl_ + integer :: np,npcol, me ,mypcol,dupl_ character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dinsi' @@ -273,21 +267,15 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif !... check parameters.... - if (m.lt.0) then + if (m < 0) then info = 10 int_err(1) = 1 int_err(2) = m @@ -298,7 +286,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) int_err(1) = desc_a%matrix_data(psb_dec_type_) call psb_errpush(info,name,int_err) goto 9999 - else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then + else if (size(x, dim=1) < desc_a%matrix_data(psb_n_row_)) then info = 310 int_err(1) = 5 int_err(2) = 4 @@ -370,7 +358,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_dspalloc.f90 b/src/tools/psb_dspalloc.f90 index 518d9b4c1..9740c9b9c 100644 --- a/src/tools/psb_dspalloc.f90 +++ b/src/tools/psb_dspalloc.f90 @@ -36,7 +36,7 @@ ! Parameters: ! a - type(). The sparse matrix to be allocated. ! desc_a - type(). The communication descriptor to be updated. -! info - integer. Eventually returns an error code. +! info - integer. Possibly returns an error code. ! nnz - integer(optional). The number of nonzeroes in the matrix. ! subroutine psb_dspalloc(a, desc_a, info, nnz) @@ -46,6 +46,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -56,31 +57,26 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) !locals integer :: ictxt, dectype - integer :: nprow,npcol,myrow,mycol,loc_row,& + integer :: np,npcol,me,mycol,loc_row,& & length_ia1,length_ia2,err,nprocs, err_act,m,n integer :: int_err(5),temp(1) real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dspalloc' ictxt = desc_a%matrix_data(psb_ctxt_) dectype = desc_a%matrix_data(psb_dec_type_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) -! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ! @@ -96,29 +92,29 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) !...allocate matrix data... if (present(nnz))then - if (nnz.lt.0) then - info=45 - int_err(1)=7 - int_err(2)=nnz - call psb_errpush(info,name,int_err) - goto 9999 - endif - length_ia1=nnz - length_ia2=nnz + if (nnz < 0) then + info=45 + int_err(1)=7 + int_err(2)=nnz + call psb_errpush(info,name,int_err) + goto 9999 + endif + length_ia1=nnz + length_ia2=nnz else - length_ia1=max(1,4*loc_row) - length_ia2=max(1,4*loc_row) + length_ia1=max(1,4*loc_row) + length_ia2=max(1,4*loc_row) endif if (debug) write(*,*) 'allocating size:',length_ia1 !....allocate aspk, ia1, ia2..... call psb_sp_all(loc_row,loc_row,a,length_ia1,info) - if(info.ne.0) then - info=4010 - ch_err='sp_all' - call psb_errpush(info,name,int_err) - goto 9999 + if(info /= 0) then + info=4010 + ch_err='sp_all' + call psb_errpush(info,name,int_err) + goto 9999 end if ! set permutation matrices @@ -135,17 +131,17 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) &desc_a%matrix_data(psb_dec_type_),psb_desc_bld_ return - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return + + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/src/tools/psb_dspasb.f90 b/src/tools/psb_dspasb.f90 index 7f08d4cf6..2d1dc3ac9 100644 --- a/src/tools/psb_dspasb.f90 +++ b/src/tools/psb_dspasb.f90 @@ -51,6 +51,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) use psi_mod use psb_error_mod use psb_string_mod + use psb_penv_mod implicit none @@ -65,7 +66,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) type(psb_dspmat_type) :: atemp real(kind(1.d0)) :: real_err(5) integer :: ia1_size,ia2_size,aspk_size,m,i,err,& - & nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act + & np,npcol,me,mycol ,size_req,n_col,iout, err_act integer :: dscstate, spstate, nr,k,j integer :: upd_, dupl_ integer :: ictxt,temp(2),isize(2),n_row @@ -83,16 +84,11 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) n_col = desc_a%matrix_data(psb_n_col_) ! check on BLACS grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 endif if (.not.psb_is_asb_dec(dscstate)) then @@ -154,7 +150,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) endif if (debugwrt) then - iout = 30+myrow + iout = 30+me open(iout) call psb_csprt(iout,atemp,head='Input mat') close(iout) @@ -164,7 +160,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) ! result is put in A call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_) - IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA + IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA if (info /= no_err) then info=4010 ch_err='psb_csdp' @@ -173,7 +169,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) endif if (debugwrt) then - iout = 60+myrow + iout = 60+me open(iout) call psb_csprt(iout,a,head='Output mat') close(iout) @@ -233,7 +229,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_dspcnv.f90 b/src/tools/psb_dspcnv.f90 index 81bb0764f..c5e722de8 100644 --- a/src/tools/psb_dspcnv.f90 +++ b/src/tools/psb_dspcnv.f90 @@ -46,49 +46,50 @@ subroutine psb_dspcnv(a,b,desc_a,info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none interface dcsdp - subroutine dcsdp(check,trans,m,n,unitd,d,& - & fida,descra,a,ia1,ia2,infoa,& - & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& - & work,lwork,ierror) - integer, intent(in) :: lh, lwork, lh1, lh2, m, n - integer, intent(out) :: ierror - character, intent(in) :: check, trans, unitd - real(kind(1.d0)), intent(in) :: d(*), a(*) - real(kind(1.d0)), intent(out) :: h(*) - real(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) - character, intent(in) :: fida*5, descra*11 - character, intent(out) :: fidh*5, descrh*11 - end subroutine dcsdp + subroutine dcsdp(check,trans,m,n,unitd,d,& + & fida,descra,a,ia1,ia2,infoa,& + & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& + & work,lwork,ierror) + integer, intent(in) :: lh, lwork, lh1, lh2, m, n + integer, intent(out) :: ierror + character, intent(in) :: check, trans, unitd + real(kind(1.d0)), intent(in) :: d(*), a(*) + real(kind(1.d0)), intent(out) :: h(*) + real(kind(1.d0)), intent(inout) :: work(*) + integer, intent(in) :: ia1(*), ia2(*), infoa(*) + integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) + character, intent(in) :: fida*5, descra*11 + character, intent(out) :: fidh*5, descrh*11 + end subroutine dcsdp end interface interface dcsrp - subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsrp + subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& + & infoa,p,work,lwork,ierror) + integer, intent(in) :: m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + real(kind(1.d0)), intent(inout) :: work(*) + integer, intent(in) :: p(*) + integer, intent(inout) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine dcsrp end interface interface dcsprt - subroutine dcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) - integer, intent(in) :: iout,m, n - integer, intent(out) :: ierror - real(kind(1.d0)), intent(in) :: a(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsprt + subroutine dcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) + integer, intent(in) :: iout,m, n + integer, intent(out) :: ierror + real(kind(1.d0)), intent(in) :: a(*) + integer, intent(in) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine dcsprt end interface !...parameters.... @@ -103,7 +104,7 @@ subroutine psb_dspcnv(a,b,desc_a,info) integer,pointer :: i_temp(:) real(kind(1.d0)),pointer :: work_dcsdp(:) integer :: ia1_size,ia2_size,aspk_size,err_act& - & ,i,err,nprow,npcol,myrow,mycol,n_col,l_dcsdp, iout, nrow + & ,i,err,np,npcol,me,mycol,n_col,l_dcsdp, iout, nrow integer :: lwork_dcsdp,dectype integer :: ictxt,temp(1),n_row character :: check*1, trans*1, unitd*1 @@ -113,7 +114,7 @@ subroutine psb_dspcnv(a,b,desc_a,info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name = 'psb_dspcnv' call psb_erractionsave(err_act) @@ -127,23 +128,18 @@ subroutine psb_dspcnv(a,b,desc_a,info) n_col = desc_a%matrix_data(psb_n_col_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (.not.psb_is_ok_dec((dectype))) then - info = 600 - int_err(1) = dectype - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info = 600 + int_err(1) = dectype + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif if (debug) write (0, *) name,' begin matrix assembly...' @@ -166,11 +162,11 @@ subroutine psb_dspcnv(a,b,desc_a,info) b%k=n_col call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info) allocate(work_dcsdp(l_dcsdp),stat=info) - if (info.ne.0) then - info=2025 - int_err(1)=l_dcsdp - call psb_errpush(info, name, i_err=int_err) - goto 9999 + if (info /= 0) then + info=2025 + int_err(1)=l_dcsdp + call psb_errpush(info, name, i_err=int_err) + goto 9999 endif lwork_dcsdp=size(work_dcsdp) @@ -191,53 +187,53 @@ subroutine psb_dspcnv(a,b,desc_a,info) & size(b%aspk),size(b%ia1),size(b%ia2),& & work_dcsdp,size(work_dcsdp),info) - if(info.ne.no_err) then - info=4010 - ch_err='dcsdp' - call psb_errpush(info, name, a_err=ch_err) - goto 9999 + if(info /= no_err) then + info=4010 + ch_err='dcsdp' + call psb_errpush(info, name, a_err=ch_err) + goto 9999 end if ! ! hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!! ! should work (crossed fingers :-) - if (a%pr(1).ne.0) then - if (b%pr(1).ne.0) then - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = b%pr(a%pr(i)) - enddo - deallocate(b%pr) - b%pr => i_temp - else - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = a%pr(i) - enddo - deallocate(b%pr) - b%pr => i_temp - endif + if (a%pr(1) /= 0) then + if (b%pr(1) /= 0) then + allocate(i_temp(n_col)) + do i=1, n_col + i_temp(i) = b%pr(a%pr(i)) + enddo + deallocate(b%pr) + b%pr => i_temp + else + allocate(i_temp(n_col)) + do i=1, n_col + i_temp(i) = a%pr(i) + enddo + deallocate(b%pr) + b%pr => i_temp + endif endif - if (a%pl(1).ne.0) then - if (b%pr(1).ne.0) then - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(b%pl(i)) - enddo - deallocate(b%pl) - b%pl => i_temp - else - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(i) - enddo - deallocate(b%pl) - b%pl => i_temp - endif + if (a%pl(1) /= 0) then + if (b%pr(1) /= 0) then + allocate(i_temp(n_row)) + do i=1, n_row + i_temp(i) = a%pl(b%pl(i)) + enddo + deallocate(b%pl) + b%pl => i_temp + else + allocate(i_temp(n_row)) + do i=1, n_row + i_temp(i) = a%pl(i) + enddo + deallocate(b%pl) + b%pl => i_temp + endif endif - if (debug) write (0, *) myrow,name,' from dcsdp ',& + if (debug) write (0, *) me,name,' from dcsdp ',& &b%fida,' pl ', b%pl(:),'pr',b%pr(:) call psb_erractionrestore(err_act) @@ -245,9 +241,9 @@ subroutine psb_dspcnv(a,b,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_dspfree.f90 b/src/tools/psb_dspfree.f90 index 3d0bee20f..66b167c47 100644 --- a/src/tools/psb_dspfree.f90 +++ b/src/tools/psb_dspfree.f90 @@ -58,7 +58,7 @@ subroutine psb_dspfree(a, desc_a,info) integer :: ictxt,nprow,npcol,me,mypcol,err, err_act character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name = 'psb_dspfree' call psb_erractionsave(err_act) @@ -75,7 +75,7 @@ subroutine psb_dspfree(a, desc_a,info) call psb_sp_free(a,info) - if(info.ne.0) then + if(info /= 0) then info=2045 call psb_errpush(info,name) goto 9999 @@ -86,7 +86,7 @@ subroutine psb_dspfree(a, desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_dsphalo.f90 b/src/tools/psb_dsphalo.f90 index 79f8a4611..303124ca3 100644 --- a/src/tools/psb_dsphalo.f90 +++ b/src/tools/psb_dsphalo.f90 @@ -53,6 +53,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) use psb_realloc_mod use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob use psb_error_mod + use psb_penv_mod Implicit None @@ -64,7 +65,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) logical, optional, intent(in) :: rwcnv,clcnv character(len=5), optional :: outfmt ! ...local scalars.... - Integer :: nprow,npcol,me,mycol,counter,proc,n,i,& + Integer :: np,me,counter,proc,n,i,& & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& & n_elem, m, j, ipx,mat_recv, iszs, iszr,& & idxs,idxr, nrv, nsd,nz @@ -78,7 +79,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7,t8,t9 character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_dsphalo' call psb_erractionsave(err_act) @@ -102,16 +103,16 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) endif ictxt=desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + Call psb_info(ictxt, me, np) t1 = mpi_wtime() - Allocate(sdid(nprow,3),rvid(nprow,3),brvindx(nprow+1),& - & rvsz(nprow),sdsz(nprow),bsdindx(nprow+1),stat=info) + Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1),stat=info) if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if If (debug) Write(0,*)'dsphalo',me @@ -142,10 +143,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) idx = desc_a%halo_index(counter+psb_elem_send_+j) call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) if (info /= 0) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if tot_elem = tot_elem+n_elem @@ -156,14 +157,14 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) counter = counter+n_el_send+3 Enddo - call blacs_get(ictxt,10,icomm) - + call psb_get_mpicomm(ictxt,icomm) + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) if (info /= 0) then - info=4010 - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if idxs = 0 @@ -187,10 +188,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) call psb_sp_reall(blk,max(iszr,1),info) if(debug) write(0,*)me,'SPHALO Sizes:',size(blk%ia1),size(blk%ia2) if (info /= 0) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if mat_recv = iszr iszs=sum(sdsz) @@ -218,18 +219,18 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) idx = desc_a%halo_index(counter+psb_elem_send_+j) call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) if (info /= 0) then - info=4010 - ch_err='spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if !!$ write(0,*) me,'Getting row ',idx,n_elem call psb_spgtblk(idx,a,tmp,info,append=.true.) if (info /= 0) then - info=4010 - ch_err='psb_spgtblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_spgtblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if tot_elem=tot_elem+n_elem Enddo @@ -245,10 +246,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) if (rwcnv_) call psb_loc_to_glob(tmp%ia1(1:nz),desc_a,info,iact='I') if (clcnv_) call psb_loc_to_glob(tmp%ia2(1:nz),desc_a,info,iact='I') if (info /= 0) then - info=4010 - ch_err='psb_loc_to_glob' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if !!$ call csprt(30+me,tmp,head='% SPHALO border SEND .') !!$ close(30+me) @@ -261,10 +262,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) call mpi_alltoallv(tmp%ia2,sdsz,bsdindx,mpi_integer,& & blk%ia2,rvsz,brvindx,mpi_integer,icomm,info) if (info /= 0) then - info=4010 - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if t3 = mpi_wtime() @@ -276,12 +277,12 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) if (rwcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I') if (clcnv_) call psb_glob_to_loc(blk%ia2(1:iszr),desc_a,info,iact='I') if (info /= 0) then - info=4010 - ch_err='psbglob_to_loc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - + l1 = 0 Do i=1,iszr !!$ write(0,*) work5(i),work6(i) @@ -313,12 +314,12 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) case ('CSR') call psb_ipcoo2csr(blk,info,rwshr=.true.) if (info /= 0) then - info=4010 - ch_err='psb_ipcoo2csr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_ipcoo2csr' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - case('COO') + case('COO') ! Do nothing! case default write(0,*) 'Error in DSPHALO : invalid outfmt "',outfmt_,'"' @@ -335,20 +336,20 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) call psb_sp_free(tmp,info) if (info /= 0) then - info=4010 - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_dspins.f90 b/src/tools/psb_dspins.f90 index 30486a909..0e0de4cba 100644 --- a/src/tools/psb_dspins.f90 +++ b/src/tools/psb_dspins.f90 @@ -51,6 +51,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -66,19 +67,19 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) & first_loc_row,nrow,j, err,locix,locjx,err_act,& & dectype,mglob, nnza,m,n, pnt_halo,ncol, nh, ip, spstate integer,pointer :: tia1(:),tia2(:), temp(:) - integer :: nprow,npcol, myrow ,mycol, iflag, isize, irlc + integer :: np,npcol, me ,mycol, iflag, isize, irlc logical, parameter :: debug=.false. integer, parameter :: relocsz=200 logical :: rebuild_ interface psb_cdins - subroutine psb_cdins(nz,ia,ja,desc_a,info) - use psb_descriptor_type - implicit none - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(in) :: nz,ia(:),ja(:) - integer, intent(out) :: info - end subroutine psb_cdins + subroutine psb_cdins(nz,ia,ja,desc_a,info) + use psb_descriptor_type + implicit none + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(in) :: nz,ia(:),ja(:) + integer, intent(out) :: info + end subroutine psb_cdins end interface character(len=20) :: name, ch_err @@ -91,39 +92,35 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) ictxt = desc_a%matrix_data(psb_ctxt_) dectype = desc_a%matrix_data(psb_dec_type_) mglob = desc_a%matrix_data(psb_m_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (npcol.ne.1) then - info = 2030 - call psb_errpush(info,name) - goto 9999 - endif + + call psb_info(ictxt, me, np) + if (.not.psb_is_ok_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif if (nz <= 0) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (size(ia) < nz) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (size(ja) < nz) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (size(val) < nz) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (present(rebuild)) then @@ -134,44 +131,44 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) spstate = a%infoa(psb_state_) if (psb_is_bld_dec(dectype)) then - call psb_cdins(nz,ia,ja,desc_a,info) - if (info /= 0) then - info=4010 - ch_err='psb_cdins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - nrow = desc_a%matrix_data(psb_n_row_) - ncol = desc_a%matrix_data(psb_n_col_) + call psb_cdins(nz,ia,ja,desc_a,info) + if (info /= 0) then + info=4010 + ch_err='psb_cdins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + nrow = desc_a%matrix_data(psb_n_row_) + ncol = desc_a%matrix_data(psb_n_col_) - if (spstate == psb_spmat_bld_) then - call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc) - if (info /= 0) then - info=4010 - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - info = 1123 - call psb_errpush(info,name) - goto 9999 - end if - else if (psb_is_asb_dec(dectype)) then - nrow = desc_a%matrix_data(psb_n_row_) - ncol = desc_a%matrix_data(psb_n_col_) - call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& - & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) - if (info /= 0) then + if (spstate == psb_spmat_bld_) then + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc) + if (info /= 0) then info=4010 ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + else + info = 1123 + call psb_errpush(info,name) + goto 9999 + end if + else if (psb_is_asb_dec(dectype)) then + nrow = desc_a%matrix_data(psb_n_row_) + ncol = desc_a%matrix_data(psb_n_col_) + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& + & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if else - info = 1122 - call psb_errpush(info,name) - goto 9999 + info = 1122 + call psb_errpush(info,name) + goto 9999 end if call psb_erractionrestore(err_act) @@ -179,9 +176,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_dsprn.f90 b/src/tools/psb_dsprn.f90 index da7226dfe..945b4a040 100644 --- a/src/tools/psb_dsprn.f90 +++ b/src/tools/psb_dsprn.f90 @@ -45,6 +45,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod Implicit None !....Parameters... @@ -56,7 +57,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) !locals Integer :: ictxt - Integer :: nprow,npcol,myrow,mycol,err,err_act + Integer :: np,npcol,me,mycol,err,err_act logical, parameter :: debug=.false. integer :: int_err(5) real(kind(1.d0)) :: real_err(5) @@ -70,18 +71,10 @@ Subroutine psb_dsprn(a, desc_a,info,clear) call psb_erractionsave(err_act) ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) + call psb_info(ictxt, me, np) if (debug) & - &write(*,*) 'starting spalloc ',ictxt,nprow,npcol,myrow + &write(*,*) 'starting spalloc ',ictxt,np,me - ! ....verify blacs grid correctness.. - if (npcol.ne.1) then - info = 2030 - call psb_errpush(info,name) - goto 9999 - endif - - if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then ! Should do nothing, we are called redundantly return @@ -106,7 +99,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_glob_to_loc.f90 b/src/tools/psb_glob_to_loc.f90 index b511bd200..0239b8c10 100644 --- a/src/tools/psb_glob_to_loc.f90 +++ b/src/tools/psb_glob_to_loc.f90 @@ -45,6 +45,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_string_mod implicit none !...parameters.... @@ -61,60 +62,61 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) integer, parameter :: zero=0 character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name = 'glob_to_loc' call psb_erractionsave(err_act) if (present(iact)) then - act=iact + act=iact else - act='A' - endif + act='A' + endif + act = toupper(act) int_err=0 real_val = 0.d0 n=size(x) do i=1,n - if ((x(i).gt.desc_a%matrix_data(psb_m_)).or.& - & (x(i).le.zero)) then - if(act.eq.'I') then - y(i)=-3*desc_a%matrix_data(psb_m_) - else - info=140 - int_err(1)=x(i) - int_err(2)=desc_a%matrix_data(psb_m_) - exit - end if - else - tmp=desc_a%glob_to_loc(x(i)) - if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_n_col_))) then - y(i)=tmp - else if (tmp.le.zero) then - info = 150 - int_err(1)=tmp - exit - else if (tmp.gt.desc_a%matrix_data(psb_n_col_)) then - info = 140 - int_err(1)=tmp - int_err(2)=desc_a%matrix_data(psb_n_col_) - exit - end if - end if + if ((x(i).gt.desc_a%matrix_data(psb_m_)).or.& + & (x(i).le.zero)) then + if (act == 'I') then + y(i)=-3*desc_a%matrix_data(psb_m_) + else + info=140 + int_err(1)=x(i) + int_err(2)=desc_a%matrix_data(psb_m_) + exit + end if + else + tmp=desc_a%glob_to_loc(x(i)) + if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_n_col_))) then + y(i)=tmp + else if (tmp.le.zero) then + info = 150 + int_err(1)=tmp + exit + else if (tmp.gt.desc_a%matrix_data(psb_n_col_)) then + info = 140 + int_err(1)=tmp + int_err(2)=desc_a%matrix_data(psb_n_col_) + exit + end if + end if enddo - - if (info.ne.0) then - select case(act) - case('E','I') - call psb_erractionrestore(err_act) - return - case('W') - write(0,'("Error ",i5," in subroutine glob_to_loc")') info - case('A') - call psb_errpush(info,name) - goto 9999 - end select + + if (info /= 0) then + select case(act) + case('E','I') + call psb_erractionrestore(err_act) + return + case('W') + write(0,'("Error ",i5," in subroutine glob_to_loc")') info + case('A') + call psb_errpush(info,name) + goto 9999 + end select endif call psb_erractionrestore(err_act) @@ -123,14 +125,14 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error() + call psb_error() end if return - - + + end subroutine psb_glob_to_loc2 @@ -178,6 +180,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_string_mod implicit none !...parameters.... @@ -194,58 +197,60 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) integer, parameter :: zero=0 character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name = 'glob_to_loc' call psb_erractionsave(err_act) - + if (present(iact)) then - act=iact + act=iact else - act='A' - endif + act='A' + endif + + act = toupper(act) real_val = 0.d0 n=size(x) do i=1,n - if ((x(i).gt.desc_a%matrix_data(psb_m_)).or.& - & (x(i).le.zero)) then - if(act.eq.'I') then - x(i)=-3*desc_a%matrix_data(psb_m_) - else - info=140 - int_err(1)=x(i) - int_err(2)=desc_a%matrix_data(psb_m_) - exit - end if - else - tmp=desc_a%glob_to_loc(x(i)) - if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_n_col_))) then - x(i)=tmp - else if (tmp.le.zero) then - info = 150 - int_err(1)=tmp - exit - else if (tmp.ge.desc_a%matrix_data(psb_n_col_)) then - info = 140 - int_err(1)=tmp - int_err(2)=desc_a%matrix_data(psb_n_col_) - exit - end if - end if + if ((x(i).gt.desc_a%matrix_data(psb_m_)).or.& + & (x(i).le.zero)) then + if(act == 'I') then + x(i)=-3*desc_a%matrix_data(psb_m_) + else + info=140 + int_err(1)=x(i) + int_err(2)=desc_a%matrix_data(psb_m_) + exit + end if + else + tmp=desc_a%glob_to_loc(x(i)) + if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_n_col_))) then + x(i)=tmp + else if (tmp.le.zero) then + info = 150 + int_err(1)=tmp + exit + else if (tmp.ge.desc_a%matrix_data(psb_n_col_)) then + info = 140 + int_err(1)=tmp + int_err(2)=desc_a%matrix_data(psb_n_col_) + exit + end if + end if enddo - - if (info.ne.0) then - select case(act) - case('E','I') - call psb_erractionrestore(err_act) - return - case('W') - write(0,'("Error ",i5," in subroutine glob_to_loc")') info - case('A') - call psb_errpush(info,name) - goto 9999 - end select + + if (info /= 0) then + select case(act) + case('E','I') + call psb_erractionrestore(err_act) + return + case('W') + write(0,'("Error ",i5," in subroutine glob_to_loc")') info + case('A') + call psb_errpush(info,name) + goto 9999 + end select endif call psb_erractionrestore(err_act) @@ -254,12 +259,12 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error() + call psb_error() end if return - + end subroutine psb_glob_to_loc diff --git a/src/tools/psb_ialloc.f90 b/src/tools/psb_ialloc.f90 index ab01e04ce..fe6c576c7 100644 --- a/src/tools/psb_ialloc.f90 +++ b/src/tools/psb_ialloc.f90 @@ -43,6 +43,8 @@ subroutine psb_ialloc(x, desc_a, info, n) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod + implicit none !....parameters... @@ -53,30 +55,24 @@ subroutine psb_ialloc(x, desc_a, info, n) !locals - integer :: nprow,npcol,myrow,mypcol,err,n_col,n_row,i,j,jj,err_act + integer :: np,npcol,me,mycol,err,n_col,n_row,i,j,jj,err_act integer :: ictxt,dectype,n_ integer :: int_err(5),temp(1),exch(3) real(kind(1.d0)) :: real_err(5) character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_ialloc' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mypcol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif dectype=desc_a%matrix_data(psb_dec_type_) @@ -93,12 +89,12 @@ subroutine psb_ialloc(x, desc_a, info, n) n_ = 1 endif !global check on n parameters - if (myrow.eq.psb_root_) then + if (me == psb_root_) then exch(1)=n_ - call igebs2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione) + call psb_bcast(ictxt,exch(1),root=psb_root_) else - call igebr2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0) - if (exch(1).ne.n_) then + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then info=550 int_err(1)=1 call psb_errpush(info,name,int_err) @@ -110,7 +106,7 @@ subroutine psb_ialloc(x, desc_a, info, n) if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then n_col = max(1,desc_a%matrix_data(psb_n_col_)) allocate(x(n_col,n_),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) @@ -124,7 +120,7 @@ subroutine psb_ialloc(x, desc_a, info, n) else if (psb_is_bld_dec(dectype)) then n_row = max(1,desc_a%matrix_data(psb_n_row_)) allocate(x(n_row,n_),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) @@ -142,7 +138,7 @@ subroutine psb_ialloc(x, desc_a, info, n) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -196,6 +192,7 @@ subroutine psb_iallocv(x, desc_a, info,n) use psb_const_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none @@ -206,31 +203,26 @@ subroutine psb_iallocv(x, desc_a, info,n) integer, optional, intent(in) :: n !locals - integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act + integer :: np,npcol,me,mycol,err,n_col,n_row,dectype,i,err_act integer :: ictxt, n_ integer :: int_err(5),temp(1),exch real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_iallocv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif dectype=desc_a%matrix_data(psb_dec_type_) @@ -273,7 +265,7 @@ subroutine psb_iallocv(x, desc_a, info,n) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_iasb.f90 b/src/tools/psb_iasb.f90 index 8e7876d98..d58e1569d 100644 --- a/src/tools/psb_iasb.f90 +++ b/src/tools/psb_iasb.f90 @@ -44,6 +44,7 @@ subroutine psb_iasb(x, desc_a, info) use psb_comm_mod use psb_error_mod use psb_realloc_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -51,13 +52,13 @@ subroutine psb_iasb(x, desc_a, info) integer, intent(out) :: info ! local variables - integer :: ictxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol,err_act + integer :: ictxt,np,npcol,me,mypcol,temp,lwork,nrow,ncol,err_act integer :: int_err(5), i1sz, i2sz, dectype, i real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_iasb' call psb_erractionsave(err_act) @@ -71,15 +72,21 @@ subroutine psb_iasb(x, desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) dectype=desc_a%matrix_data(psb_dec_type_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + + + if (debug) write(*,*) 'asb start: ',np,npcol,me,& + &desc_a%matrix_data(psb_dec_type_) + ! ....verify blacs grid correctness.. + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) + else if (.not.psb_is_asb_dec(dectype)) then + if (debug) write(*,*) 'asb error ',& + &dectype + info = 3110 + call psb_errpush(info,name) goto 9999 endif @@ -92,7 +99,7 @@ subroutine psb_iasb(x, desc_a, info) if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol if (i1sz.lt.ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info.ne.0) then + if (info /= 0) then info=2025 int_err(1)=ncol call psb_errpush(info,name,int_err) @@ -108,7 +115,7 @@ subroutine psb_iasb(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -162,6 +169,7 @@ subroutine psb_iasbv(x, desc_a, info) use psb_comm_mod use psb_error_mod use psb_realloc_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -169,7 +177,7 @@ subroutine psb_iasbv(x, desc_a, info) integer, intent(out) :: info ! local variables - integer :: ictxt,nprow,npcol,me,mypcol,temp,lwork, err_act + integer :: ictxt,np,npcol,me,mypcol,temp,lwork, err_act integer :: int_err(5), i1sz,nrow,ncol, dectype, i real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. @@ -184,16 +192,17 @@ subroutine psb_iasbv(x, desc_a, info) ictxt=desc_a%matrix_data(psb_ctxt_) dectype=desc_a%matrix_data(psb_dec_type_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_dec(dectype)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 endif nrow=desc_a%matrix_data(psb_n_row_) @@ -203,7 +212,7 @@ subroutine psb_iasbv(x, desc_a, info) if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol if (i1sz.lt.ncol) then call psb_realloc(ncol,x,info) - if (info.ne.0) then + if (info /= 0) then info=2025 int_err(1)=ncol call psb_errpush(info,name,int_err) @@ -219,7 +228,7 @@ subroutine psb_iasbv(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_ifree.f90 b/src/tools/psb_ifree.f90 index 3c5f923e7..6ad4ced42 100644 --- a/src/tools/psb_ifree.f90 +++ b/src/tools/psb_ifree.f90 @@ -42,6 +42,7 @@ subroutine psb_ifree(x, desc_a, info) use psb_const_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -51,12 +52,11 @@ subroutine psb_ifree(x, desc_a, info) !...locals.... integer :: int_err(5) - integer :: temp(1) - real(kind(1.d0)) :: real_err(5) - integer :: ictxt,nprow,npcol,me,mypcol,err_act - character(len=20) :: name, ch_err + integer :: ictxt,np,npcol,me,mypcol,err, err_act + character(len=20) :: name - if(psb_get_errstatus().ne.0) return + + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_ifree' @@ -68,17 +68,13 @@ subroutine psb_ifree(x, desc_a, info) end if ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (.not.associated(x)) then @@ -102,7 +98,7 @@ subroutine psb_ifree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -154,6 +150,8 @@ subroutine psb_ifreev(x, desc_a,info) use psb_const_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod + implicit none !....parameters... integer, pointer :: x(:) @@ -161,12 +159,11 @@ subroutine psb_ifreev(x, desc_a,info) integer, intent(out) :: info !...locals.... integer :: int_err(5) - integer :: temp(1) - real(kind(1.d0)) :: real_err(5) - integer :: ictxt,nprow,npcol,me,mypcol,err_act - character(len=20) :: name, ch_err + integer :: ictxt,np,npcol,me,mypcol,err, err_act + character(len=20) :: name - if(psb_get_errstatus().ne.0) return + + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_ifreev' @@ -177,33 +174,27 @@ subroutine psb_ifreev(x, desc_a,info) call psb_errpush(info,name) return end if - ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (.not.associated(x)) then - info=290 - call psb_errpush(info,name,int_err) - goto 9999 + info=295 + call psb_errpush(info,name) + goto 9999 end if !deallocate x deallocate(x,stat=info) - if (info.ne.0) then - info=2045 - call psb_errpush(info,name,int_err) - goto 9999 + if (info /= no_err) then + info=4000 + call psb_errpush(info,name) else nullify(x) endif @@ -213,7 +204,7 @@ subroutine psb_ifreev(x, desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_iins.f90 b/src/tools/psb_iins.f90 index 6fc7889e6..fddde35d0 100644 --- a/src/tools/psb_iins.f90 +++ b/src/tools/psb_iins.f90 @@ -44,6 +44,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none ! m rows number of submatrix belonging to val to be inserted @@ -62,10 +63,10 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) !locals..... integer :: ictxt,i,loc_row,glob_row,row,k,& & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err - integer :: nprow,npcol, me ,mypcol,dupl_ + integer :: np,npcol, me ,mypcol,dupl_ character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dinsvv' @@ -83,21 +84,15 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif !... check parameters.... - if (m.lt.0) then + if (m < 0) then info = 10 int_err(1) = 1 int_err(2) = m @@ -108,7 +103,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) int_err(1) = desc_a%matrix_data(psb_dec_type_) call psb_errpush(info,name,int_err) goto 9999 - else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then + else if (size(x, dim=1) < desc_a%matrix_data(psb_n_row_)) then info = 310 int_err(1) = 5 int_err(2) = 4 @@ -174,7 +169,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) @@ -229,6 +224,7 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none ! m rows number of submatrix belonging to val to be inserted @@ -248,10 +244,10 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) !locals..... integer :: ictxt,i,loc_row,glob_row,row,k,j,n,& & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err - integer :: nprow,npcol, me ,mypcol,dupl_ + integer :: np,npcol, me ,mypcol,dupl_ character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dinsvv' @@ -269,21 +265,15 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif !... check parameters.... - if (m.lt.0) then + if (m < 0) then info = 10 int_err(1) = 1 int_err(2) = m @@ -294,7 +284,7 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) int_err(1) = desc_a%matrix_data(psb_dec_type_) call psb_errpush(info,name,int_err) goto 9999 - else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then + else if (size(x, dim=1) < desc_a%matrix_data(psb_n_row_)) then info = 310 int_err(1) = 5 int_err(2) = 4 @@ -366,7 +356,7 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_loc_to_glob.f90 b/src/tools/psb_loc_to_glob.f90 index 1dc597f7e..59e6c6444 100644 --- a/src/tools/psb_loc_to_glob.f90 +++ b/src/tools/psb_loc_to_glob.f90 @@ -45,6 +45,7 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_string_mod implicit none !...parameters.... @@ -62,51 +63,52 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) integer, parameter :: zero=0 character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_loc_to_glob2' call psb_erractionsave(err_act) if (present(iact)) then - act=iact + act=iact else - act='A' - endif - + act='A' + endif + act=toupper(act) + real_val = 0.d0 n=size(x) do i=1,n - if ((x(i).gt.desc_a%matrix_data(psb_n_col_)).or.& - & (x(i).le.zero)) then - info=140 + if ((x(i).gt.desc_a%matrix_data(psb_n_col_)).or.& + & (x(i).le.zero)) then + info=140 + int_err(1)=tmp + int_err(2)=desc_a%matrix_data(psb_n_col_) + exit + else + tmp=desc_a%loc_to_glob(x(i)) + if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_m_))) then + y(i)=tmp + else + info = 140 int_err(1)=tmp - int_err(2)=desc_a%matrix_data(psb_n_col_) + int_err(2)=desc_a%matrix_data(psb_n_col_) exit - else - tmp=desc_a%loc_to_glob(x(i)) - if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_m_))) then - y(i)=tmp - else - info = 140 - int_err(1)=tmp - int_err(2)=desc_a%matrix_data(psb_n_col_) - exit - end if - end if + end if + end if enddo - - if (info.ne.0) then - select case(act) - case('E') - call psb_erractionrestore(err_act) - return - case('W') - write(0,'("Error ",i5," in subroutine glob_to_loc")') info - case('A') - call psb_errpush(info,name) - goto 9999 - end select + + if (info /= 0) then + select case(act) + case('E') + call psb_erractionrestore(err_act) + return + case('W') + write(0,'("Error ",i5," in subroutine glob_to_loc")') info + case('A') + call psb_errpush(info,name) + goto 9999 + end select endif call psb_erractionrestore(err_act) @@ -115,10 +117,10 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error() + call psb_error() end if return @@ -169,6 +171,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_string_mod implicit none !...parameters.... @@ -185,16 +188,17 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) integer, parameter :: zero=0 character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_loc_to_glob' call psb_erractionsave(err_act) if (present(iact)) then - act=iact + act=iact else - act='A' - endif + act='A' + endif + act = toupper(act) real_val = 0.d0 @@ -217,17 +221,17 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) end if enddo - if (info.ne.0) then - select case(act) - case('E') - call psb_erractionrestore(err_act) - return - case('W') - write(0,'("Error ",i5," in subroutine glob_to_loc")') info - case('A') - call psb_errpush(info,name) - goto 9999 - end select + if (info /= 0) then + select case(act) + case('E') + call psb_erractionrestore(err_act) + return + case('W') + write(0,'("Error ",i5," in subroutine glob_to_loc")') info + case('A') + call psb_errpush(info,name) + goto 9999 + end select endif call psb_erractionrestore(err_act) @@ -236,10 +240,10 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error() + call psb_error() end if return diff --git a/src/tools/psb_zallc.f90 b/src/tools/psb_zallc.f90 index f0a7141e1..5951204ab 100644 --- a/src/tools/psb_zallc.f90 +++ b/src/tools/psb_zallc.f90 @@ -44,6 +44,7 @@ subroutine psb_zalloc(x, desc_a, info, n) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none @@ -54,14 +55,14 @@ subroutine psb_zalloc(x, desc_a, info, n) integer, optional, intent(in) :: n !locals - integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,i,j,jj,err_act + integer :: np,npcol,me,mycol,err,n_col,n_row,i,j,jj,err_act integer :: ictxt,dectype,n_ integer :: int_err(5),temp(1),exch(3) real(kind(1.d0)) :: real_err(5) character(len=20) :: name, ch_err name='psb_zallc' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 err=0 int_err(1)=0 @@ -69,17 +70,11 @@ subroutine psb_zalloc(x, desc_a, info, n) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif dectype=desc_a%matrix_data(psb_dec_type_) @@ -96,12 +91,12 @@ subroutine psb_zalloc(x, desc_a, info, n) n_ = 1 endif !global check on n parameters - if (myrow.eq.psb_root_) then + if (me == psb_root_) then exch(1)=n_ - call igebs2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione) + call psb_bcast(ictxt,exch(1),root=psb_root_) else - call igebr2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0) - if (exch(1).ne.n_) then + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then info=550 int_err(1)=1 call psb_errpush(info,name,int_err) @@ -113,7 +108,7 @@ subroutine psb_zalloc(x, desc_a, info, n) if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then n_col = max(1,desc_a%matrix_data(psb_n_col_)) allocate(x(n_col,n_),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) @@ -127,7 +122,7 @@ subroutine psb_zalloc(x, desc_a, info, n) else if (psb_is_bld_dec(dectype)) then n_row = max(1,desc_a%matrix_data(psb_n_row_)) allocate(x(n_row,n_),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) @@ -145,7 +140,7 @@ subroutine psb_zalloc(x, desc_a, info, n) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if @@ -197,6 +192,7 @@ subroutine psb_zallocv(x, desc_a,info,n) use psb_const_mod use psb_realloc_mod use psb_error_mod + use psb_penv_mod implicit none @@ -207,31 +203,26 @@ subroutine psb_zallocv(x, desc_a,info,n) integer, optional, intent(in) :: n !locals - integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act + integer :: np,npcol,me,mycol,err,n_col,n_row,dectype,i,err_act integer :: ictxt, n_ integer :: int_err(5),temp(1),exch real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_zallcv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif dectype=desc_a%matrix_data(psb_dec_type_) @@ -250,7 +241,7 @@ subroutine psb_zallocv(x, desc_a,info,n) if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then n_col = max(1,desc_a%matrix_data(psb_n_col_)) call psb_realloc(n_col,x,info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) @@ -263,7 +254,7 @@ subroutine psb_zallocv(x, desc_a,info,n) else if (psb_is_bld_dec(dectype)) then n_row = max(1,desc_a%matrix_data(psb_n_row_)) call psb_realloc(n_row,x,info) - if (info.ne.0) then + if (info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) @@ -279,7 +270,7 @@ subroutine psb_zallocv(x, desc_a,info,n) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_zasb.f90 b/src/tools/psb_zasb.f90 index 99de00468..d1a58518d 100644 --- a/src/tools/psb_zasb.f90 +++ b/src/tools/psb_zasb.f90 @@ -44,6 +44,7 @@ subroutine psb_zasb(x, desc_a, info) use psb_comm_mod use psb_error_mod use psb_realloc_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -51,40 +52,36 @@ subroutine psb_zasb(x, desc_a, info) integer, intent(out) :: info ! local variables - integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act + integer :: err, ictxt,np,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act integer :: int_err(5), i1sz, i2sz, dectype, i,j double precision :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_zasb' call psb_erractionsave(err_act) - ictxt=desc_a%matrix_data(psb_ctxt_) - dectype=desc_a%matrix_data(psb_dec_type_) - - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if ((.not.associated(desc_a%matrix_data))) then info=3110 call psb_errpush(info,name) goto 9999 endif - if (debug) write(*,*) 'asb start: ',nprow,npcol,me,& + ictxt=desc_a%matrix_data(psb_ctxt_) + dectype=desc_a%matrix_data(psb_dec_type_) + + call psb_info(ictxt, me, np) + + + if (debug) write(*,*) 'asb start: ',np,npcol,me,& &desc_a%matrix_data(psb_dec_type_) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 else if (.not.psb_is_asb_dec(dectype)) then if (debug) write(*,*) 'asb error ',& &dectype @@ -102,7 +99,7 @@ subroutine psb_zasb(x, desc_a, info) if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol if (i1sz.lt.ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info.ne.0) then + if (info /= 0) then info=2025 int_err(1)=ncol call psb_errpush(info,name,i_err=int_err) @@ -113,25 +110,23 @@ subroutine psb_zasb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) if(info /= 0) then - info=4010 - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else - call psb_error(ictxt) + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return - + end subroutine psb_zasb @@ -179,6 +174,7 @@ subroutine psb_zasbv(x, desc_a, info) use psb_comm_mod use psb_error_mod use psb_realloc_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -186,7 +182,7 @@ subroutine psb_zasbv(x, desc_a, info) integer, intent(out) :: info ! local variables - integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork + integer :: err, ictxt,np,npcol,me,mypcol,temp,lwork integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act double precision :: real_err(5) @@ -196,26 +192,21 @@ subroutine psb_zasbv(x, desc_a, info) info = 0 int_err(1) = 0 name = 'psb_zasbv' - + ictxt=desc_a%matrix_data(psb_ctxt_) dectype=desc_a%matrix_data(psb_dec_type_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 else if (.not.psb_is_asb_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif nrow=desc_a%matrix_data(psb_n_row_) @@ -225,36 +216,34 @@ subroutine psb_zasbv(x, desc_a, info) if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol if (i1sz.lt.ncol) then call psb_realloc(ncol,x,info) - if (info.ne.0) then + if (info /= 0) then info=2025 int_err(1)=ncol call psb_errpush(info,name,i_err=int_err) goto 9999 endif - endif - + endif + ! ..update halo elements.. call psb_halo(x,desc_a,info) if(info /= 0) then - info=4010 - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else - call psb_error(ictxt) + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return - + end subroutine psb_zasbv diff --git a/src/tools/psb_zcdovr.f90 b/src/tools/psb_zcdovr.f90 index 7943c5a68..f5ef2c9ea 100644 --- a/src/tools/psb_zcdovr.f90 +++ b/src/tools/psb_zcdovr.f90 @@ -50,6 +50,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) Use psb_prec_type Use psb_prec_mod use psb_error_mod + use psb_penv_mod Implicit None ! .. Array Arguments .. @@ -91,7 +92,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! .. Local Scalars .. - Integer :: i, j, k, nprow,npcol, me, mycol,m,nnzero,& + Integer :: i, j, k, np,npcol, me, mycol,m,nnzero,& & ictxt, lovr, lelem,lworks,lworkr, n_col, int_err(5),& & n_row,index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Logical,Parameter :: debug=.false. @@ -103,7 +104,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ictxt=desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + Call psb_info(ictxt, me, np) If(debug) Write(0,*)'in psb_cdovr',novr @@ -136,7 +137,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) return endif - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm ) !!$ call MPI_Comm_rank(icomm,irank,ierr) !!$ idscb = mpe_log_get_event_number() !!$ idsce = mpe_log_get_event_number() @@ -148,7 +149,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) !!$ endif If(debug)then Write(0,*)'BEGIN cdovr',me,nhalo - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif t1 = mpi_wtime() @@ -211,7 +212,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) desc_ov%glob_to_loc(:) = desc_a%glob_to_loc(:) If(debug)then Write(0,*)'Start cdovrbld',me,lworks,lworkr - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif ! @@ -228,7 +229,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) desc_ov%matrix_data(psb_dec_type_) = psb_desc_asb_ If(debug)then Write(0,*)'Done cdovrbld',me,lworks,lworkr - call blacs_barrier(ictxt,'All') + call psb_barrier(ictxt) endif !!$ ierr = MPE_Log_event( idsce, 0, "st CDASB" ) diff --git a/src/tools/psb_zcdovrbld.f90 b/src/tools/psb_zcdovrbld.f90 index 7c9a7b8da..e9a873c72 100644 --- a/src/tools/psb_zcdovrbld.f90 +++ b/src/tools/psb_zcdovrbld.f90 @@ -55,6 +55,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& use psb_tools_mod, only : psb_cdprt use psb_error_mod use psb_const_mod + use psb_penv_mod Implicit None include 'mpif.h' @@ -73,7 +74,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& Integer, Pointer :: tmp_halo(:),tmp_ovr_idx(:) Integer :: counter,counter_h, counter_o, counter_e,j,idx,gidx,proc,n_elem_recv,& - & n_elem_send,tot_recv,tot_elem,n_col,m,ictxt,np,npcol,myrow,mycol,dl_lda,lwork,& + & n_elem_send,tot_recv,tot_elem,n_col,m,ictxt,np,npcol,me,mycol,dl_lda,lwork,& & counter_t,n_elem,i_ovr,jj,n,i,proc_id,isz, mglob, glx,n_row, & & idxr, idxs, lx, iszs, iszr, err_act @@ -94,8 +95,9 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& If(debug) Write(0,*)'cdovrbld begin' ictxt = desc_a%matrix_data(psb_ctxt_) -!!$ call blacs_barrier(ictxt,'All') - Call blacs_gridinfo(ictxt,np,npcol,myrow,mycol) + + Call psb_info(ictxt,me,np) + call psb_nullify_sp(blk) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) @@ -106,13 +108,13 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& tl = 0.0 tch = 0.0 t4 = 0.0 - call blacs_get(ictxt,10,icomm ) + call psb_get_mpicomm(ictxt,icomm ) mglob = desc_a%matrix_data(psb_m_) m = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_) n_col = desc_a%matrix_data(psb_n_col_) - if (debug) write(0,*) myrow,' On entry to CDOVRBLD n_col:',n_col + if (debug) write(0,*) me,' On entry to CDOVRBLD n_col:',n_col dl_lda=np*5 lwork=5*(5*np+2)*np+10 @@ -127,10 +129,10 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& call psb_sp_all(blk,max(lworks,lworkr),info) if (info /= 0) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if blk%fida='COO' @@ -153,12 +155,12 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& ! See comment in main loop below. call InitPairSearchTree(info) if (info /= 0) then - info=4010 - ch_err='InitPairSearhTree' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='InitPairSearhTree' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - if (debug) write(0,*) myrow,'Done InitPairSearchTree',info + if (debug) write(0,*) me,'Done InitPairSearchTree',info ! ! A picture is in order to understand what goes on here. @@ -182,438 +184,438 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& ! Do i_ovr=1,n_ovr - if (debug) write(0,*) myrow,'Running on overlap level ',i_ovr,' of ',n_ovr + if (debug) write(0,*) me,'Running on overlap level ',i_ovr,' of ',n_ovr !!$ t_halo_in(:) = -1 - ! - ! At this point, halo contains a valid halo corresponding to the - ! matrix enlarged with the elements in the frontier for I_OVR-1. - ! At the start, this is just the halo for A; the rows for indices in - ! the first halo will contain column indices defining the second halo - ! level and so on. - ! - bsdindx(:) = 0 - sdsz(:) = 0 - brvindx(:) = 0 - rvsz(:) = 0 - idxr = 0 - idxs = 0 - counter = 1 - counter_t = 1 + ! + ! At this point, halo contains a valid halo corresponding to the + ! matrix enlarged with the elements in the frontier for I_OVR-1. + ! At the start, this is just the halo for A; the rows for indices in + ! the first halo will contain column indices defining the second halo + ! level and so on. + ! + bsdindx(:) = 0 + sdsz(:) = 0 + brvindx(:) = 0 + rvsz(:) = 0 + idxr = 0 + idxs = 0 + counter = 1 + counter_t = 1 - t1 = mpi_wtime() - Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) - If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then - info=-1 - call psb_errpush(info,name) - goto 9999 - end If - tot_recv=tot_recv+n_elem_recv - if (debug) write(0,*) myrow,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv - ! - ! While running through the column indices exchanged with other procs - ! we have to keep track of which elements actually are overlap and halo - ! ones to record them in overlap_elem. We do this by maintaining - ! an AVL balanced search tree: at each point counter_e is the next - ! free index element. The search routine for gidx will return - ! glx if gidx was already assigned a local index (glx Size(halo)) then + info=-1 + call psb_errpush(info,name) + goto 9999 + end If + tot_recv=tot_recv+n_elem_recv + if (debug) write(0,*) me,' CDOVRBLD tot_recv:',proc,n_elem_recv,tot_recv + ! + ! While running through the column indices exchanged with other procs + ! we have to keep track of which elements actually are overlap and halo + ! ones to record them in overlap_elem. We do this by maintaining + ! an AVL balanced search tree: at each point counter_e is the next + ! free index element. The search routine for gidx will return + ! glx if gidx was already assigned a local index (glxSize(halo)) then - info=-2 - call psb_errpush(info,name) - goto 9999 - end If - idx = halo(counter+psb_elem_recv_+j) - idx = halo(counter+psb_elem_recv_+j) - If(idx > Size(desc_p%loc_to_glob)) then - info=-3 - call psb_errpush(info,name) - goto 9999 - endif + t3 = mpi_wtime() + ! + ! add recv elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_recv-1 + If((counter+psb_elem_recv_+j)>Size(halo)) then + info=-2 + call psb_errpush(info,name) + goto 9999 + end If + idx = halo(counter+psb_elem_recv_+j) + idx = halo(counter+psb_elem_recv_+j) + If(idx > Size(desc_p%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif - gidx = desc_p%loc_to_glob(idx) + gidx = desc_p%loc_to_glob(idx) - If((counter_o+2) > Size(tmp_ovr_idx)) Then - isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) - if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz - call psb_realloc(isz,tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + If((counter_o+2) > Size(tmp_ovr_idx)) Then + isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) + if (debug) write(0,*) me,'Realloc tmp_ovr',isz + call psb_realloc(isz,tmp_ovr_idx,info,pad=-1) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 - If((counter_h+2) > Size(tmp_halo)) Then - isz = max((3*Size(tmp_halo))/2,(counter_h+3)) - if (debug) write(0,*) myrow,'Realloc tmp_halo',isz - call psb_realloc(isz,tmp_halo,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + If((counter_h+2) > Size(tmp_halo)) Then + isz = max((3*Size(tmp_halo))/2,(counter_h+3)) + if (debug) write(0,*) me,'Realloc tmp_halo',isz + call psb_realloc(isz,tmp_halo,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - tmp_halo(counter_h)=proc - tmp_halo(counter_h+1)=1 - tmp_halo(counter_h+2)=idx - tmp_halo(counter_h+3)=-1 + tmp_halo(counter_h)=proc + tmp_halo(counter_h+1)=1 + tmp_halo(counter_h+2)=idx + tmp_halo(counter_h+3)=-1 - counter_h=counter_h+3 + counter_h=counter_h+3 - call SearchInsKeyVal(gidx,counter_e,glx,info) + call SearchInsKeyVal(gidx,counter_e,glx,info) !!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) myrow,'Realloc ovr_El',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + if (info>=0) then + If (glx < counter_e) Then + desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & + & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 + Else + If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then + isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) + if (debug) write(0,*) me,'Realloc ovr_El',isz + call psb_realloc(isz,desc_p%ovrlap_elem,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If !!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) myrow, 'Cdovrbld From SearchInsKeyVal: ',info - endif - Enddo - if (debug) write(0,*) myrow,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) - counter = counter+n_elem_recv + desc_p%ovrlap_elem(counter_e)=gidx + desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 + desc_p%ovrlap_elem(counter_e+2)=-1 + counter_e = counter_e + 2 + End If + else + write(0,*) me, 'Cdovrbld From SearchInsKeyVal: ',info + endif + Enddo + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + counter = counter+n_elem_recv - ! - ! add send elements in halo_index into ovrlap_index - ! - Do j=0,n_elem_send-1 + ! + ! add send elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_send-1 - idx = halo(counter+psb_elem_send_+j) - gidx = desc_p%loc_to_glob(idx) + idx = halo(counter+psb_elem_send_+j) + gidx = desc_p%loc_to_glob(idx) - If((counter_o+2) > Size(tmp_ovr_idx)) Then - isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) - if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz - call psb_realloc(isz,tmp_ovr_idx,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + If((counter_o+2) > Size(tmp_ovr_idx)) Then + isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) + if (debug) write(0,*) me,'Realloc tmp_ovr',isz + call psb_realloc(isz,tmp_ovr_idx,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - tmp_ovr_idx(counter_o)=proc - tmp_ovr_idx(counter_o+1)=1 - tmp_ovr_idx(counter_o+2)=gidx - tmp_ovr_idx(counter_o+3)=-1 - counter_o=counter_o+3 + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 - call SearchInsKeyVal(gidx,counter_e,glx,info) + call SearchInsKeyVal(gidx,counter_e,glx,info) !!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) myrow,'Realloc ovr_el',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If + if (info>=0) then + If (glx < counter_e) Then + desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & + & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 + Else + If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then + isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) + if (debug) write(0,*) me,'Realloc ovr_el',isz + call psb_realloc(isz,desc_p%ovrlap_elem,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If !!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) myrow,'Cdovrbld From SearchInsKeyVal: ',info - endif + desc_p%ovrlap_elem(counter_e)=gidx + desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 + desc_p%ovrlap_elem(counter_e+2)=-1 + counter_e = counter_e + 2 + End If + else + write(0,*) me,'Cdovrbld From SearchInsKeyVal: ',info + endif - ! - ! Prepare to exchange the halo rows with the other proc. - ! - If (i_ovr < (n_ovr)) Then - call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) - if (info /= 0) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + ! + ! Prepare to exchange the halo rows with the other proc. + ! + If (i_ovr < (n_ovr)) Then + call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) + if (info /= 0) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if - If((idxs+tot_elem+n_elem) > lworks) Then - isz = max((3*lworks)/2,(idxs+tot_elem+n_elem)) - if (debug) write(0,*) myrow,'Realloc works',isz - call psb_realloc(isz,works,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - lworks = isz - End If - If((n_elem) > size(blk%ia2)) Then - isz = max((3*size(blk%ia2))/2,(n_elem)) - if (debug) write(0,*) myrow,'Realloc blk',isz - call psb_sp_reall(blk,isz,info) - if (info /= 0) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If - - call psb_spgtblk(idx,a,blk,info) - if (info /= 0) then - info=4010 - ch_err='psb_spgtblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - Do jj=1,n_elem - works(idxs+tot_elem+jj)=desc_p%loc_to_glob(blk%ia2(jj)) - End Do - tot_elem=tot_elem+n_elem - End If - - Enddo - - t4 = t4 + mpi_wtime() -t3 - - if (i_ovr < n_ovr) then - if (tot_elem > 1) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - if (tot_elem+2 > size(temp)) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - deallocate(temp) - allocate(temp(tot_elem+2),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - endif - Call mrgsrt(tot_elem,works(idxs+1),temp,info) - If (info.Eq.0) Call ireordv1(tot_elem,works(idxs+1),temp) - lx = works(idxs+1) - i = 1 - j = 1 - do - j = j + 1 - if (j > tot_elem) exit - if (works(idxs+j) /= lx) then - i = i + 1 - works(idxs+i) = works(idxs+j) - lx = works(idxs+i) - end if - end do - tot_elem = i - endif - if (debug) write(0,*) myrow,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) - sdsz(proc+1) = tot_elem - idxs = idxs + tot_elem - end if - counter = counter+n_elem_send+3 - if (debug) write(0,*) myrow,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) - Enddo - if (debug) write(0,*)myrow,'End phase 1 CDOVRBLD', m, n_col, tot_recv - - if (i_ovr < n_ovr) then - ! - ! Exchange data requests with everybody else: so far we have - ! accumulated RECV requests, we have an all-to-all to build - ! matchings SENDs. - ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - idxs = 0 - idxr = 0 - counter = 1 - Do - proc=halo(counter) - if (proc == -1) exit - n_elem_recv = halo(counter+psb_n_elem_recv_) - counter = counter+n_elem_recv - n_elem_send = halo(counter+psb_n_elem_send_) - - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) - counter = counter+n_elem_send+3 - Enddo - - iszr=sum(rvsz) - if (max(iszr,1) > lworkr) then - call psb_realloc(max(iszr,1),workr,info) - if (info /= 0) then + If((idxs+tot_elem+n_elem) > lworks) Then + isz = max((3*lworks)/2,(idxs+tot_elem+n_elem)) + if (debug) write(0,*) me,'Realloc works',isz + call psb_realloc(isz,works,info) + if (info /= 0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if - lworkr=max(iszr,1) - end if + end if + lworks = isz + End If + If((n_elem) > size(blk%ia2)) Then + isz = max((3*size(blk%ia2))/2,(n_elem)) + if (debug) write(0,*) me,'Realloc blk',isz + call psb_sp_reall(blk,isz,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) + call psb_spgtblk(idx,a,blk,info) + if (info /= 0) then + info=4010 + ch_err='psb_spgtblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Do jj=1,n_elem + works(idxs+tot_elem+jj)=desc_p%loc_to_glob(blk%ia2(jj)) + End Do + tot_elem=tot_elem+n_elem + End If + + Enddo + + t4 = t4 + mpi_wtime() -t3 + + if (i_ovr < n_ovr) then + if (tot_elem > 1) then +!!$ write(0,*) me,'Realloc temp',tot_elem+2 + if (tot_elem+2 > size(temp)) then +!!$ write(0,*) me,'Realloc temp',tot_elem+2 + deallocate(temp) + allocate(temp(tot_elem+2),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + endif + Call mrgsrt(tot_elem,works(idxs+1),temp,info) + If (info == 0) Call ireordv1(tot_elem,works(idxs+1),temp) + lx = works(idxs+1) + i = 1 + j = 1 + do + j = j + 1 + if (j > tot_elem) exit + if (works(idxs+j) /= lx) then + i = i + 1 + works(idxs+i) = works(idxs+j) + lx = works(idxs+i) + end if + end do + tot_elem = i + endif + if (debug) write(0,*) me,'Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + sdsz(proc+1) = tot_elem + idxs = idxs + tot_elem + end if + counter = counter+n_elem_send+3 + if (debug) write(0,*) me,'Checktmp_o_i Loop End',tmp_ovr_idx(1:10) + Enddo + if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv + + if (i_ovr < n_ovr) then + ! + ! Exchange data requests with everybody else: so far we have + ! accumulated RECV requests, we have an all-to-all to build + ! matchings SENDs. + ! + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=halo(counter) + if (proc == -1) exit + n_elem_recv = halo(counter+psb_n_elem_recv_) + counter = counter+n_elem_recv + n_elem_send = halo(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_elem_send+3 + Enddo + + iszr=sum(rvsz) + if (max(iszr,1) > lworkr) then + call psb_realloc(max(iszr,1),workr,info) if (info /= 0) then - info=4010 - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + lworkr=max(iszr,1) + end if + + call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& + & workr,rvsz,brvindx,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Do i=1,iszr + idx=workr(i) + if (idx <1) then + write(0,*) me,'Error in CDOVRBLD ',idx,i,iszr +!!$ write(0,*) me, ' WORKR :',workr(1:iszr) + else If (desc_p%glob_to_loc(idx) < -np) Then + ! + ! This is a new index. Assigning a local index as + ! we receive the guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I Size(desc_p%loc_to_glob)) Then + isz = 3*n_col/2 + if (debug) write(0,*) me,'Realloc loc_to_glob' + call psb_realloc(isz,desc_p%loc_to_glob,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If + desc_p%glob_to_loc(idx)=n_col + desc_p%loc_to_glob(n_col)=idx + If((counter_t+3) > Size(t_halo_in))Write(0,*)'bingo' + t_halo_in(counter_t)=proc_id + t_halo_in(counter_t+1)=1 + t_halo_in(counter_t+2)=n_col + counter_t=counter_t+3 + if (debug) write(0,*) me,' CDOVRBLD: Added into t_halo_in from recv',& + &proc_id,n_col,idx + else if (desc_p%glob_to_loc(idx) < 0) Then + if (debug) write(0,*) me,'Wrong input to cdovrbld??',& + &idx,desc_p%glob_to_loc(idx) + End If + End Do + end if + t2 = mpi_wtime() + n_row=m+tot_recv + desc_p%matrix_data(psb_n_row_)=n_row + desc_p%matrix_data(psb_n_col_)=n_col + + ! + ! Ok, now we have a temporary halo with all the info for the + ! next round. If we need to keep going, convert the halo format + ! from temporary to final, so that we can work out the next iteration. + ! This uses one of the convert_comm internals, i.e. we are doing + ! the equivalent of a partial call to convert_comm + ! + + If (i_ovr < (n_ovr)) Then + + If(lwork < (counter_t/3+np*3)) Then + isz = max((3*lwork)/2,(counter_t/3+np*3)) + if (debug) write(0,*) me,'Realloc work',isz + deallocate(work) + allocate(work(isz),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 end if - Do i=1,iszr - idx=workr(i) - if (idx <1) then - write(0,*) myrow,'Error in CDOVRBLD ',idx,i,iszr -!!$ write(0,*) myrow, ' WORKR :',workr(1:iszr) - else If (desc_p%glob_to_loc(idx) < -np) Then - ! - ! This is a new index. Assigning a local index as - ! we receive the guarantees that all indices for HALO(I) - ! will be less than those for HALO(J) whenever I Size(desc_p%loc_to_glob)) Then - isz = 3*n_col/2 - if (debug) write(0,*) myrow,'Realloc loc_to_glob' - call psb_realloc(isz,desc_p%loc_to_glob,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If - desc_p%glob_to_loc(idx)=n_col - desc_p%loc_to_glob(n_col)=idx - If((counter_t+3) > Size(t_halo_in))Write(0,*)'bingo' - t_halo_in(counter_t)=proc_id - t_halo_in(counter_t+1)=1 - t_halo_in(counter_t+2)=n_col - counter_t=counter_t+3 - if (debug) write(0,*) myrow,' CDOVRBLD: Added into t_halo_in from recv',& - &proc_id,n_col,idx - else if (desc_p%glob_to_loc(idx) < 0) Then - if (debug) write(0,*) myrow,'Wrong input to cdovrbld??',& - &idx,desc_p%glob_to_loc(idx) - End If - End Do - end if - t2 = mpi_wtime() - n_row=m+tot_recv - desc_p%matrix_data(psb_n_row_)=n_row - desc_p%matrix_data(psb_n_col_)=n_col - - ! - ! Ok, now we have a temporary halo with all the info for the - ! next round. If we need to keep going, convert the halo format - ! from temporary to final, so that we can work out the next iteration. - ! This uses one of the convert_comm internals, i.e. we are doing - ! the equivalent of a partial call to convert_comm - ! - - If (i_ovr < (n_ovr)) Then - - If(lwork < (counter_t/3+np*3)) Then - isz = max((3*lwork)/2,(counter_t/3+np*3)) - if (debug) write(0,*) myrow,'Realloc work',isz - deallocate(work) - allocate(work(isz),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - lwork=size(work) - Endif - t_halo_in(counter_t)=-1 + lwork=size(work) + Endif + t_halo_in(counter_t)=-1 !!$ !!$ t_halo_out(:)=-1 !!$ ierr = MPE_Log_event( icrhb, 0, "st CRTHAL" ) - if (debug) write(0,*) myrow,'Checktmp_o_i 1',tmp_ovr_idx(1:10) - if (debug) write(0,*) myrow,'Calling Crea_Halo' - - call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) + if (debug) write(0,*) me,'Checktmp_o_i 1',tmp_ovr_idx(1:10) + if (debug) write(0,*) me,'Calling Crea_Halo' + + call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) !!$ Call psi_crea_halo(desc_p%matrix_data,t_halo_in,& !!$ & np,t_halo_out,Size(t_halo_out),dep_list,& !!$ & dl_lda,length_dl,desc_p%loc_to_glob,& !!$ & desc_p%glob_to_loc,work,lwork,info) - if (debug) then - write(0,*) myrow,'Done Crea_Halo' - call blacs_barrier(ictxt,'All') - end if - if (debug) write(0,*) myrow,'Checktmp_o_i 2',tmp_ovr_idx(1:10) - if (debug) write(0,*) myrow,'Done Crea_Halo' + if (debug) then + write(0,*) me,'Done Crea_Halo' + call psb_barrier(ictxt) + end if + if (debug) write(0,*) me,'Checktmp_o_i 2',tmp_ovr_idx(1:10) + if (debug) write(0,*) me,'Done Crea_Halo' !!$ ierr = MPE_Log_event( icrhe, 0, "ed CRHAL " ) - halo => t_halo_out - ! - ! At this point we have built the halo necessary for I_OVR+1. - ! - End If - if (debug) write(0,*) myrow,'Checktmp_o_i ',tmp_ovr_idx(1:10) - t3 = mpi_wtime() - tl = tl +(t2-t1) - tch = tch +(t3-t2) + halo => t_halo_out + ! + ! At this point we have built the halo necessary for I_OVR+1. + ! + End If + if (debug) write(0,*) me,'Checktmp_o_i ',tmp_ovr_idx(1:10) + t3 = mpi_wtime() + tl = tl +(t2-t1) + tch = tch +(t3-t2) End Do t1 = mpi_wtime() call FreePairSearchTree() @@ -632,24 +634,24 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& ! if (debug) then - write(0,*) 'psb_cdasb: converting indexes' - call blacs_barrier(ictxt,'All') + write(0,*) 'psb_cdasb: converting indexes' + call psb_barrier(ictxt) end if !.... convert comunication stuctures.... ! first the halo index call psi_crea_index(desc_p,tmp_halo,& & desc_p%halo_index,.false.,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 end if ! then the overlap index call psi_crea_index(desc_p,tmp_ovr_idx,& & desc_p%ovrlap_index,.true.,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 end if ! next is the ovrlap_elem index @@ -658,8 +660,8 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& ! finally bnd_elem call psi_crea_bnd_elem(desc_p,info) if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') - goto 9999 + call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') + goto 9999 end if ! Ok, register into MATRIX_DATA & free temporary work areas @@ -674,25 +676,25 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& desc_p%lprm(1) = 0 if (debug) then - write(0,*) myrow,'Done Convert_comm' - call blacs_barrier(ictxt,'All') + write(0,*) me,'Done Convert_comm' + call psb_barrier(ictxt) end if if (.false.) then - call psb_cdprt(70+myrow,desc_p,.false.) + call psb_cdprt(70+me,desc_p,.false.) end if - if (debug) write(0,*) myrow,'Done ConvertComm' + if (debug) write(0,*) me,'Done ConvertComm' !!$ ierr = MPE_Log_event( iovre, 0, "ed CNVCRT" ) Deallocate(works,workr,t_halo_in,t_halo_out,work,& & length_dl,dep_list,tmp_ovr_idx,tmp_halo,& & brvindx,rvsz,sdsz,bsdindx,temp,stat=info) if (info == 0) call psb_sp_free(blk,info) if (info /= 0) then - info=4010 - ch_err='sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if t2 = mpi_wtime() @@ -701,9 +703,9 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_zcsrp.f90 b/src/tools/psb_zcsrp.f90 index af044fdf4..687a97b6b 100644 --- a/src/tools/psb_zcsrp.f90 +++ b/src/tools/psb_zcsrp.f90 @@ -78,7 +78,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) integer :: int_err(5),p(1),infoa(10) real(kind(1.d0)) :: real_err(5) integer,pointer :: ipt(:) - integer :: i,err,nprow,npcol,me,& + integer :: i,err,np,npcol,me,& & mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize integer :: dectype real(kind(1.d0)), pointer :: work_dcsdp(:) @@ -96,22 +96,17 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) n_row = desc_a%matrix_data(psb_n_row_) n_col = desc_a%matrix_data(psb_n_col_) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psd_csrp' ! check on blacs grid - call psb_info(ictxt, me, nprow) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif @@ -123,7 +118,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) endif ipsize = size(iperm) - if (.not.((ipsize.eq.n_col).or.(ipsize.eq.n_row) )) then + if (.not.((ipsize == n_col).or.(ipsize == n_row) )) then info = 35 int_err(1) = 1 int_err(2) = ipsize @@ -139,17 +134,17 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) endif l_dcsdp = (n_col) - + call psb_realloc(l_dcsdp,work_dcsdp,info) call psb_realloc(n_col,ipt,info) if(info /= no_err) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 + info=4010 + char_err='psrealloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 end if - if (ipsize.eq.n_col) then + if (ipsize == n_col) then do i=1, n_col ipt(i) = iperm(i) enddo @@ -169,14 +164,14 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) call zcsrp(trans,n_row,n_col,a%fida,a%descra,a%ia1,a%ia2,a%infoa,& & ipt,work_dcsdp,size(work_dcsdp),info) if(info /= no_err) then - info=4010 - char_err='dcsrp' - call psb_errpush(info,name,a_err=char_err) - goto 9999 + info=4010 + char_err='dcsrp' + call psb_errpush(info,name,a_err=char_err) + goto 9999 end if - + deallocate(ipt,work_dcsdp) - + time(4) = mpi_wtime() time(4) = time(4) - time(3) if (debug) then @@ -190,9 +185,9 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error() - return + if (err_act == act_abort) then + call psb_error() + return end if return diff --git a/src/tools/psb_zfree.f90 b/src/tools/psb_zfree.f90 index 98983977a..ae6d12b9a 100644 --- a/src/tools/psb_zfree.f90 +++ b/src/tools/psb_zfree.f90 @@ -42,6 +42,7 @@ subroutine psb_zfree(x, desc_a, info) use psb_const_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -51,36 +52,30 @@ subroutine psb_zfree(x, desc_a, info) !...locals.... integer :: int_err(5) - integer :: ictxt,nprow,npcol,me,mypcol,err, err_act + integer :: ictxt,np,npcol,me,mypcol,err, err_act character(len=20) :: name - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name='psb_zfree' + if (.not.associated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + return + end if ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif - if (.not.associated(desc_a%matrix_data)) then - info=295 - call psb_errpush(info,name) - goto 9999 - end if - if (.not.associated(x)) then info=295 call psb_errpush(info,name) @@ -89,10 +84,10 @@ subroutine psb_zfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) - if (info.ne.no_err) then - info=4000 - call psb_errpush(info,name) - goto 9999 + if (info /= no_err) then + info=4000 + call psb_errpush(info,name) + goto 9999 else nullify(x) endif @@ -103,11 +98,9 @@ subroutine psb_zfree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return - else + if (err_act == act_abort) then call psb_error(ictxt) + return end if return @@ -127,6 +120,7 @@ subroutine psb_zfreev(x, desc_a, info) use psb_const_mod use psb_descriptor_type use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -136,34 +130,29 @@ subroutine psb_zfreev(x, desc_a, info) !...locals.... integer :: int_err(5) - integer :: ictxt,nprow,npcol,me,mypcol,err, err_act + integer :: ictxt,np,npcol,me,mypcol,err, err_act character(len=20) :: name - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name='psb_zfreev' - ictxt=desc_a%matrix_data(psb_ctxt_) if (.not.associated(desc_a%matrix_data)) then info=295 call psb_errpush(info,name) goto 9999 end if + ictxt=desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + endif if (.not.associated(x)) then @@ -174,7 +163,7 @@ subroutine psb_zfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) - if (info.ne.no_err) then + if (info /= no_err) then info=4000 call psb_errpush(info,name) else @@ -187,7 +176,7 @@ subroutine psb_zfreev(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_zgelp.f90 b/src/tools/psb_zgelp.f90 index b8e63415a..125b8698d 100644 --- a/src/tools/psb_zgelp.f90 +++ b/src/tools/psb_zgelp.f90 @@ -45,6 +45,7 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -53,7 +54,7 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) character, intent(in) :: trans ! local variables - integer :: err, ictxt,nprow, & + integer :: err, ictxt,np, & & npcol,me,mypcol,temp,lwork,nrow,ncol complex(kind(1.d0)),pointer :: dtemp(:) integer :: int_err(5), i1sz, i2sz, dectype, i, err_act @@ -62,27 +63,27 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) logical, parameter :: debug=.false. interface - subroutine zgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(kind(1.d0)), intent(inout) :: b(ldb,*), work(*) - integer, intent(in) :: p(*) - end subroutine zgelp + subroutine zgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + complex(kind(1.d0)), intent(inout) :: b(ldb,*), work(*) + integer, intent(in) :: p(*) + end subroutine zgelp end interface interface isaperm - logical function isaperm(n,ip) - integer, intent(in) :: n - integer, intent(inout) :: ip(*) - end function isaperm + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm end interface character(len=20) :: name, ch_err name = 'psb_zgelp' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -93,32 +94,27 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) i1sz = size(x,dim=1) i2sz = size(x,dim=2) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) - if (debug) write(*,*) 'asb start: ',nprow,npcol,me,& + if (debug) write(*,*) 'asb start: ',np,npcol,me,& &desc_a%matrix_data(psb_dec_type_) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 else if (.not.psb_is_asb_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif if (.not.isaperm(i1sz,iperm)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol @@ -126,9 +122,9 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) call zgelp(trans,i1sz,i2sz,iperm,x,i1sz,dtemp,i1sz,info) if(info.ne.0) then - info=4010 - ch_err='zgelp' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='zgelp' + call psb_errpush(info,name,a_err=ch_err) end if deallocate(dtemp) @@ -139,10 +135,10 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return @@ -195,6 +191,7 @@ subroutine psb_zgelpv(trans,iperm,x,desc_a,info) use psb_const_mod use psb_psblas_mod use psb_error_mod + use psb_penv_mod implicit none type(psb_desc_type), intent(in) :: desc_a @@ -203,7 +200,7 @@ subroutine psb_zgelpv(trans,iperm,x,desc_a,info) character, intent(in) :: trans ! local variables - integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork + integer :: err, ictxt,np,npcol,me,mypcol,temp,lwork integer :: int_err(5), i1sz,nrow,ncol,dectype, i, err_act complex(kind(1.d0)),pointer :: dtemp(:) double precision :: real_err(5) @@ -212,27 +209,27 @@ subroutine psb_zgelpv(trans,iperm,x,desc_a,info) logical, parameter :: debug=.false. interface zgelp - subroutine zgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(kind(1.d0)), intent(inout) :: b(*), work(*) - integer, intent(in) :: p(*) - end subroutine zgelp + subroutine zgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + complex(kind(1.d0)), intent(inout) :: b(*), work(*) + integer, intent(in) :: p(*) + end subroutine zgelp end interface interface isaperm - logical function isaperm(n,ip) - integer, intent(in) :: n - integer, intent(inout) :: ip(*) - end function isaperm + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm end interface character(len=20) :: name, ch_err name = 'psb_zgelpv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -243,40 +240,35 @@ subroutine psb_zgelpv(trans,iperm,x,desc_a,info) nrow=desc_a%matrix_data(psb_n_row_) ncol=desc_a%matrix_data(psb_n_col_) - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) + call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 else if (.not.psb_is_asb_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif if (debug) write(0,*) 'calling isaperm ',i1sz,size(iperm),trans if (.not.isaperm(i1sz,iperm)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif allocate(dtemp(i1sz),stat=info) call zgelp(trans,i1sz,1,iperm,x,i1sz,dtemp,i1sz,info) if(info.ne.0) then - info=4010 - ch_err='zgelp' - call psb_errpush(info,name,a_err=ch_err) + info=4010 + ch_err='zgelp' + call psb_errpush(info,name,a_err=ch_err) end if deallocate(dtemp) @@ -287,10 +279,10 @@ subroutine psb_zgelpv(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then - return + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/src/tools/psb_zins.f90 b/src/tools/psb_zins.f90 index 8701100e5..005d6c0b2 100644 --- a/src/tools/psb_zins.f90 +++ b/src/tools/psb_zins.f90 @@ -1,4 +1,3 @@ - !!$ !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata @@ -45,6 +44,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none ! m rows number of submatrix belonging to val to be inserted @@ -64,10 +64,10 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) !locals..... integer :: ictxt,i,loc_row,glob_row,row,k,& & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err - integer :: nprow,npcol, me ,mypcol,dupl_ + integer :: np,npcol, me ,mypcol,dupl_ character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dinsvv' @@ -85,21 +85,15 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif !... check parameters.... - if (m.lt.0) then + if (m < 0) then info = 10 int_err(1) = 1 int_err(2) = m @@ -110,7 +104,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) int_err(1) = desc_a%matrix_data(psb_dec_type_) call psb_errpush(info,name,int_err) goto 9999 - else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then + else if (size(x, dim=1) < desc_a%matrix_data(psb_n_row_)) then info = 310 int_err(1) = 5 int_err(2) = 4 @@ -176,7 +170,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) @@ -231,6 +225,7 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) use psb_descriptor_type use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none ! m rows number of submatrix belonging to val to be inserted @@ -250,10 +245,10 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) !locals..... integer :: ictxt,i,loc_row,glob_row,row,k,j,n,& & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err - integer :: nprow,npcol, me ,mypcol,dupl_ + integer :: np,npcol, me ,mypcol,dupl_ character(len=20) :: name, char_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_dinsvv' @@ -271,17 +266,11 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) ictxt=desc_a%matrix_data(psb_ctxt_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) - if (nprow.eq.-1) then + call psb_info(ictxt, me, np) + if (np == -1) then info = 2010 call psb_errpush(info,name) goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 endif !... check parameters.... @@ -296,7 +285,7 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) int_err(1) = desc_a%matrix_data(psb_dec_type_) call psb_errpush(info,name,int_err) goto 9999 - else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then + else if (size(x, dim=1) < desc_a%matrix_data(psb_n_row_)) then info = 310 int_err(1) = 5 int_err(2) = 4 @@ -309,6 +298,7 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) mglob = desc_a%matrix_data(psb_m_) n = min(size(val,2),size(x,2)) + if (present(dupl)) then dupl_ = dupl else @@ -367,7 +357,7 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act == act_ret) then return else call psb_error(ictxt) diff --git a/src/tools/psb_zspalloc.f90 b/src/tools/psb_zspalloc.f90 index aa723a95f..96ed63f3b 100644 --- a/src/tools/psb_zspalloc.f90 +++ b/src/tools/psb_zspalloc.f90 @@ -46,6 +46,7 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -56,31 +57,26 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) !locals integer :: ictxt, dectype - integer :: nprow,npcol,myrow,mycol,loc_row,& + integer :: np,npcol,me,mycol,loc_row,& & length_ia1,length_ia2,err,nprocs, err_act,m,n integer :: int_err(5),temp(1) real(kind(1.d0)) :: real_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) name = 'psb_zspalloc' ictxt = desc_a%matrix_data(psb_ctxt_) - dectype=desc_a%matrix_data(psb_dec_type_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) -! ....verify blacs grid correctness.. - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,int_err) - goto 9999 + dectype = desc_a%matrix_data(psb_dec_type_) + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif ! @@ -96,29 +92,29 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) !...allocate matrix data... if (present(nnz))then - if (nnz.lt.0) then - info=45 - int_err(1)=7 - int_err(2)=nnz - call psb_errpush(info,name,int_err) - goto 9999 - endif - length_ia1=nnz - length_ia2=nnz + if (nnz < 0) then + info=45 + int_err(1)=7 + int_err(2)=nnz + call psb_errpush(info,name,int_err) + goto 9999 + endif + length_ia1=nnz + length_ia2=nnz else - length_ia1=max(1,4*loc_row) - length_ia2=max(1,4*loc_row) + length_ia1=max(1,4*loc_row) + length_ia2=max(1,4*loc_row) endif if (debug) write(*,*) 'allocating size:',length_ia1 !....allocate aspk, ia1, ia2..... call psb_sp_all(loc_row,loc_row,a,length_ia1,info) - if(info.ne.0) then - info=4010 - ch_err='sp_all' - call psb_errpush(info,name,int_err) - goto 9999 + if(info /= 0) then + info=4010 + ch_err='sp_all' + call psb_errpush(info,name,int_err) + goto 9999 end if ! set permutation matrices @@ -135,17 +131,17 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) &desc_a%matrix_data(psb_dec_type_),psb_desc_bld_ return - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - - if (err_act.eq.act_ret) then - return + + if (err_act == act_ret) then + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/src/tools/psb_zspasb.f90 b/src/tools/psb_zspasb.f90 index 13e0f924a..d3a607ff7 100644 --- a/src/tools/psb_zspasb.f90 +++ b/src/tools/psb_zspasb.f90 @@ -51,6 +51,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) use psi_mod use psb_error_mod use psb_string_mod + use psb_penv_mod implicit none @@ -65,7 +66,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) type(psb_zspmat_type) :: atemp real(kind(1.d0)) :: real_err(5) integer :: ia1_size,ia2_size,aspk_size,m,i,err,& - & nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act + & np,npcol,me,mycol ,size_req,n_col,iout, err_act integer :: dscstate, spstate, nr,k,j integer :: upd_, dupl_ integer :: ictxt,temp(2),isize(2),n_row @@ -83,23 +84,18 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) n_col = desc_a%matrix_data(psb_n_col_) ! check on BLACS grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (.not.psb_is_asb_dec(dscstate)) then - info = 600 - int_err(1) = dscstate - call psb_errpush(info,name) - goto 9999 + info = 600 + int_err(1) = dscstate + call psb_errpush(info,name) + goto 9999 endif if (debug) Write (*, *) ' Begin matrix assembly...' @@ -154,7 +150,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) endif if (debugwrt) then - iout = 30+myrow + iout = 30+me open(iout) call psb_csprt(iout,atemp,head='Input mat') close(iout) @@ -164,7 +160,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) ! result is put in A call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_) - IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA + IF (debug) WRITE (*, *) me,' ASB: From ZCSDP',info,' ',A%FIDA if (info /= no_err) then info=4010 ch_err='psb_csdp' @@ -173,58 +169,58 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) endif if (debugwrt) then - iout = 60+myrow + iout = 60+me open(iout) call psb_csprt(iout,a,head='Output mat') close(iout) endif - call psb_sp_free(atemp,info) + call psb_sp_free(atemp,info) else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! + ! + ! Second case: we come from an update loop. + ! - ! Right now, almost nothing to be done, but this - ! may change in the future - ! as we revise the implementation of the update routine. - call psb_sp_all(atemp,1,info) - atemp%m=a%m - atemp%k=a%k - ! check on allocation - if (info /= no_err) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif + ! Right now, almost nothing to be done, but this + ! may change in the future + ! as we revise the implementation of the update routine. + call psb_sp_all(atemp,1,info) + atemp%m=a%m + atemp%k=a%k + ! check on allocation + if (info /= no_err) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif - call psb_csdp(atemp,a,info,check='R') - ! check on error retuned by dcsdp - if (info /= no_err) then - info = 4010 - ch_err='psb_csdp90' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + call psb_csdp(atemp,a,info,check='R') + ! check on error retuned by zcsdp + if (info /= no_err) then + info = 4010 + ch_err='psb_csdp90' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if - call psb_sp_free(atemp,info) - if (info /= no_err) then - info = 4010 - ch_err='sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + call psb_sp_free(atemp,info) + if (info /= no_err) then + info = 4010 + ch_err='sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if else - info = 600 - call psb_errpush(info,name) - goto 9999 - if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + info = 600 + call psb_errpush(info,name) + goto 9999 + if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ endif @@ -233,9 +229,9 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_zspcnv.f90 b/src/tools/psb_zspcnv.f90 index 8de66365e..d4278b70a 100644 --- a/src/tools/psb_zspcnv.f90 +++ b/src/tools/psb_zspcnv.f90 @@ -46,50 +46,51 @@ subroutine psb_zspcnv(a,b,desc_a,info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none interface zcsdp - subroutine zcsdp(check,trans,m,n,unitd,d,& - & fida,descra,a,ia1,ia2,infoa,& - & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& - & work,lwork,ierror) - integer, intent(in) :: lh, lwork, lh1, lh2, m, n - integer, intent(out) :: ierror - character, intent(in) :: check, trans, unitd - complex(kind(1.d0)), intent(in) :: d(*), a(*) - complex(kind(1.d0)), intent(out) :: h(*) - complex(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) - character, intent(in) :: fida*5, descra*11 - character, intent(out) :: fidh*5, descrh*11 - end subroutine zcsdp + subroutine zcsdp(check,trans,m,n,unitd,d,& + & fida,descra,a,ia1,ia2,infoa,& + & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& + & work,lwork,ierror) + integer, intent(in) :: lh, lwork, lh1, lh2, m, n + integer, intent(out) :: ierror + character, intent(in) :: check, trans, unitd + complex(kind(1.d0)), intent(in) :: d(*), a(*) + complex(kind(1.d0)), intent(out) :: h(*) + complex(kind(1.d0)), intent(inout) :: work(*) + integer, intent(in) :: ia1(*), ia2(*), infoa(*) + integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) + character, intent(in) :: fida*5, descra*11 + character, intent(out) :: fidh*5, descrh*11 + end subroutine zcsdp end interface interface zcsrp - subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine zcsrp + subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& + & infoa,p,work,lwork,ierror) + integer, intent(in) :: m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + complex(kind(1.d0)), intent(inout) :: work(*) + integer, intent(in) :: p(*) + integer, intent(inout) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine zcsrp end interface interface zcsprt - subroutine zcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) - integer, intent(in) :: iout,m, n - integer, intent(out) :: ierror - complex(kind(1.d0)), intent(in) :: a(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine zcsprt + subroutine zcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) + integer, intent(in) :: iout,m, n + integer, intent(out) :: ierror + complex(kind(1.d0)), intent(in) :: a(*) + integer, intent(in) :: ia1(*), ia2(*), infoa(*) + character, intent(in) :: fida*5, descra*11 + end subroutine zcsprt end interface !...parameters.... @@ -104,7 +105,7 @@ subroutine psb_zspcnv(a,b,desc_a,info) integer,pointer :: i_temp(:) complex(kind(1.d0)),pointer :: work_dcsdp(:) integer :: ia1_size,ia2_size,aspk_size,err_act& - & ,i,err,nprow,npcol,myrow,mycol,n_col,l_dcsdp, iout, nrow + & ,i,err,np,npcol,me,mycol,n_col,l_dcsdp, iout, nrow integer :: lwork_dcsdp,dectype integer :: ictxt,temp(1),n_row character :: check*1, trans*1, unitd*1 @@ -114,7 +115,7 @@ subroutine psb_zspcnv(a,b,desc_a,info) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name = 'psb_zspcnv' call psb_erractionsave(err_act) @@ -128,23 +129,18 @@ subroutine psb_zspcnv(a,b,desc_a,info) n_col = desc_a%matrix_data(psb_n_col_) ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (nprow.eq.-1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - else if (npcol.ne.1) then - info = 2030 - int_err(1) = npcol - call psb_errpush(info,name,i_err=int_err) - goto 9999 + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 endif if (.not.psb_is_ok_dec((dectype))) then - info = 600 - int_err(1) = dectype - call psb_errpush(info,name,i_err=int_err) - goto 9999 + info = 600 + int_err(1) = dectype + call psb_errpush(info,name,i_err=int_err) + goto 9999 endif if (debug) write (0, *) name,' begin matrix assembly...' @@ -167,11 +163,11 @@ subroutine psb_zspcnv(a,b,desc_a,info) b%k=n_col call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info) allocate(work_dcsdp(l_dcsdp),stat=info) - if (info.ne.0) then - info=2025 - int_err(1)=l_dcsdp - call psb_errpush(info, name, i_err=int_err) - goto 9999 + if (info /= 0) then + info=2025 + int_err(1)=l_dcsdp + call psb_errpush(info, name, i_err=int_err) + goto 9999 endif lwork_dcsdp=size(work_dcsdp) @@ -192,53 +188,53 @@ subroutine psb_zspcnv(a,b,desc_a,info) & size(b%aspk),size(b%ia1),size(b%ia2),& & work_dcsdp,size(work_dcsdp),info) - if(info.ne.no_err) then - info=4010 - ch_err='zcsdp' - call psb_errpush(info, name, a_err=ch_err) - goto 9999 + if(info /= no_err) then + info=4010 + ch_err='zcsdp' + call psb_errpush(info, name, a_err=ch_err) + goto 9999 end if ! ! hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!! ! should work (crossed fingers :-) - if (a%pr(1).ne.0) then - if (b%pr(1).ne.0) then - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = b%pr(a%pr(i)) - enddo - deallocate(b%pr) - b%pr => i_temp - else - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = a%pr(i) - enddo - deallocate(b%pr) - b%pr => i_temp - endif + if (a%pr(1) /= 0) then + if (b%pr(1) /= 0) then + allocate(i_temp(n_col)) + do i=1, n_col + i_temp(i) = b%pr(a%pr(i)) + enddo + deallocate(b%pr) + b%pr => i_temp + else + allocate(i_temp(n_col)) + do i=1, n_col + i_temp(i) = a%pr(i) + enddo + deallocate(b%pr) + b%pr => i_temp + endif endif - if (a%pl(1).ne.0) then - if (b%pr(1).ne.0) then - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(b%pl(i)) - enddo - deallocate(b%pl) - b%pl => i_temp - else - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(i) - enddo - deallocate(b%pl) - b%pl => i_temp - endif + if (a%pl(1) /= 0) then + if (b%pr(1) /= 0) then + allocate(i_temp(n_row)) + do i=1, n_row + i_temp(i) = a%pl(b%pl(i)) + enddo + deallocate(b%pl) + b%pl => i_temp + else + allocate(i_temp(n_row)) + do i=1, n_row + i_temp(i) = a%pl(i) + enddo + deallocate(b%pl) + b%pl => i_temp + endif endif - if (debug) write (0, *) myrow,name,' from dcsdp ',& + if (debug) write (0, *) me,name,' from zcsdp ',& &b%fida,' pl ', b%pl(:),'pr',b%pr(:) call psb_erractionrestore(err_act) @@ -246,9 +242,9 @@ subroutine psb_zspcnv(a,b,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_zspfree.f90 b/src/tools/psb_zspfree.f90 index 4bff1ff05..53a053480 100644 --- a/src/tools/psb_zspfree.f90 +++ b/src/tools/psb_zspfree.f90 @@ -75,7 +75,7 @@ subroutine psb_zspfree(a, desc_a,info) call psb_sp_free(a,info) - if(info.ne.0) then + if(info /= 0) then info=2045 call psb_errpush(info,name) goto 9999 @@ -86,7 +86,7 @@ subroutine psb_zspfree(a, desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/src/tools/psb_zsphalo.f90 b/src/tools/psb_zsphalo.f90 index 492c624ee..e1029592c 100644 --- a/src/tools/psb_zsphalo.f90 +++ b/src/tools/psb_zsphalo.f90 @@ -53,6 +53,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) use psb_realloc_mod use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob use psb_error_mod + use psb_penv_mod Implicit None @@ -63,8 +64,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) integer, intent(out) :: info logical, optional, intent(in) :: rwcnv,clcnv character(len=5), optional :: outfmt - !c ...local scalars.... - Integer :: nprow,npcol,me,mycol,counter,proc,n,i,& + ! ...local scalars.... + Integer :: np,me,counter,proc,n,i,& & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& & n_elem, m, j, ipx,mat_recv, iszs, iszr,& & idxs,idxr, nrv, nsd,nz @@ -78,7 +79,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7,t8,t9 character(len=20) :: name, ch_err - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name='psb_zsphalo' call psb_erractionsave(err_act) @@ -102,16 +103,16 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) endif ictxt=desc_a%matrix_data(psb_ctxt_) - Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) + Call psb_info(ictxt, me, np) t1 = mpi_wtime() - Allocate(sdid(nprow,3),rvid(nprow,3),brvindx(nprow+1),& - & rvsz(nprow),sdsz(nprow),bsdindx(nprow+1),stat=info) + Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1),stat=info) if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 + info=4000 + call psb_errpush(info,name) + goto 9999 end if If (debug) Write(0,*)'dsphalo',me @@ -142,10 +143,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) idx = desc_a%halo_index(counter+psb_elem_send_+j) call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) if (info /= 0) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if tot_elem = tot_elem+n_elem @@ -156,14 +157,14 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) counter = counter+n_el_send+3 Enddo - call blacs_get(ictxt,10,icomm) - + call psb_get_mpicomm(ictxt,icomm) + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) if (info /= 0) then - info=4010 - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if idxs = 0 @@ -187,10 +188,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) call psb_sp_reall(blk,max(iszr,1),info) if(debug) write(0,*)me,'SPHALO Sizes:',size(blk%ia1),size(blk%ia2) if (info /= 0) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if mat_recv = iszr iszs=sum(sdsz) @@ -218,18 +219,18 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) idx = desc_a%halo_index(counter+psb_elem_send_+j) call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) if (info /= 0) then - info=4010 - ch_err='spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if !!$ write(0,*) me,'Getting row ',idx,n_elem call psb_spgtblk(idx,a,tmp,info,append=.true.) if (info /= 0) then - info=4010 - ch_err='psb_spgtblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_spgtblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if tot_elem=tot_elem+n_elem Enddo @@ -245,10 +246,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) if (rwcnv_) call psb_loc_to_glob(tmp%ia1(1:nz),desc_a,info,iact='I') if (clcnv_) call psb_loc_to_glob(tmp%ia2(1:nz),desc_a,info,iact='I') if (info /= 0) then - info=4010 - ch_err='psb_loc_to_glob' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if !!$ call csprt(30+me,tmp,head='% SPHALO border SEND .') !!$ close(30+me) @@ -261,10 +262,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) call mpi_alltoallv(tmp%ia2,sdsz,bsdindx,mpi_integer,& & blk%ia2,rvsz,brvindx,mpi_integer,icomm,info) if (info /= 0) then - info=4010 - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if t3 = mpi_wtime() @@ -276,12 +277,12 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) if (rwcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I') if (clcnv_) call psb_glob_to_loc(blk%ia2(1:iszr),desc_a,info,iact='I') if (info /= 0) then - info=4010 - ch_err='psbglob_to_loc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - + l1 = 0 Do i=1,iszr !!$ write(0,*) work5(i),work6(i) @@ -313,12 +314,12 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) case ('CSR') call psb_ipcoo2csr(blk,info,rwshr=.true.) if (info /= 0) then - info=4010 - ch_err='psb_ipcoo2csr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_ipcoo2csr' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - case('COO') + case('COO') ! Do nothing! case default write(0,*) 'Error in DSPHALO : invalid outfmt "',outfmt_,'"' @@ -335,20 +336,20 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) call psb_sp_free(tmp,info) if (info /= 0) then - info=4010 - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_zspins.f90 b/src/tools/psb_zspins.f90 index 09dfe0121..a604fdce6 100644 --- a/src/tools/psb_zspins.f90 +++ b/src/tools/psb_zspins.f90 @@ -51,6 +51,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod implicit none !....parameters... @@ -66,19 +67,19 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) & first_loc_row,nrow,j, err,locix,locjx,err_act,& & dectype,mglob, nnza,m,n, pnt_halo,ncol, nh, ip, spstate integer,pointer :: tia1(:),tia2(:), temp(:) - integer :: nprow,npcol, myrow ,mycol, iflag, isize, irlc + integer :: np,npcol, me ,mycol, iflag, isize, irlc logical, parameter :: debug=.false. integer, parameter :: relocsz=200 logical :: rebuild_ interface psb_cdins - subroutine psb_cdins(nz,ia,ja,desc_a,info) - use psb_descriptor_type - implicit none - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(in) :: nz,ia(:),ja(:) - integer, intent(out) :: info - end subroutine psb_cdins + subroutine psb_cdins(nz,ia,ja,desc_a,info) + use psb_descriptor_type + implicit none + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(in) :: nz,ia(:),ja(:) + integer, intent(out) :: info + end subroutine psb_cdins end interface character(len=20) :: name, ch_err @@ -91,39 +92,35 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) ictxt = desc_a%matrix_data(psb_ctxt_) dectype = desc_a%matrix_data(psb_dec_type_) mglob = desc_a%matrix_data(psb_m_) - ! check on blacs grid - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) - if (npcol.ne.1) then - info = 2030 - call psb_errpush(info,name) - goto 9999 - endif + + call psb_info(ictxt, me, np) + if (.not.psb_is_ok_dec(dectype)) then - info = 3110 - call psb_errpush(info,name) - goto 9999 + info = 3110 + call psb_errpush(info,name) + goto 9999 endif if (nz <= 0) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (size(ia) < nz) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (size(ja) < nz) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (size(val) < nz) then - info = 1111 - call psb_errpush(info,name) - goto 9999 + info = 1111 + call psb_errpush(info,name) + goto 9999 end if if (present(rebuild)) then @@ -134,44 +131,44 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) spstate = a%infoa(psb_state_) if (psb_is_bld_dec(dectype)) then - call psb_cdins(nz,ia,ja,desc_a,info) - if (info /= 0) then - info=4010 - ch_err='psb_cdins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - nrow = desc_a%matrix_data(psb_n_row_) - ncol = desc_a%matrix_data(psb_n_col_) + call psb_cdins(nz,ia,ja,desc_a,info) + if (info /= 0) then + info=4010 + ch_err='psb_cdins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + nrow = desc_a%matrix_data(psb_n_row_) + ncol = desc_a%matrix_data(psb_n_col_) - if (spstate == psb_spmat_bld_) then - call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc) - if (info /= 0) then - info=4010 - ch_err='psb_coins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - info = 1123 - call psb_errpush(info,name) - goto 9999 - end if - else if (psb_is_asb_dec(dectype)) then - nrow = desc_a%matrix_data(psb_n_row_) - ncol = desc_a%matrix_data(psb_n_col_) - call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& - & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) - if (info /= 0) then + if (spstate == psb_spmat_bld_) then + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc) + if (info /= 0) then info=4010 ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end if + else + info = 1123 + call psb_errpush(info,name) + goto 9999 + end if + else if (psb_is_asb_dec(dectype)) then + nrow = desc_a%matrix_data(psb_n_row_) + ncol = desc_a%matrix_data(psb_n_col_) + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& + & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if else - info = 1122 - call psb_errpush(info,name) - goto 9999 + info = 1122 + call psb_errpush(info,name) + goto 9999 end if call psb_erractionrestore(err_act) @@ -179,9 +176,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error(ictxt) - return + if (err_act == act_abort) then + call psb_error(ictxt) + return end if return diff --git a/src/tools/psb_zsprn.f90 b/src/tools/psb_zsprn.f90 index ffcd2560e..8b7f596a5 100644 --- a/src/tools/psb_zsprn.f90 +++ b/src/tools/psb_zsprn.f90 @@ -45,6 +45,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) use psb_serial_mod use psb_const_mod use psb_error_mod + use psb_penv_mod Implicit None !....Parameters... @@ -55,7 +56,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) !locals Integer :: ictxt - Integer :: nprow,npcol,myrow,mycol,err,err_act + Integer :: np,npcol,me,mycol,err,err_act logical, parameter :: debug=.false. integer :: int_err(5) real(kind(1.d0)) :: real_err(5) @@ -69,16 +70,9 @@ Subroutine psb_zsprn(a, desc_a,info,clear) call psb_erractionsave(err_act) ictxt = desc_a%matrix_data(psb_ctxt_) - call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) + call psb_info(ictxt, me, np) if (debug) & - &write(*,*) 'starting spalloc ',ictxt,nprow,npcol,myrow - - ! ....verify blacs grid correctness.. - if (npcol.ne.1) then - info = 2030 - call psb_errpush(info,name) - goto 9999 - endif + &write(*,*) 'starting spalloc ',ictxt,np,me if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then @@ -105,7 +99,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act == act_abort) then call psb_error(ictxt) return end if diff --git a/test/Fileread/Makefile b/test/Fileread/Makefile index 93f78c485..5a8c41502 100644 --- a/test/Fileread/Makefile +++ b/test/Fileread/Makefile @@ -60,7 +60,7 @@ clean: *$(.mod) $(EXEDIR)/df_sample $(EXEDIR)/zf_sample dhb2mm zhb2mm dmm2hb zmm2hb lib: - (cd ../../; make lib) + (cd ../../; make library) verycleanlib: (cd ../../; make veryclean) diff --git a/test/Fileread/df_sample.f90 b/test/Fileread/df_sample.f90 index a9508f1cc..5abc8d05b 100644 --- a/test/Fileread/df_sample.f90 +++ b/test/Fileread/df_sample.f90 @@ -75,7 +75,6 @@ program df_sample ! communications data structure type(psb_desc_type):: desc_a - ! blacs variables integer :: ictxt, iam, np logical :: amroot @@ -270,11 +269,11 @@ program df_sample end if iparm = 0 - call blacs_barrier(ictxt,'all') + call psb_barrier(ictxt) t1 = mpi_wtime() call psb_krylov(cmethd,a,pre,b_col,x_col,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=ml) - call blacs_barrier(ictxt,'all') + call psb_barrier(ictxt) t2 = mpi_wtime() - t1 call psb_amx(ictxt,t2) call psb_geaxpby(1.d0,b_col,0.d0,r_col,desc_a,info) diff --git a/test/Fileread/zf_sample.f90 b/test/Fileread/zf_sample.f90 index 4e009b8b2..9c77cea03 100644 --- a/test/Fileread/zf_sample.f90 +++ b/test/Fileread/zf_sample.f90 @@ -75,7 +75,6 @@ program zf_sample ! communications data structure type(psb_desc_type):: desc_a - ! blacs variables integer :: ictxt, iam, np logical :: amroot @@ -270,11 +269,11 @@ program zf_sample end if iparm = 0 - call blacs_barrier(ictxt,'all') + call psb_barrier(ictxt) t1 = mpi_wtime() call psb_krylov(cmethd,a,pre,b_col,x_col,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=ml) - call blacs_barrier(ictxt,'all') + call psb_barrier(ictxt) t2 = mpi_wtime() - t1 call psb_amx(ictxt,t2) call psb_geaxpby(zone,b_col,zzero,r_col,desc_a,info)