From c8c211c0e91abfa3d47c6d49907e29a492450d07 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 14 Jan 2008 15:31:12 +0000 Subject: [PATCH] Merged changes at r2702 from branch psblas-ovtrans. --- base/comm/Makefile | 5 +- base/comm/psb_dgather.f90 | 51 +- base/comm/psb_dhalo.f90 | 38 +- base/comm/psb_dovrl.f90 | 138 +-- base/comm/psb_dscatter.F90 | 4 +- base/comm/psb_igather.f90 | 48 +- base/comm/psb_ihalo.f90 | 38 +- base/comm/psb_iovrl.f90 | 397 +++++++++ base/comm/psb_iscatter.F90 | 4 +- base/comm/psb_zgather.f90 | 67 +- base/comm/psb_zhalo.f90 | 38 +- base/comm/psb_zovrl.f90 | 137 +-- base/comm/psb_zscatter.F90 | 4 +- base/internals/Makefile | 5 +- base/internals/psi_bld_hash.f90 | 2 +- base/internals/psi_bld_tmphalo.f90 | 2 +- base/internals/psi_bld_tmpovrl.f90 | 156 ++++ base/internals/psi_compute_size.f90 | 8 +- base/internals/psi_crea_bnd_elem.f90 | 2 +- base/internals/psi_crea_ovr_elem.f90 | 186 ++-- base/internals/psi_desc_index.F90 | 2 +- base/internals/psi_dl_check.f90 | 2 +- base/internals/psi_dswapdata.F90 | 4 +- base/internals/psi_dswaptran.F90 | 4 +- base/internals/psi_exist_ovr_elem.f | 8 +- base/internals/psi_extrct_dl.F90 | 8 +- base/internals/psi_fnd_owner.f90 | 2 +- base/internals/psi_gthsct_mod.f90 | 369 -------- base/internals/psi_idx_cnv.f90 | 4 +- base/internals/psi_idx_ins_cnv.f90 | 8 +- base/internals/psi_iswapdata.F90 | 4 +- base/internals/psi_iswaptran.F90 | 4 +- base/internals/psi_ldsc_pre_halo.f90 | 2 +- base/internals/psi_zswapdata.F90 | 4 +- base/internals/psi_zswaptran.F90 | 5 +- base/modules/psb_comm_mod.f90 | 394 +++++---- base/modules/psb_desc_type.f90 | 2 +- base/modules/psb_error_mod.F90 | 22 +- base/modules/psb_gps_mod.f90 | 126 +-- base/modules/psb_realloc_mod.F90 | 58 +- base/modules/psb_sort_mod.f90 | 20 +- base/modules/psb_spmat_type.f90 | 28 +- base/modules/psb_tools_mod.f90 | 17 +- base/modules/psi_mod.f90 | 1202 +++++++++++++++++++++----- base/psblas/psb_damax.f90 | 40 +- base/psblas/psb_dasum.f90 | 84 +- base/psblas/psb_daxpby.f90 | 30 +- base/psblas/psb_ddot.f90 | 109 +-- base/psblas/psb_dnrm2.f90 | 96 +- base/psblas/psb_dnrmi.f90 | 12 +- base/psblas/psb_dspmm.f90 | 134 +-- base/psblas/psb_dspsm.f90 | 139 +-- base/psblas/psb_zamax.f90 | 40 +- base/psblas/psb_zasum.f90 | 76 +- base/psblas/psb_zaxpby.f90 | 30 +- base/psblas/psb_zdot.f90 | 107 +-- base/psblas/psb_znrm2.f90 | 90 +- base/psblas/psb_znrmi.f90 | 12 +- base/psblas/psb_zspmm.f90 | 153 ++-- base/psblas/psb_zspsm.f90 | 139 +-- base/serial/psb_cest.f90 | 2 +- base/serial/psb_dcoins.f90 | 2 +- base/serial/psb_dcsmm.f90 | 4 +- base/serial/psb_dcsmv.f90 | 4 +- base/serial/psb_dcsnmi.f90 | 2 +- base/serial/psb_dcsrws.f90 | 2 +- base/serial/psb_dcssm.f90 | 4 +- base/serial/psb_dcssv.f90 | 4 +- base/serial/psb_dfixcoo.f90 | 18 +- base/serial/psb_dipcoo2csc.f90 | 2 +- base/serial/psb_dipcoo2csr.f90 | 2 +- base/serial/psb_dipcsr2coo.f90 | 2 +- base/serial/psb_dneigh.f90 | 4 +- base/serial/psb_drwextd.f90 | 2 +- base/serial/psb_dspclip.f90 | 2 +- base/serial/psb_dspcnv.f90 | 4 +- base/serial/psb_dspgetrow.f90 | 2 +- base/serial/psb_dspgtdiag.f90 | 4 +- base/serial/psb_dspscal.f90 | 2 +- base/serial/psb_dsymbmm.f90 | 4 +- base/serial/psb_getrow_mod.f90 | 8 +- base/serial/psb_regen_mod.f90 | 12 +- base/serial/psb_update_mod.f90 | 16 +- base/serial/psb_zcoins.f90 | 2 +- base/serial/psb_zcsmm.f90 | 4 +- base/serial/psb_zcsmv.f90 | 4 +- base/serial/psb_zcsnmi.f90 | 2 +- base/serial/psb_zcsrws.f90 | 2 +- base/serial/psb_zcssm.f90 | 4 +- base/serial/psb_zcssv.f90 | 4 +- base/serial/psb_zfixcoo.f90 | 18 +- base/serial/psb_zgelp.f90 | 4 +- base/serial/psb_zipcoo2csc.f90 | 2 +- base/serial/psb_zipcoo2csr.f90 | 2 +- base/serial/psb_zipcsr2coo.f90 | 2 +- base/serial/psb_zneigh.f90 | 4 +- base/serial/psb_zrwextd.f90 | 2 +- base/serial/psb_zspclip.f90 | 2 +- base/serial/psb_zspcnv.f90 | 4 +- base/serial/psb_zspgetrow.f90 | 2 +- base/serial/psb_zspgtdiag.f90 | 4 +- base/serial/psb_zspscal.f90 | 2 +- base/serial/psb_zsymbmm.f90 | 4 +- base/tools/psb_cd_inloc.f90 | 57 +- base/tools/psb_cdals.f90 | 57 +- base/tools/psb_cdalv.f90 | 69 +- base/tools/psb_cdins.f90 | 2 +- base/tools/psb_cdprt.f90 | 31 +- base/tools/psb_cdren.f90 | 16 +- base/tools/psb_cdrep.f90 | 3 +- base/tools/psb_dallc.f90 | 4 +- base/tools/psb_dcdovr.F90 | 35 +- base/tools/psb_get_overlap.f90 | 23 +- base/tools/psb_ialloc.f90 | 4 +- base/tools/psb_icdasb.F90 | 2 +- base/tools/psb_loc_to_glob.f90 | 12 +- base/tools/psb_zallc.f90 | 4 +- base/tools/psb_zcdovr.F90 | 21 +- base/tools/psb_zspfree.f90 | 2 +- 119 files changed, 2949 insertions(+), 2495 deletions(-) create mode 100644 base/comm/psb_iovrl.f90 create mode 100644 base/internals/psi_bld_tmpovrl.f90 delete mode 100644 base/internals/psi_gthsct_mod.f90 diff --git a/base/comm/Makefile b/base/comm/Makefile index 5d8efc6a..a97ebccd 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -1,7 +1,8 @@ include ../../Make.inc -OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ - psb_igather.o psb_ihalo.o psb_zgather.o psb_zhalo.o psb_zovrl.o +OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ + psb_igather.o psb_ihalo.o psb_iovrl.o \ + psb_zgather.o psb_zhalo.o psb_zovrl.o MPFOBJS=psb_dscatter.o psb_zscatter.o psb_iscatter.o LIBDIR=.. diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 4e3d2fbf..4635c08f 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -66,7 +66,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) character(len=20) :: name, ch_err name='psb_dgatherm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -82,7 +82,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -119,14 +119,14 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,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 @@ -136,17 +136,18 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) do j=1,k do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%loc_to_glob(i) + idx = desc_a%loc_to_glob(i) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do + end do + do j=1,k ! 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,jglobx+j-1) = & - & globx(idx,jglobx+j-1)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - i=i+2 + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx,jglobx+j-1) = dzero + end if end do end do @@ -158,7 +159,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -237,7 +238,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) character(len=20) :: name, ch_err name='psb_dgatherv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -253,7 +254,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -281,14 +282,14 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,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 @@ -300,15 +301,15 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) 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 + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx) = dzero + end if end do - call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) @@ -317,7 +318,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index d3f30599..ac9551c6 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -80,7 +80,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) logical :: aliw name='psb_dhalom' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -108,7 +108,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then + if(ik > maxk) then k=maxk else k=ik @@ -138,23 +138,23 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then + if(alpha /= 1.d0) then do i=0, k-1 call dscal(nrow,alpha,x(1,jjx+i),1) end do @@ -163,13 +163,13 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then + if(size(work) >= liwork) then iwork => work aliw=.false. else aliw=.true. allocate(iwork(liwork),stat=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) @@ -180,7 +180,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) aliw=.true. !!$ write(0,*) 'halom ',liwork allocate(iwork(liwork),stat=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) @@ -202,7 +202,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) goto 9999 end if - if(info.ne.0) then + if(info /= 0) then ch_err='PSI_dSwapdata' call psb_errpush(4010,name,a_err=ch_err) goto 9999 @@ -305,7 +305,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) logical :: aliw name='psb_dhalov' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -344,36 +344,36 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then + if(alpha /= 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 + if(size(work) >= liwork) then iwork => work aliw=.false. else aliw=.true. allocate(iwork(liwork),stat=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) @@ -383,7 +383,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=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) @@ -404,7 +404,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) goto 9999 end if - if(info.ne.0) then + if(info /= 0) then ch_err='PSI_swapdata' call psb_errpush(4010,name,a_err=ch_err) goto 9999 diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index c3c2d5f9..2b79fd2e 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -79,16 +79,16 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) integer, intent(in), optional :: update,jx,ik,mode ! locals - integer :: int_err(5), ictxt, np, me, & + integer :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, i + & mode_, err, liwork real(kind(1.d0)),pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_dovrlm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -117,7 +117,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then + if(ik > maxk) then k=maxk else k=ik @@ -141,87 +141,55 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work + if(size(work) >= liwork) then aliw=.false. else aliw=.true. - allocate(iwork(liwork),stat=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 aliw=.true. + end if + + if (aliw) then allocate(iwork(liwork),stat=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) + call psb_errpush(info,name,a_err='Allocate') goto 9999 end if + else + iwork => work end if - ! exchange overlap elements if(do_swap) then xp => x(iix:size(x,1),jjx:jjx+k-1) call psi_swapdata(mode_,k,done,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') + if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 end if - i=1 - ! switch on update type - select case (update_) - 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 - 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 - case(psb_sum_) - ! do nothing - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,update_,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end select - if (aliw) deallocate(iwork) nullify(iwork) @@ -317,16 +285,16 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) integer, intent(in), optional :: update,mode ! locals - integer :: int_err(5), ictxt, np, me, & + integer :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, i + & mode_, err, liwork real(kind(1.d0)),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_dovrlv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -365,86 +333,54 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work + if(size(work) >= liwork) then aliw=.false. else aliw=.true. - allocate(iwork(liwork),stat=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 aliw=.true. + end if + if (aliw) then allocate(iwork(liwork),stat=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) + call psb_errpush(info,name,a_err='Allocate') goto 9999 end if + else + iwork => work end if ! exchange overlap elements - if(do_swap) then - call psi_swapdata(mode_,done,x(iix:size(x)),& + if (do_swap) then + call psi_swapdata(mode_,done,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') + if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 end if - - i=1 - ! switch on update type - select case (update_) - 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 - 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 - case(psb_sum_) - ! do nothing - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,update_,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end select - + if (aliw) deallocate(iwork) nullify(iwork) diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index 2bf33d55..a709ae98 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -89,7 +89,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -317,7 +317,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 4ead3fcb..4aedf845 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -66,7 +66,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) character(len=20) :: name, ch_err name='psb_igatherm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -82,7 +82,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -119,14 +119,14 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,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 @@ -139,14 +139,15 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) idx = desc_a%loc_to_glob(i) globx(idx,jglobx+j-1) = locx(i,jlx+j-1) end do + end do + do j=1,k ! 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,jglobx+j-1) = & - & globx(idx,jglobx+j-1)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - i=i+2 + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx,jglobx+j-1) = izero + end if end do end do @@ -158,7 +159,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -237,7 +238,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) character(len=20) :: name, ch_err name='psb_igatherv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -253,7 +254,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -281,14 +282,14 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,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 @@ -301,14 +302,13 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) 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 + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx) = dzero + end if end do - call psb_sum(ictxt,globx(1:m),root=root) call psb_erractionrestore(err_act) @@ -317,7 +317,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index c1c32253..ce95f48f 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -81,7 +81,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) logical :: aliw name='psb_ihalom' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -109,7 +109,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then + if(ik > maxk) then k=maxk else k=ik @@ -139,25 +139,25 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 ! we should write an "iscal" !!$ if(present(alpha)) then -!!$ if(alpha.ne.1.d0) then +!!$ if(alpha /= 1.d0) then !!$ do i=0, k-1 !!$ call iscal(nrow,alpha,x(1,jjx+i),1) !!$ end do @@ -166,13 +166,13 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then + if(size(work) >= liwork) then aliw=.false. iwork => work else aliw=.true. allocate(iwork(liwork),stat=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) @@ -182,7 +182,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=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) @@ -204,7 +204,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) goto 9999 end if - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4010,name,a_err='PSI_iSwap...') goto 9999 end if @@ -309,7 +309,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) logical :: aliw name='psb_ihalov' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -350,36 +350,36 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 !!$ if(present(alpha)) then -!!$ if(alpha.ne.1.d0) then +!!$ if(alpha /= 1.d0) then !!$ call dscal(nrow,alpha,x,1) !!$ end if !!$ end if liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then + if(size(work) >= liwork) then aliw=.false. iwork => work else aliw=.true. allocate(iwork(liwork),stat=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) @@ -389,7 +389,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=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) @@ -410,7 +410,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) goto 9999 end if - if(info.ne.0) then + if(info /= 0) then call psb_errpush(4010,name,a_err='PSI_iswapdata') goto 9999 end if diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 new file mode 100644 index 00000000..9a70f292 --- /dev/null +++ b/base/comm/psb_iovrl.f90 @@ -0,0 +1,397 @@ +!!$ +!!$ 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. +!!$ +!!$ +! File: psb_iovrl.f90 +! +! Subroutine: psb_iovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - integer The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - 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 (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_realloc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, target :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork + integer, pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_iovrlm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + ! check on blacs grid + 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 + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:size(x,1),jjx:jjx+k-1) + call psi_swapdata(mode_,k,ione,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psb_iovrlm + +!!$ +!!$ 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: psb_iovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - integer The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - 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 (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! +subroutine psb_iovrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + use psi_mod + use psb_const_mod + use psb_realloc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, target :: work(:) + integer, intent(in), optional :: update,mode + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& + & mode_, err, liwork + integer,pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_iovrlv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,ione,x(:),& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psb_iovrlv diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index 5c171dcf..d2690fd5 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -88,7 +88,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -315,7 +315,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index 507e6d65..16934851 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -66,7 +66,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) character(len=20) :: name, ch_err name='psb_zgatherm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -82,7 +82,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -121,37 +121,38 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) if (info == 0) & & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,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 end if - + globx(:,:)=0.d0 do j=1,k - do i=1,psb_cd_get_local_rows(desc_a) - idx = desc_a%loc_to_glob(i) - globx(idx,jglobx+j-1) = locx(i,jlx+j-1) - 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,jglobx+j-1) = & - & globx(idx,jglobx+j-1)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_) - i=i+2 - end do + do i=1,psb_cd_get_local_rows(desc_a) + idx = desc_a%loc_to_glob(i) + globx(idx,jglobx+j-1) = locx(i,jlx+j-1) + end do end do + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx,jglobx+j-1) = zzero + end if + end do + end do call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root) call psb_erractionrestore(err_act) @@ -160,9 +161,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error(ictxt) - return + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return end if return @@ -240,7 +241,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) character(len=20) :: name, ch_err name='psb_zgatherv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -256,7 +257,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -285,14 +286,14 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) if (info == 0) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,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 @@ -305,15 +306,15 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) 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 + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx) = dzero + end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_erractionrestore(err_act) return @@ -321,7 +322,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index fa2e6373..4e13e0f4 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -80,7 +80,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) logical :: aliw name='psb_zhalom' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -108,7 +108,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then + if(ik > maxk) then k=maxk else k=ik @@ -136,23 +136,23 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then + if(alpha /= 1.d0) then do i=0, k-1 call zscal(nrow,alpha,x(1,jjx+i),1) end do @@ -161,13 +161,13 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) liwork=nrow if (present(work)) then - if(size(work).ge.liwork) then + if(size(work) >= liwork) then aliw=.false. iwork => work else aliw=.true. allocate(iwork(liwork),stat=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) @@ -178,7 +178,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) aliw=.true. allocate(iwork(liwork),stat=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) @@ -200,7 +200,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) goto 9999 end if - if(info.ne.0) then + if(info /= 0) then ch_err='PSI_zswapdata' call psb_errpush(4010,name,a_err=ch_err) goto 9999 @@ -305,7 +305,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) logical :: aliw name='psb_zhalov' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -345,36 +345,36 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 if(present(alpha)) then - if(alpha.ne.1.d0) then + if(alpha /= 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 + if(size(work) >= liwork) then aliw=.false. iwork => work else aliw=.true. allocate(iwork(liwork),stat=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) @@ -384,7 +384,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=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) @@ -405,7 +405,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) goto 9999 end if - if(info.ne.0) then + if(info /= 0) then ch_err='PSI_dSwap...' call psb_errpush(4010,name,a_err=ch_err) goto 9999 diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 7cebf154..eb8a906c 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -80,16 +80,16 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) integer, intent(in), optional :: update,jx,ik,mode ! locals - integer :: int_err(5), ictxt, np, me, & + integer :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, i + & mode_, err, liwork complex(kind(1.d0)),pointer :: iwork(:), xp(:,:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_zovrlm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -118,7 +118,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) maxk=size(x,2)-ijx+1 if(present(ik)) then - if(ik.gt.maxk) then + if(ik > maxk) then k=maxk else k=ik @@ -142,87 +142,54 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work + if(size(work) >= liwork) then aliw=.false. else aliw=.true. - allocate(iwork(liwork),stat=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 aliw=.true. + end if + if (aliw) then allocate(iwork(liwork),stat=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) + call psb_errpush(info,name,a_err='Allocate') goto 9999 end if + else + iwork => work end if - ! exchange overlap elements if(do_swap) then xp => x(iix:size(x,1),jjx:jjx+k-1) call psi_swapdata(mode_,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') + if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 end if - i=1 - ! switch on update type - select case (update_) - 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 - 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 - case(psb_sum_) - ! do nothing - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,update_,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end select - if (aliw) deallocate(iwork) nullify(iwork) @@ -316,16 +283,16 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) integer, intent(in), optional :: update,mode ! locals - integer :: int_err(5), ictxt, np, me, & + integer :: ictxt, np, me, & & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, i + & mode_, err, liwork complex(kind(1.d0)),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_zovrlv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -364,86 +331,54 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) end if err=info call psb_errcomm(ictxt,err) - if(err.ne.0) goto 9999 + if(err /= 0) goto 9999 ! check for presence/size of a work area liwork=ncol if (present(work)) then - if(size(work).ge.liwork) then - iwork => work + if(size(work) >= liwork) then aliw=.false. else aliw=.true. - allocate(iwork(liwork),stat=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 aliw=.true. + end if + if (aliw) then allocate(iwork(liwork),stat=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) + call psb_errpush(info,name,a_err='Allocate') goto 9999 end if + else + iwork => work end if ! exchange overlap elements - if(do_swap) then - call psi_swapdata(mode_,zone,x(iix:size(x)),& + if (do_swap) then + call psi_swapdata(mode_,zone,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') + if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 end if - - i=1 - ! switch on update type - select case (update_) - 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 - 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 - case(psb_sum_) - ! do nothing - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,update_,0,0,0/) - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end select - + if (aliw) deallocate(iwork) nullify(iwork) diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index bbfb758e..c0aff7fb 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -89,7 +89,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) @@ -320,7 +320,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot - if((root.lt.-1).or.(root.gt.np)) then + if((root < -1).or.(root > np)) then info=30 int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) diff --git a/base/internals/Makefile b/base/internals/Makefile index 40143697..ecad6843 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -1,8 +1,7 @@ include ../../Make.inc FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ - psi_crea_ovr_elem.o psi_dl_check.o \ - psi_gthsct_mod.o \ + psi_crea_ovr_elem.o psi_bld_tmpovrl.o psi_dl_check.o \ psi_sort_dl.o \ psi_ldsc_pre_halo.o psi_bld_tmphalo.o psi_bld_hash.o\ psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o psi_fnd_owner.o @@ -23,7 +22,7 @@ lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(RANLIB) $(LIBDIR)/$(LIBNAME) -mpfobjs: psi_gthsct_mod.o +mpfobjs: (make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)") (make $(FOBJS2) F90="$(MPF77)" FC="$(MPF77)" FCOPT="$(FCOPT)") clean: diff --git a/base/internals/psi_bld_hash.f90 b/base/internals/psi_bld_hash.f90 index 039c3b88..211e50a0 100644 --- a/base/internals/psi_bld_hash.f90 +++ b/base/internals/psi_bld_hash.f90 @@ -133,7 +133,7 @@ subroutine psi_bld_hash(desc,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index 2d3b8732..10473d5c 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -137,7 +137,7 @@ subroutine psi_bld_tmphalo(desc,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_bld_tmpovrl.f90 b/base/internals/psi_bld_tmpovrl.f90 new file mode 100644 index 00000000..2a71910c --- /dev/null +++ b/base/internals/psi_bld_tmpovrl.f90 @@ -0,0 +1,156 @@ +!!$ +!!$ 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. +!!$ +!!$ +! +! File: psi_bld_tmpovrl.f90 +! +! Subroutine: psi_bld_tmpovrl +! Build initial versions of overlap exchange lists. +! When the descriptor is for a large index space, we cannot build +! the data exchange lists "on-the-fly", but we also want to keep using the +! same format conversion routines we use in the small index space case, +! hence this adapter routine. +! +! +! Arguments: +! iv(:) - integer Initial list. +! index +! nprocs (sharing it) +! procs(1:nprocs) +! End marked with -1 +! +! desc - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! +subroutine psi_bld_tmpovrl(iv,desc,info) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psi_mod, psb_protect_name => psi_bld_tmpovrl + implicit none + integer, intent(in) :: iv(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + + !locals + Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& + & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, icomm + integer, allocatable :: ov_idx(:),ov_el(:,:) + + integer :: ictxt,n_row, debug_unit, debug_level + character(len=20) :: name,ch_err + + info = 0 + name = 'psi_bld_tmpovrl' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc) + icomm = psb_cd_get_mpic(desc) + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + l_ov_ix=0 + l_ov_el=0 + i = 1 + do while (iv(i) /= -1) + idx = iv(i) + i = i + 1 + nprocs = iv(i) + i = i + 1 + l_ov_ix = l_ov_ix+3*(nprocs-1) + l_ov_el = l_ov_el + 1 + i = i + nprocs + enddo + + l_ov_ix = l_ov_ix+3 + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el + + allocate(ov_idx(l_ov_ix),ov_el(l_ov_el,3), stat=info) + if (info /= psb_no_err_) then + info=4010 + err=info + call psb_errpush(err,name,a_err='psb_realloc') + goto 9999 + end if + + l_ov_ix=0 + l_ov_el=0 + i = 1 + do while (iv(i) /= -1) + idx = iv(i) + i = i+1 + nprocs = iv(i) + l_ov_el = l_ov_el+1 + ov_el(l_ov_el,1) = idx ! Index + ov_el(l_ov_el,2) = nprocs ! How many procs + ov_el(l_ov_el,3) = minval(iv(i+1:i+nprocs)) ! master proc + do j=1, nprocs + if (iv(i+j) /= me) then + ov_idx(l_ov_ix+1) = iv(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_ix = l_ov_ix + 1 + ov_idx(l_ov_ix) = -1 + call psb_transfer(ov_idx,desc%ovrlap_index,info) + if (info == 0) call psb_transfer(ov_el,desc%ovrlap_elem,info) + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + + +end subroutine psi_bld_tmpovrl diff --git a/base/internals/psi_compute_size.f90 b/base/internals/psi_compute_size.f90 index 6e269d03..b66a69d4 100644 --- a/base/internals/psi_compute_size.f90 +++ b/base/internals/psi_compute_size.f90 @@ -84,9 +84,9 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) ! ....verify local correctness of halo_in.... i=1 - do while (index_in(i).ne.-1) + do while (index_in(i) /= -1) proc=index_in(i) - if ((proc.gt.np-1).or.(proc.lt.0)) then + if ((proc > np-1).or.(proc < 0)) then info = 115 int_err(1) = 11 int_err(2) = proc @@ -108,8 +108,8 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) dl_lda=0 do i=0,np-1 - if (counter_recv(i).gt.max_index) max_index = counter_recv(i) - if (counter_dl(i).eq.1) dl_lda = dl_lda+1 + if (counter_recv(i) > max_index) max_index = counter_recv(i) + if (counter_dl(i) == 1) dl_lda = dl_lda+1 enddo ! computing max global value of dl_lda diff --git a/base/internals/psi_crea_bnd_elem.f90 b/base/internals/psi_crea_bnd_elem.f90 index 1e896936..388ebe0e 100644 --- a/base/internals/psi_crea_bnd_elem.f90 +++ b/base/internals/psi_crea_bnd_elem.f90 @@ -113,7 +113,7 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/internals/psi_crea_ovr_elem.f90 b/base/internals/psi_crea_ovr_elem.f90 index d084c005..0befdd68 100644 --- a/base/internals/psi_crea_ovr_elem.f90 +++ b/base/internals/psi_crea_ovr_elem.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! -subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info) +subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) use psi_mod, psb_protect_name => psi_crea_ovr_elem use psb_realloc_mod @@ -51,9 +51,9 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info) implicit none ! ...parameter arrays.... - integer :: desc_overlap(:) - integer, allocatable, intent(inout) :: ovr_elem(:) - integer, intent(out) :: info + integer, intent(in) :: me, desc_overlap(:) + integer, allocatable, intent(out) :: ovr_elem(:,:) + integer, intent(out) :: info ! ...local scalars... integer :: i,pnt_new_elem,ret,j @@ -64,145 +64,77 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info) integer :: psi_exist_ovr_elem external :: psi_exist_ovr_elem - integer :: nel, ip, ix, iel, insize, err_act + integer :: nel, ip, ix, iel, insize, err_act, iproc integer, allocatable :: telem(:,:) - logical, parameter :: usetree=.false. character(len=20) :: name info = 0 name='psi_crea_ovr_elem' - + if (allocated(ovr_elem)) then - dim_ovr_elem = size(ovr_elem) + dim_ovr_elem = size(ovr_elem,1) else dim_ovr_elem = 0 endif - if (usetree) then - - ! - ! This is now here just for historical reasons. - ! - ! While running through the column indices exchanged with other procs - ! we have 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 dim_ovr_elem) then - dim_ovr_elem=max(((3*dim_ovr_elem)/2+2),pnt_new_elem+100) - call psb_realloc(dim_ovr_elem,ovr_elem,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - endif - ovr_elem(pnt_new_elem)=desc_overlap(i+j) - ovr_elem(pnt_new_elem+1)=2 - pnt_new_elem=pnt_new_elem+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. - ! And fix the size to the minimum necessary. - dim_ovr_elem=pnt_new_elem - call psb_realloc(dim_ovr_elem,ovr_elem,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - ovr_elem(pnt_new_elem)=-1 - call freepairsearchtree(pairtree) - - else if (.not.usetree) then - - ! Simple alternative. - insize = size(desc_overlap) - insize = max(1,(insize+1)/2) - allocate(telem(insize,2),stat=info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - i = 1 - nel = 0 - do while (desc_overlap(i).ne.-1) - ! ...loop over all procs of desc_overlap list.... - - i=i+1 - do j=1,desc_overlap(i) - nel = nel + 1 - telem(nel,1) = desc_overlap(i+j) - enddo - i=i+2*desc_overlap(i)+2 + insize = size(desc_overlap) + insize = max(1,(insize+1)/2) + allocate(telem(insize,3),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + i = 1 + nel = 0 + do while (desc_overlap(i) /= -1) + ! ...loop over all procs of desc_overlap list.... + iproc = desc_overlap(i) + i = i+1 + do j=1,desc_overlap(i) + nel = nel + 1 + telem(nel,1) = desc_overlap(i+j) + telem(nel,2) = 1 + telem(nel,3) = iproc enddo - if (nel > 0) then - call psb_msort(telem(1:nel,1)) - iel = telem(1,1) - telem(1,2) = 2 - ix = 1 - ip = 2 - do - if (ip > nel) exit - if (telem(ip,1) == iel) then - telem(ix,2) = telem(ix,2) + 1 - else - ix = ix + 1 - telem(ix,1) = telem(ip,1) - iel = telem(ip,1) - telem(ix,2) = 2 - end if - ip = ip + 1 - end do - else - ix = 0 - end if - dim_ovr_elem=2*ix+1 - call psb_realloc(dim_ovr_elem,ovr_elem,info) - iel = 1 - do i=1, ix - ovr_elem(iel) = telem(i,1) - ovr_elem(iel+1) = telem(i,2) - iel = iel + 2 + i=i+2*desc_overlap(i)+2 + enddo + + if (nel > 0) then + call psb_msort(telem(1:nel,1),ix=telem(1:nel,3),flag=psb_sort_keep_idx_) + + iel = telem(1,1) + telem(1,2) = 2 + telem(1,3) = min(me,telem(1,3)) + ix = 1 + ip = 2 + do + if (ip > nel) exit + if (telem(ip,1) == iel) then + telem(ix,2) = telem(ix,2) + 1 + telem(ix,3) = min(telem(ix,3),telem(ip,3)) + else + ix = ix + 1 + telem(ix,1) = telem(ip,1) + iel = telem(ip,1) + telem(ix,2) = 2 + telem(ix,3) = min(me,telem(ip,3)) + end if + ip = ip + 1 end do - ovr_elem(iel) = -1 - deallocate(telem) - endif + else + ix = 0 + end if + + nel = ix + + call psb_realloc(nel,3,telem,info) + call psb_transfer(telem,ovr_elem,info) + call psb_erractionrestore(err_act) return diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index 3fdbe38b..4f1cf68c 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -330,7 +330,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_dl_check.f90 b/base/internals/psi_dl_check.f90 index 171c9cf5..dd6f770f 100644 --- a/base/internals/psi_dl_check.f90 +++ b/base/internals/psi_dl_check.f90 @@ -65,7 +65,7 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) outer: do if (i >length_dl(proc)) exit outer proc2=dep_list(i,proc) - if (proc2.ne.-1) then + if (proc2 /= -1) then ! ...search proc in proc2's dep_list.... j=1 p2loop:do diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 9588c180..a7cde9d6 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -86,7 +86,7 @@ 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 psi_gthsct_mod +!!$ use psi_gthsct_mod #ifdef MPI_MOD use mpi #endif @@ -559,7 +559,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 9c471119..992dfb09 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -89,7 +89,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif @@ -557,7 +557,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif diff --git a/base/internals/psi_exist_ovr_elem.f b/base/internals/psi_exist_ovr_elem.f index 6d0ecb8d..21ac4e1f 100644 --- a/base/internals/psi_exist_ovr_elem.f +++ b/base/internals/psi_exist_ovr_elem.f @@ -52,7 +52,7 @@ C ELEM_SEARCHED.....:point's Local index identifier to be searched. IMPLICIT NONE C ...Array Parameters.... - INTEGER OVR_ELEM(*) + INTEGER OVR_ELEM(dim_list,*) C ....Scalars parameters.... INTEGER DIM_LIST,ELEM_SEARCHED @@ -61,10 +61,10 @@ C ...Local Scalars.... INTEGER I I=1 - DO WHILE ((I.LE.DIM_LIST).AND.(OVR_ELEM(I).NE.ELEM_SEARCHED)) - I=I+2 + DO WHILE ((I.LE.DIM_LIST).AND.(OVR_ELEM(I,1).NE.ELEM_SEARCHED)) + I=I+1 ENDDO - IF ((I.LE.DIM_LIST).AND.(OVR_ELEM(I).EQ.ELEM_SEARCHED)) THEN + IF ((I.LE.DIM_LIST).AND.(OVR_ELEM(I,1).EQ.ELEM_SEARCHED)) THEN PSI_EXIST_OVR_ELEM=I ELSE PSI_EXIST_OVR_ELEM=-1 diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index 9b6babac..2dcc451f 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -172,7 +172,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& if ((desc_str(i+1) /= 0).or.(desc_str(i+2) /= 0)) then ! ..if number of element to be exchanged !=0 proc=desc_str(i) - if ((proc < 0).or.(proc.ge.nprow)) then + if ((proc < 0).or.(proc >= nprow)) then if (debug_level >= psb_debug_inner_)& & write(debug_unit,*) me,' ',trim(name),': error ',i,desc_str(i) info = 9999 @@ -196,7 +196,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& pointer_dep_list=pointer_dep_list+1 endif else if (mode == 0) then - if (pointer_dep_list.gt.dl_lda) then + if (pointer_dep_list > dl_lda) then info = 4000 goto 998 endif @@ -227,7 +227,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& enddo if (j == pointer_dep_list) then ! ...if not found..... - if (pointer_dep_list.gt.dl_lda) then + if (pointer_dep_list > dl_lda) then info = 4000 goto 998 endif @@ -235,7 +235,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& pointer_dep_list=pointer_dep_list+1 endif else if (mode == 0) then - if (pointer_dep_list.gt.dl_lda) then + if (pointer_dep_list > dl_lda) then info = 4000 goto 998 endif diff --git a/base/internals/psi_fnd_owner.f90 b/base/internals/psi_fnd_owner.f90 index 60d56183..71afb113 100644 --- a/base/internals/psi_fnd_owner.f90 +++ b/base/internals/psi_fnd_owner.f90 @@ -158,7 +158,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_gthsct_mod.f90 b/base/internals/psi_gthsct_mod.f90 deleted file mode 100644 index 85495d47..00000000 --- a/base/internals/psi_gthsct_mod.f90 +++ /dev/null @@ -1,369 +0,0 @@ -!!$ -!!$ 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. -!!$ -!!$ -! File: psi_gthsct_mod.f90 -! -! Module: psi_gth_scr_mod -! Provides pack/unpack routines for usage in the data exchange. -! The unpack routines take a BETA argument to have a unified treatment of -! simple receives with overwriting, and receives with sum (for overlap) -! -! -module psi_gthsct_mod - - interface psi_gth - module procedure psi_igthm, psi_igthv,& - & psi_dgthm, psi_dgthv,& - & psi_zgthm, psi_zgthv - end interface - - interface psi_sct - module procedure psi_isctm, psi_isctv,& - & psi_dsctm, psi_dsctv,& - & psi_zsctm, psi_zsctv - end interface - -contains - - subroutine psi_dgthm(n,k,idx,x,y) - - use psb_const_mod - 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 subroutine psi_dgthm - - subroutine psi_dgthv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(kind(1.d0)) :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_dgthv - - - subroutine psi_dsctm(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == dzero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == done) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - 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) - end do - end do - end if - end subroutine psi_dsctm - - subroutine psi_dsctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(kind(1.d0)) :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == dzero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == done) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if - end subroutine psi_dsctv - - - subroutine psi_igthm(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - integer :: 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 subroutine psi_igthm - - - subroutine psi_igthv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - integer :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_igthv - - - - subroutine psi_isctm(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == izero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == ione) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - 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) - end do - end do - end if - end subroutine psi_isctm - - subroutine psi_isctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - integer :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == izero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == ione) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if - end subroutine psi_isctv - - - subroutine psi_zgthm(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - complex(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 subroutine psi_zgthm - - - subroutine psi_zgthv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(kind(1.d0)) :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_zgthv - - subroutine psi_zsctm(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == zzero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == zone) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - 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) - end do - end do - end if - end subroutine psi_zsctm - - - subroutine psi_zsctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(kind(1.d0)) :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == zzero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == zone) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - 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 module psi_gthsct_mod diff --git a/base/internals/psi_idx_cnv.f90 b/base/internals/psi_idx_cnv.f90 index bbcf1ac2..ab22ec1b 100644 --- a/base/internals/psi_idx_cnv.f90 +++ b/base/internals/psi_idx_cnv.f90 @@ -143,7 +143,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -362,7 +362,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_idx_ins_cnv.f90 b/base/internals/psi_idx_ins_cnv.f90 index 561b298c..e112987d 100644 --- a/base/internals/psi_idx_ins_cnv.f90 +++ b/base/internals/psi_idx_ins_cnv.f90 @@ -139,7 +139,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -332,7 +332,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) cycle endif k = desc%glob_to_loc(ip) - if (k.lt.-np) then + if (k < -np) then k = k + np k = - k - 1 ncol = ncol + 1 @@ -352,7 +352,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) endif desc%loc_to_glob(ncol) = ip isize = size(desc%halo_index) - if ((pnt_halo+3).gt.isize) then + if ((pnt_halo+3) > isize) then nh = isize + max(nv,relocsz) call psb_realloc(nh,desc%halo_index,info,pad=-1) if (info /= 0) then @@ -390,7 +390,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 1de81c42..fe07e892 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -85,7 +85,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif @@ -558,7 +558,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index 46e31ab0..a2538ccf 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -89,7 +89,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif @@ -556,7 +556,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif diff --git a/base/internals/psi_ldsc_pre_halo.f90 b/base/internals/psi_ldsc_pre_halo.f90 index d241ae3c..25a147b6 100644 --- a/base/internals/psi_ldsc_pre_halo.f90 +++ b/base/internals/psi_ldsc_pre_halo.f90 @@ -107,7 +107,7 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index ff997826..cea78147 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -85,7 +85,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif @@ -558,7 +558,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 7293b1ee..5c926255 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -89,7 +89,7 @@ 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 psi_gthsct_mod #ifdef MPI_MOD use mpi #endif @@ -553,10 +553,11 @@ end subroutine psi_zswaptranm ! subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) + use psi_mod, psb_protect_name => psi_zswaptranv use psb_error_mod use psb_descriptor_type use psb_penv_mod - use psi_gthsct_mod +!!$ use psi_gthsct_mod #ifdef MPI_MOD use mpi #endif diff --git a/base/modules/psb_comm_mod.f90 b/base/modules/psb_comm_mod.f90 index b790e0e9..07660d27 100644 --- a/base/modules/psb_comm_mod.f90 +++ b/base/modules/psb_comm_mod.f90 @@ -31,204 +31,220 @@ module psb_comm_mod interface psb_ovrl - subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_descriptor_type - real(kind(1.d0)), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(kind(1.d0)), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,jx,ik,mode - end subroutine psb_dovrlm - subroutine psb_dovrlv(x,desc_a,info,work,update,mode) - use psb_descriptor_type - real(kind(1.d0)), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(kind(1.d0)), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,mode - end subroutine psb_dovrlv - subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_descriptor_type - complex(kind(1.d0)), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - complex(kind(1.d0)), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,jx,ik,mode - end subroutine psb_zovrlm - subroutine psb_zovrlv(x,desc_a,info,work,update,mode) - use psb_descriptor_type - complex(kind(1.d0)), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - complex(kind(1.d0)), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,mode - end subroutine psb_zovrlv + subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + real(kind(1.d0)), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + end subroutine psb_dovrlm + subroutine psb_dovrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + real(kind(1.d0)), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,mode + end subroutine psb_dovrlv + subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + integer, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + end subroutine psb_iovrlm + subroutine psb_iovrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + integer, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,mode + end subroutine psb_iovrlv + subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + complex(kind(1.d0)), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(kind(1.d0)), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + end subroutine psb_zovrlm + subroutine psb_zovrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + complex(kind(1.d0)), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(kind(1.d0)), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,mode + end subroutine psb_zovrlv end interface interface psb_halo - subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) - use psb_descriptor_type - real(kind(1.d0)), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(kind(1.d0)), intent(in), optional :: alpha - real(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_dhalom - subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) - use psb_descriptor_type - real(kind(1.d0)), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(kind(1.d0)), intent(in), optional :: alpha - real(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_dhalov - subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) - use psb_descriptor_type - integer, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(kind(1.d0)), intent(in), optional :: alpha - integer, intent(inout), optional :: work(:) - integer, intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_ihalom - subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) - use psb_descriptor_type - integer, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(kind(1.d0)), intent(in), optional :: alpha - integer, intent(inout), optional :: work(:) - integer, intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_ihalov - subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) - use psb_descriptor_type - complex(kind(1.d0)), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - complex(kind(1.d0)), intent(in), optional :: alpha - complex(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_zhalom - subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) - use psb_descriptor_type - complex(kind(1.d0)), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - complex(kind(1.d0)), intent(in), optional :: alpha - complex(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_zhalov + subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + real(kind(1.d0)), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(in), optional :: alpha + real(kind(1.d0)), target, optional :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_dhalom + subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + real(kind(1.d0)), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(in), optional :: alpha + real(kind(1.d0)), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_dhalov + subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + integer, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(in), optional :: alpha + integer, intent(inout), optional :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_ihalom + subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + integer, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(kind(1.d0)), intent(in), optional :: alpha + integer, intent(inout), optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_ihalov + subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + complex(kind(1.d0)), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(kind(1.d0)), intent(in), optional :: alpha + complex(kind(1.d0)), target, optional :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_zhalom + subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + complex(kind(1.d0)), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(kind(1.d0)), intent(in), optional :: alpha + complex(kind(1.d0)), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_zhalov end interface interface psb_dscatter - subroutine psb_dscatterm(globx, locx, desc_a, info, root) - use psb_descriptor_type - real(kind(1.d0)), intent(out) :: locx(:,:) - real(kind(1.d0)), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_dscatterm - subroutine psb_dscatterv(globx, locx, desc_a, info, root) - use psb_descriptor_type - real(kind(1.d0)), intent(out) :: locx(:) - real(kind(1.d0)), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_dscatterv - subroutine psb_zscatterm(globx, locx, desc_a, info, root) - use psb_descriptor_type - complex(kind(1.d0)), intent(out) :: locx(:,:) - complex(kind(1.d0)), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_zscatterm - subroutine psb_zscatterv(globx, locx, desc_a, info, root) - use psb_descriptor_type - complex(kind(1.d0)), intent(out) :: locx(:) - complex(kind(1.d0)), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_zscatterv - subroutine psb_iscatterm(globx, locx, desc_a, info, root) - use psb_descriptor_type - integer, intent(out) :: locx(:,:) - integer, intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_iscatterm - subroutine psb_iscatterv(globx, locx, desc_a, info, root) - use psb_descriptor_type - integer, intent(out) :: locx(:) - integer, intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_iscatterv + subroutine psb_dscatterm(globx, locx, desc_a, info, root) + use psb_descriptor_type + real(kind(1.d0)), intent(out) :: locx(:,:) + real(kind(1.d0)), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_dscatterm + subroutine psb_dscatterv(globx, locx, desc_a, info, root) + use psb_descriptor_type + real(kind(1.d0)), intent(out) :: locx(:) + real(kind(1.d0)), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_dscatterv + subroutine psb_zscatterm(globx, locx, desc_a, info, root) + use psb_descriptor_type + complex(kind(1.d0)), intent(out) :: locx(:,:) + complex(kind(1.d0)), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_zscatterm + subroutine psb_zscatterv(globx, locx, desc_a, info, root) + use psb_descriptor_type + complex(kind(1.d0)), intent(out) :: locx(:) + complex(kind(1.d0)), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_zscatterv + subroutine psb_iscatterm(globx, locx, desc_a, info, root) + use psb_descriptor_type + integer, intent(out) :: locx(:,:) + integer, intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_iscatterm + subroutine psb_iscatterv(globx, locx, desc_a, info, root) + use psb_descriptor_type + integer, intent(out) :: locx(:) + integer, intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_iscatterv end interface interface psb_gather - subroutine psb_igatherm(globx, locx, desc_a, info, root) - use psb_descriptor_type - integer, intent(in) :: locx(:,:) - integer, intent(out) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_igatherm - subroutine psb_igatherv(globx, locx, desc_a, info, root) - use psb_descriptor_type - integer, intent(in) :: locx(:) - integer, intent(out) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_igatherv - subroutine psb_dgatherm(globx, locx, desc_a, info, root) - use psb_descriptor_type - real(kind(1.d0)), intent(in) :: locx(:,:) - real(kind(1.d0)), intent(out) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_dgatherm - subroutine psb_dgatherv(globx, locx, desc_a, info, root) - use psb_descriptor_type - real(kind(1.d0)), intent(in) :: locx(:) - real(kind(1.d0)), intent(out) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_dgatherv - subroutine psb_zgatherm(globx, locx, desc_a, info, root) - use psb_descriptor_type - complex(kind(1.d0)), intent(in) :: locx(:,:) - complex(kind(1.d0)), intent(out) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_zgatherm - subroutine psb_zgatherv(globx, locx, desc_a, info, root) - use psb_descriptor_type - complex(kind(1.d0)), intent(in) :: locx(:) - complex(kind(1.d0)), intent(out) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, intent(in), optional :: root - end subroutine psb_zgatherv + subroutine psb_igatherm(globx, locx, desc_a, info, root) + use psb_descriptor_type + integer, intent(in) :: locx(:,:) + integer, intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_igatherm + subroutine psb_igatherv(globx, locx, desc_a, info, root) + use psb_descriptor_type + integer, intent(in) :: locx(:) + integer, intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_igatherv + subroutine psb_dgatherm(globx, locx, desc_a, info, root) + use psb_descriptor_type + real(kind(1.d0)), intent(in) :: locx(:,:) + real(kind(1.d0)), intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_dgatherm + subroutine psb_dgatherv(globx, locx, desc_a, info, root) + use psb_descriptor_type + real(kind(1.d0)), intent(in) :: locx(:) + real(kind(1.d0)), intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_dgatherv + subroutine psb_zgatherm(globx, locx, desc_a, info, root) + use psb_descriptor_type + complex(kind(1.d0)), intent(in) :: locx(:,:) + complex(kind(1.d0)), intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_zgatherm + subroutine psb_zgatherv(globx, locx, desc_a, info, root) + use psb_descriptor_type + complex(kind(1.d0)), intent(in) :: locx(:) + complex(kind(1.d0)), intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_zgatherv end interface - + end module psb_comm_mod diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index e70bae74..799c72d3 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -266,7 +266,7 @@ module psb_descriptor_type integer, allocatable :: halo_index(:), ext_index(:) integer, allocatable :: bnd_elem(:) integer, allocatable :: ovrlap_index(:) - integer, allocatable :: ovrlap_elem(:) + integer, allocatable :: ovrlap_elem(:,:) integer, allocatable :: loc_to_glob(:) integer, allocatable :: glob_to_loc (:) integer, allocatable :: hashv(:), glb_lc(:,:), ptree(:) diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index ad38bdd6..9983f380 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -222,7 +222,7 @@ contains new_node%next => error_stack%top error_stack%top => new_node error_stack%n_elems = error_stack%n_elems+1 - if(error_status.eq.0) error_status=1 + if(error_status == 0) error_status=1 nullify(new_node) end subroutine psb_errpush @@ -246,7 +246,7 @@ contains old_node => error_stack%top error_stack%top => old_node%next error_stack%n_elems = error_stack%n_elems - 1 - if(error_stack%n_elems.eq.0) error_status=0 + if(error_stack%n_elems == 0) error_status=0 deallocate(old_node) @@ -266,10 +266,10 @@ contains integer, parameter :: ione=1, izero=0 - if(error_status.gt.0) then - if(verbosity_level.gt.1) then + if(error_status > 0) then + if(verbosity_level > 1) then - do while (error_stack%n_elems.gt.izero) + do while (error_stack%n_elems > izero) write(0,'(50("="))') call psb_errpop(err_c, r_name, i_e_d, a_e_d) call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) @@ -284,7 +284,7 @@ contains call psb_errpop(err_c, r_name, i_e_d, a_e_d) call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) - do while (error_stack%n_elems.gt.0) + do while (error_stack%n_elems > 0) call psb_errpop(err_c, r_name, i_e_d, a_e_d) end do #if defined(SERIAL_MPI) @@ -295,7 +295,7 @@ contains end if end if - if(error_status.gt.izero) then + if(error_status > izero) then #if defined(SERIAL_MPI) stop #else @@ -316,10 +316,10 @@ contains integer :: i_e_d(5) integer, parameter :: ione=1, izero=0 - if(error_status.gt.0) then - if(verbosity_level.gt.1) then + if(error_status > 0) then + if(verbosity_level > 1) then - do while (error_stack%n_elems.gt.izero) + do while (error_stack%n_elems > izero) write(0,'(50("="))') call psb_errpop(err_c, r_name, i_e_d, a_e_d) call psb_errmsg(err_c, r_name, i_e_d, a_e_d) @@ -330,7 +330,7 @@ contains call psb_errpop(err_c, r_name, i_e_d, a_e_d) call psb_errmsg(err_c, r_name, i_e_d, a_e_d) - do while (error_stack%n_elems.gt.0) + do while (error_stack%n_elems > 0) call psb_errpop(err_c, r_name, i_e_d, a_e_d) end do end if diff --git a/base/modules/psb_gps_mod.f90 b/base/modules/psb_gps_mod.f90 index e10d2482..3034673b 100644 --- a/base/modules/psb_gps_mod.f90 +++ b/base/modules/psb_gps_mod.f90 @@ -62,11 +62,11 @@ CONTAINS ! INDICES OF THE NONZERO ELEMENTS OF THE MATRIX, A. THE ALGO- ! RITHM IS DESCRIBED IN TERMS OF THE ADJACENCY GRAPH WHICH ! HAS THE CHARACTERISTIC THAT THERE IS AN EDGE (CONNECTION) - ! BETWEEN NODES I AND J IF A(I,J) .NE. 0 AND I .NE. J. + ! BETWEEN NODES I AND J IF A(I,J) /= 0 AND I /= J. ! DIMENSIONING INFORMATION--THE FOLLOWING INTEGER ARRAYS MUST BE ! DIMENSIONED IN THE CALLING ROUTINE. - ! NDSTK(NR,D1) D1 IS .GE. MAXIMUM DEGREE OF ALL NODES. - ! IOLD(D2) D2 AND NR ARE .GE. THE TOTAL NUMBER OF + ! NDSTK(NR,D1) D1 IS >= MAXIMUM DEGREE OF ALL NODES. + ! IOLD(D2) D2 AND NR ARE >= THE TOTAL NUMBER OF ! RENUM(D2+1) NODES IN THE GRAPH. ! NDEG(D2) STORAGE REQUIREMENTS CAN BE SIGNIFICANTLY ! LVL(D2) DECREASED FOR IBM 360 AND 370 COMPUTERS @@ -146,7 +146,7 @@ CONTAINS STNUM = N ! NUMBER THE NODES OF DEGREE ZERO DO I=1,N - IF (NDEG(I).GT.0) CYCLE + IF (NDEG(I) > 0) CYCLE RENUM(I) = STNUM STNUM = STNUM - 1 END DO @@ -156,8 +156,8 @@ CONTAINS NFLG = 1 ISDIR = 1 DO I=1,N - IF (NDEG(I).GE.LOWDG) CYCLE - IF (RENUM(I).GT.0) CYCLE + IF (NDEG(I) >= LOWDG) CYCLE + IF (RENUM(I) > 0) CYCLE LOWDG = NDEG(I) STNODE = I END DO @@ -165,7 +165,7 @@ CONTAINS ! STNODE AND RVNODE ARE THE ENDS OF THE DIAM AND LVLS1 AND LVLS2 ! ARE THE RESPECTIVE LEVEL STRUCTURES. CALL FNDIAM(STNODE, RVNODE, NDSTK, NR, NDEG, LVL, LVLS1,LVLS2, CCSTOR, IDFLT) - IF (.not.(ndeg(stnode).le.ndeg(rvnode))) then + IF (.not.(ndeg(stnode) <= ndeg(rvnode))) then ! NFLG INDICATES THE END TO BEGIN NUMBERING ON NFLG = -1 STNODE = RVNODE @@ -176,7 +176,7 @@ CONTAINS LROOT = 1 LVLN = 1 DO I=1,N - IF (LVL(I).NE.0) CYCLE + IF (LVL(I) /= 0) CYCLE XCC = XCC + 1 STPT(XCC) = LROOT CALL TREE(I, NDSTK, NR, LVL, CCSTOR, NDEG, LVLWTH, LVLBOT,LVLN, MAXLW, N) @@ -192,13 +192,13 @@ CONTAINS ! DIRECTION. NUM IS SET TO THE PROPER VALUE FOR THIS DIRECTION. ISDIR = ISDIR*NFLG NUM = SBNUM - IF (ISDIR.LT.0) NUM = STNUM + IF (ISDIR < 0) NUM = STNUM CALL NUMBER(STNODE, NUM, NDSTK, LVLS2, NDEG, RENUM, LVLS1,LVL,& & NR, NFLG, IBW2, IPF2, CCSTOR, ISDIR) ! UPDATE STNUM OR SBNUM AFTER NUMBERING - IF (ISDIR.LT.0) STNUM = NUM - IF (ISDIR.GT.0) SBNUM = NUM - IF (.not.(sbnum.le.stnum)) exit + IF (ISDIR < 0) STNUM = NUM + IF (ISDIR > 0) SBNUM = NUM + IF (.not.(sbnum <= stnum)) exit end do IF (IBW2 > IBW1) then ! IF ORIGINAL NUMBERING IS BETTER THAN NEW ONE, SET UP TO RETURN IT @@ -233,10 +233,10 @@ CONTAINS IF(ITST <= 0) EXIT NDEG(I) = NDEG(I) + 1 IDIF = IOLD(I) - IOLD(ITST) - IF (IRW.LT.IDIF) IRW = IDIF + IF (IRW < IDIF) IRW = IDIF END DO IPF1 = IPF1 + IRW - IF (IRW.GT.IBW1) IBW1 = IRW + IF (IRW > IBW1) IBW1 = IRW END DO RETURN END SUBROUTINE DGREE @@ -251,7 +251,7 @@ CONTAINS ! LVLS1- ARRAY CONTAINING LEVEL STRUCTURE WITH SND1 AS ROOT ! LVLS2- ARRAY CONTAINING LEVEL STRUCTURE WITH SND2 AS ROOT ! IDFLT- FLAG USED IN PICKING FINAL LEVEL STRUCTURE, SET - ! =1 IF WIDTH OF LVLS1 .LE. WIDTH OF LVLS2, OTHERWISE =2 + ! =1 IF WIDTH OF LVLS1 <= WIDTH OF LVLS2, OTHERWISE =2 ! LVL,IWK- WORKING STORAGE ! USE INTEGER*2 NDSTK WITH AN IBM 360 OR 370. INTEGER NDSTK @@ -274,7 +274,7 @@ CONTAINS LVLN = 1 ! DROP A TREE FROM SND CALL TREE(SND, NDSTK, NR, LVL, IWK, NDEG, LVLWTH, LVLBOT,LVLN, MAXLW, MTW2) - IF (FLAG.GE.1) GO TO 50 + IF (FLAG >= 1) GO TO 50 FLAG = 1 30 IDPTH = LVLN - 1 MTW1 = MAXLW @@ -289,24 +289,24 @@ CONTAINS CALL SORTDG(NDLST, IWK(LVLBOT), NDXL, LVLWTH, NDEG) SND = NDLST(1) GO TO 10 -50 IF (IDPTH.GE.LVLN-1) GO TO 60 +50 IF (IDPTH >= LVLN-1) GO TO 60 ! START AGAIN WITH NEW STARTING NODE SND1 = SND GO TO 30 -60 IF (MAXLW.GE.MTW2) GO TO 80 +60 IF (MAXLW >= MTW2) GO TO 80 MTW2 = MAXLW SND2 = SND ! STORE NARROWEST REVERSE LEVEL STRUCTURE IN LVLS2 DO 70 I=1,N LVLS2(I) = LVL(I) 70 END DO -80 IF (NDXN.EQ.NDXL) GO TO 90 +80 IF (NDXN == NDXL) GO TO 90 ! TRY NEXT NODE IN NDLST NDXN = NDXN + 1 SND = NDLST(NDXN) GO TO 10 90 IDFLT = 1 - IF (MTW2.LE.MTW1) IDFLT = 2 + IF (MTW2 <= MTW1) IDFLT = 2 NULLIFY(NDLST) RETURN END SUBROUTINE FNDIAM @@ -328,7 +328,7 @@ CONTAINS ! CONNECTED COMPONENTS, LVLN IS NEXT AVAILABLE LOCATION. ! ON OUTPUT THE TOTAL NUMBER OF LEVELS + 1 ! IBORT- INPUT PARAM WHICH TRIGGERS EARLY RETURN IF - ! MAXLW BECOMES .GE. IBORT + ! MAXLW BECOMES >= IBORT ! USE INTEGER*2 NDSTK WITH AN IBM 360 OR 370. INTEGER NDSTK DIMENSION NDSTK(NR,IDEG), LVL(N), IWK(N), NDEG(N) @@ -345,17 +345,17 @@ CONTAINS NDROW = NDEG(IWKNOW) DO 30 J=1,NDROW ITEST = NDSTK(IWKNOW,J) - IF (LVL(ITEST).NE.0) CYCLE + IF (LVL(ITEST) /= 0) CYCLE LVL(ITEST) = LVLN ITOP = ITOP + 1 IWK(ITOP) = ITEST 30 END DO INOW = INOW + 1 - IF (INOW.LT.LVLTOP) GO TO 20 + IF (INOW < LVLTOP) GO TO 20 LVLWTH = LVLTOP - LVLBOT - IF (MAXLW.LT.LVLWTH) MAXLW = LVLWTH - IF (MAXLW.GE.IBORT) RETURN - IF (ITOP.LT.LVLTOP) RETURN + IF (MAXLW < LVLWTH) MAXLW = LVLWTH + IF (MAXLW >= IBORT) RETURN + IF (ITOP < LVLTOP) RETURN LVLBOT = INOW LVLTOP = ITOP + 1 GO TO 10 @@ -371,18 +371,18 @@ CONTAINS IND = X2 10 ITEST = 0 IND = IND - 1 - IF (IND.LT.1) GO TO 30 + IF (IND < 1) GO TO 30 DO 20 I=1,IND J = I + 1 ISTK2 = STK2(I) JSTK2 = STK2(J) - IF (NDEG(ISTK2).LE.NDEG(JSTK2)) CYCLE + IF (NDEG(ISTK2) <= NDEG(JSTK2)) CYCLE ITEST = 1 TEMP = STK2(I) STK2(I) = STK2(J) STK2(J) = TEMP 20 END DO - IF (ITEST.EQ.1) GO TO 10 + IF (ITEST == 1) GO TO 10 30 DO 40 I=1,X2 X1 = X1 + 1 STK1(X1) = STK2(I) @@ -403,7 +403,7 @@ CONTAINS INTEGER :: SZ !----------------------------------------------------- SZ=SIZE(NACUM) - IF(SZ .LT. IDPTH) THEN + IF(SZ < IDPTH) THEN WRITE(*,*) 'GPS_SETUP: on fly reallocation of NACUM' CALL REALLOC(NACUM,SZ,IDPTH) END IF @@ -415,8 +415,8 @@ CONTAINS LVL(I) = 1 LVLS2(I) = IDPTH + 1 - LVLS2(I) ITEMP = LVLS2(I) - IF (ITEMP.GT.IDPTH) CYCLE - IF (ITEMP.NE.LVLS1(I)) GO TO 20 + IF (ITEMP > IDPTH) CYCLE + IF (ITEMP /= LVLS1(I)) GO TO 20 NACUM(ITEMP) = NACUM(ITEMP) + 1 CYCLE 20 LVL(I) = 0 @@ -432,15 +432,15 @@ CONTAINS !COMMON /CC/ XCC, SIZEG(50), STPT(50) SORT2 = 0 - IF (XCC.EQ.0) RETURN + IF (XCC == 0) RETURN SORT2 = 1 IND = XCC 10 ITEST = 0 IND = IND - 1 - IF (IND.LT.1) RETURN + IF (IND < 1) RETURN DO 20 I=1,IND J = I + 1 - IF (SIZEG(I).GE.SIZEG(J)) CYCLE + IF (SIZEG(I) >= SIZEG(J)) CYCLE ITEST = 1 TEMP = SIZEG(I) SIZEG(I) = SIZEG(J) @@ -449,7 +449,7 @@ CONTAINS STPT(I) = STPT(J) STPT(J) = TEMP 20 END DO - IF (ITEST.EQ.1) GO TO 10 + IF (ITEST == 1) GO TO 10 RETURN END FUNCTION SORT2 ! @@ -459,7 +459,7 @@ CONTAINS ! LVLS2- ON INPUT CONTAINS REVERSE LEVELING INFO ! ON OUTPUT THE FINAL LEVEL STRUCTURE CHOSEN ! CCSTOR- ON INPUT CONTAINS CONNECTED COMPONENT INFO - ! IDFLT- ON INPUT =1 IF WDTH LVLS1.LE.WDTH LVLS2, =2 OTHERWISE + ! IDFLT- ON INPUT =1 IF WDTH LVLS1 <= WDTH LVLS2, =2 OTHERWISE ! NHIGH KEEPS TRACK OF LEVEL WIDTHS FOR HIGH NUMBERING ! NLOW- KEEPS TRACK OF LEVEL WIDTHS FOR LOW NUMBERING ! NACUM- KEEPS TRACK OF LEVEL WIDTHS FOR CHOSEN LEVEL STRUCTURE @@ -483,12 +483,12 @@ CONTAINS ! SET NHIGH AND NLOW EQUAL TO NACUM !----------------------------------------------------- SZ=SIZE(NHIGH) - IF(SZ .LT. IDPTH) THEN + IF(SZ < IDPTH) THEN WRITE(*,*) 'GPS_PIKLVL: on fly reallocation of NHIGH' CALL REALLOC(NHIGH,SZ,IDPTH) END IF SZ=SIZE(NLOW) - IF(SZ .LT. IDPTH) THEN + IF(SZ < IDPTH) THEN WRITE(*,*) 'GPS_PIKLVL: on fly reallocation of NLOW' CALL REALLOC(NLOW,SZ,IDPTH) END IF @@ -510,16 +510,16 @@ CONTAINS ! SET MAX1=LARGEST NEW NUMBER IN NHIGH ! SET MAX2=LARGEST NEW NUMBER IN NLOW DO 30 K=1,IDPTH - IF (2*NACUM(K).EQ.NLOW(K)+NHIGH(K)) CYCLE - IF (NHIGH(K).GT.MAX1) MAX1 = NHIGH(K) - IF (NLOW(K).GT.MAX2) MAX2 = NLOW(K) + IF (2*NACUM(K) == NLOW(K)+NHIGH(K)) CYCLE + IF (NHIGH(K) > MAX1) MAX1 = NHIGH(K) + IF (NLOW(K) > MAX2) MAX2 = NLOW(K) 30 END DO ! SET IT= NUMBER OF LEVEL STRUCTURE TO BE USED IT = 1 - IF (MAX1.GT.MAX2) IT = 2 - IF (MAX1.EQ.MAX2) IT = IDFLT - IF (IT.EQ.2) GO TO 60 - IF (I.EQ.1) ISDIR = -1 + IF (MAX1 > MAX2) IT = 2 + IF (MAX1 == MAX2) IT = IDFLT + IF (IT == 2) GO TO 60 + IF (I == 1) ISDIR = -1 ! COPY LVLS1 INTO LVLS2 FOR EACH NODE IN CONNECTED COMPONENT DO 40 K=J,ENDC INODE = CCSTOR(K) @@ -580,7 +580,7 @@ CONTAINS DO 30 I=1,IDPTH LSTPT(I) = NSTPT DO 20 J=1,N - IF (LVLS2(J).NE.I) CYCLE + IF (LVLS2(J) /= I) CYCLE LVLST(NSTPT) = J NSTPT = NSTPT + 1 20 END DO @@ -592,7 +592,7 @@ CONTAINS ! LVLN KEEPS TRACK OF THE LEVEL WE ARE WORKING AT. ! INITIALLY STKC CONTAINS ONLY THE INITIAL NODE, SND. LVLN = 0 - IF (NFLG.LT.0) LVLN = IDPTH + 1 + IF (NFLG < 0) LVLN = IDPTH + 1 XC = 1 STKC(XC) = SND 40 CX = 1 @@ -612,16 +612,16 @@ CONTAINS TEST = NDSTK(IPRO,I) INX = RENUM(TEST) ! ONLY NODES NOT NUMBERED OR ALREADY ON A STACK ARE ADDED - IF (INX.EQ.0) GO TO 60 - IF (INX.LT.0) CYCLE + IF (INX == 0) GO TO 60 + IF (INX < 0) CYCLE ! DO PRELIMINARY BANDWIDTH AND PROFILE CALCULATIONS NBW = (RENUM(IPRO)-INX)*ISDIR - IF (ISDIR.GT.0) INX = RENUM(IPRO) - IF (IPFA(INX).LT.NBW) IPFA(INX) = NBW + IF (ISDIR > 0) INX = RENUM(IPRO) + IF (IPFA(INX) < NBW) IPFA(INX) = NBW CYCLE 60 RENUM(TEST) = -1 ! PUT NODES ON SAME LEVEL ON STKA, ALL OTHERS ON STKB - IF (LVLS2(TEST).EQ.LVLS2(IPRO)) GO TO 70 + IF (LVLS2(TEST) == LVLS2(IPRO)) GO TO 70 XB = XB + 1 STKB(XB) = TEST CYCLE @@ -630,8 +630,8 @@ CONTAINS 80 END DO ! SORT STKA AND STKB INTO INCREASING DEGREE AND ADD STKA TO STKC ! AND STKB TO STKD - IF (XA.EQ.0) GO TO 100 - IF (XA.EQ.1) GO TO 90 + IF (XA == 0) GO TO 100 + IF (XA == 1) GO TO 90 !----------------------------------------------------------------- SZ1=SIZE(STKC) SZ2=XC+XA @@ -655,8 +655,8 @@ CONTAINS END IF !----------------------------------------------------------------- STKC(XC) = STKA(XA) -100 IF (XB.EQ.0) GO TO 120 - IF (XB.EQ.1) GO TO 110 +100 IF (XB == 0) GO TO 120 + IF (XB == 1) GO TO 110 !----------------------------------------------------------------- SZ1=SIZE(STKD) SZ2=XD+XB @@ -682,21 +682,21 @@ CONTAINS STKD(XD) = STKB(XB) ! BE SURE TO PROCESS ALL NODES IN STKC 120 CX = CX + 1 - IF (XC.GE.CX) GO TO 50 + IF (XC >= CX) GO TO 50 ! WHEN STKC IS EXHAUSTED LOOK FOR MIN DEGREE NODE IN SAME LEVEL ! WHICH HAS NOT BEEN PROCESSED MAX = IDEG + 1 SND = N + 1 DO 130 I=LST,LND TEST = LVLST(I) - IF (RENUM(TEST).NE.0) CYCLE - IF (NDEG(TEST).GE.MAX) CYCLE + IF (RENUM(TEST) /= 0) CYCLE + IF (NDEG(TEST) >= MAX) CYCLE RENUM(SND) = 0 RENUM(TEST) = -1 MAX = NDEG(TEST) SND = TEST 130 END DO - IF (SND.EQ.N+1) GO TO 140 + IF (SND == N+1) GO TO 140 XC = XC + 1 !----------------------------------------------------------------- SZ1=SIZE(STKC) @@ -712,7 +712,7 @@ CONTAINS GO TO 50 ! IF STKD IS EMPTY WE ARE DONE, OTHERWISE COPY STKD ONTO STKC ! AND BEGIN PROCESSING NEW STKC -140 IF (XD.EQ.0) GO TO 160 +140 IF (XD == 0) GO TO 160 !----------------------------------------------------------------- SZ1=SIZE(STKC) SZ2=XD @@ -730,7 +730,7 @@ CONTAINS GO TO 40 ! DO FINAL BANDWIDTH AND PROFILE CALCULATIONS 160 DO 170 I=1,N - IF (IPFA(I).GT.IBW2) IBW2 = IPFA(I) + IF (IPFA(I) > IBW2) IBW2 = IPFA(I) IPF2 = IPF2 + IPFA(I) 170 END DO ! diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index ef1e4ae8..3c19a6f2 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -96,7 +96,7 @@ Contains name='psb_cpy1d' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info = 0 if (allocated(vin)) then isz = size(vin) @@ -118,7 +118,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -143,7 +143,7 @@ Contains name='psb_cpy1d' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info = 0 if (allocated(vin)) then isz1 = size(vin,1) @@ -167,7 +167,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -192,7 +192,7 @@ Contains name='psb_cpy1d' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info = 0 if (allocated(vin)) then isz = size(vin) @@ -214,7 +214,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -239,7 +239,7 @@ Contains name='psb_cpy1d' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info = 0 if (allocated(vin)) then isz1 = size(vin,1) @@ -263,7 +263,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -288,7 +288,7 @@ Contains name='psb_cpy1d' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info = 0 if (allocated(vin)) then isz = size(vin) @@ -310,7 +310,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -335,7 +335,7 @@ Contains name='psb_cpy1d' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info = 0 if (allocated(vin)) then isz1 = size(vin,1) @@ -359,7 +359,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -473,7 +473,7 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 If (len > psb_size(v)) Then @@ -501,7 +501,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -529,7 +529,7 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 If (len > psb_size(v)) Then @@ -557,7 +557,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -585,7 +585,7 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 If (len > psb_size(v)) Then @@ -612,7 +612,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -642,7 +642,7 @@ Contains call psb_erractionsave(err_act) if (debug) write(0,*) 'reallocate I',len - if (psb_get_errstatus().ne.0) return + if (psb_get_errstatus() /= 0) return info=0 if (present(lb)) then lb_ = lb @@ -689,7 +689,7 @@ Contains info = err call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -765,7 +765,7 @@ Contains info = err call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -839,7 +839,7 @@ Contains info = err call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -932,7 +932,7 @@ Contains info = err call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -1026,7 +1026,7 @@ Contains info = err call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -1117,7 +1117,7 @@ Contains info = err call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -1140,7 +1140,7 @@ Contains name='psb_dreallocate2i' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_dreallocate1i(len,rrax,info,pad=pad) if (info /= 0) then @@ -1160,7 +1160,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -1211,7 +1211,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -1260,7 +1260,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error() diff --git a/base/modules/psb_sort_mod.f90 b/base/modules/psb_sort_mod.f90 index 763f567a..dcf21a2d 100644 --- a/base/modules/psb_sort_mod.f90 +++ b/base/modules/psb_sort_mod.f90 @@ -171,7 +171,7 @@ contains end if 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -231,7 +231,7 @@ contains end if 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -290,7 +290,7 @@ contains end if 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -330,7 +330,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -406,7 +406,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -482,7 +482,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -571,7 +571,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -681,7 +681,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -789,7 +789,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -897,7 +897,7 @@ contains 9999 continue - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/modules/psb_spmat_type.f90 b/base/modules/psb_spmat_type.f90 index 8888b726..081ffa66 100644 --- a/base/modules/psb_spmat_type.f90 +++ b/base/modules/psb_spmat_type.f90 @@ -365,7 +365,7 @@ contains if (clear_) a%aspk(:) = dzero if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then - if(a%fida(1:3).eq.'JAD') then + if(a%fida(1:3) == 'JAD') then a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 else a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 @@ -397,7 +397,7 @@ contains logical, parameter :: debug=.false. info = 0 - if (nnz.lt.0) then + if (nnz < 0) then info=45 return Endif @@ -463,7 +463,7 @@ contains logical, parameter :: debug=.false. info = 0 - if (nnz.lt.0) then + if (nnz < 0) then info=45 return endif @@ -534,7 +534,7 @@ contains logical, parameter :: debug=.false. info = 0 - if (nnz.lt.0) then + if (nnz < 0) then info=45 return endif @@ -910,7 +910,7 @@ contains if (clear_) a%aspk(:) = zzero if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then - if(a%fida(1:3).eq.'JAD') then + if(a%fida(1:3) == 'JAD') then a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 else a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 @@ -942,7 +942,7 @@ contains logical, parameter :: debug=.false. info = 0 - if (nnz.lt.0) then + if (nnz < 0) then info=45 return Endif @@ -1008,7 +1008,7 @@ contains logical, parameter :: debug=.false. info = 0 - if (nnz.lt.0) then + if (nnz < 0) then info=45 return endif @@ -1101,7 +1101,7 @@ contains integer :: ifc_ info = 0 - if (nnz.lt.0) then + if (nnz < 0) then info=45 return endif @@ -1450,14 +1450,14 @@ contains nz=0 blkfnd: do j=j+1 - if(ia1(j).eq.idx) then + if(ia1(j) == idx) then nz=nz+ia3(j)-ia2(j) ipx = ia1(j) ! the first row index of the block rb = idx-ipx ! the row offset within the block row = ia3(j)+rb nz = nz+ja(row+1)-ja(row) exit blkfnd - else if(ia1(j).gt.idx) then + else if(ia1(j) > idx) then nz=nz+ia3(j-1)-ia2(j-1) ipx = ia1(j-1) ! the first row index of the block rb = idx-ipx ! the row offset within the block @@ -1500,7 +1500,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -1605,14 +1605,14 @@ contains nz=0 blkfnd: do j=j+1 - if(ia1(j).eq.idx) then + if(ia1(j) == idx) then nz=nz+ia3(j)-ia2(j) ipx = ia1(j) ! the first row index of the block rb = idx-ipx ! the row offset within the block row = ia3(j)+rb nz = nz+ja(row+1)-ja(row) exit blkfnd - else if(ia1(j).gt.idx) then + else if(ia1(j) > idx) then nz=nz+ia3(j-1)-ia2(j-1) ipx = ia1(j-1) ! the first row index of the block rb = idx-ipx ! the row offset within the block @@ -1655,7 +1655,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index d2b4de81..b52cb7df 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -674,14 +674,15 @@ contains subroutine psb_cdasb(desc_a,info) use psb_descriptor_type - interface - subroutine psb_icdasb(desc_a,info,ext_hv) - use psb_descriptor_type - Type(psb_desc_type), intent(inout) :: desc_a - integer, intent(out) :: info - logical, intent(in),optional :: ext_hv - end subroutine psb_icdasb - end interface + + interface + subroutine psb_icdasb(desc_a,info,ext_hv) + use psb_descriptor_type + Type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + logical, intent(in),optional :: ext_hv + end subroutine psb_icdasb + end interface Type(psb_desc_type), intent(inout) :: desc_a integer, intent(out) :: info diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index e4a1edf8..276f6400 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -32,41 +32,41 @@ module psi_mod 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_crea_bnd_elem(bndel,desc_a,info) - use psb_descriptor_type - integer, allocatable :: bndel(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - end subroutine psi_crea_bnd_elem + subroutine psi_crea_bnd_elem(bndel,desc_a,info) + use psb_descriptor_type + integer, allocatable :: bndel(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_crea_bnd_elem end interface interface - subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info,nxch,nsnd,nrcv - integer, intent(in) :: index_in(:) - integer, allocatable, intent(inout) :: index_out(:) - logical :: glob_idx - end subroutine psi_crea_index + subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info,nxch,nsnd,nrcv + integer, intent(in) :: index_in(:) + integer, allocatable, intent(inout) :: index_out(:) + logical :: glob_idx + end subroutine psi_crea_index end interface interface - subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info) - integer :: desc_overlap(:) - integer, allocatable, intent(inout) :: ovr_elem(:) - integer, intent(out) :: info - end subroutine psi_crea_ovr_elem + subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) + integer, intent(in) :: me, desc_overlap(:) + integer, allocatable, intent(out) :: ovr_elem(:,:) + integer, intent(out) :: info + end subroutine psi_crea_ovr_elem end interface - + interface subroutine psi_desc_index(desc,index_in,dep_list,& & length_dl,nsnd,nrcv,desc_index,isglob_in,info) @@ -78,7 +78,7 @@ module psi_mod logical :: isglob_in end subroutine psi_desc_index end interface - + interface subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) integer :: np,dl_lda,length_dl(0:np) @@ -87,126 +87,118 @@ module psi_mod 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 psi_swapdata - subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - real(kind(1.d0)) :: y(:,:), beta - real(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_dswapdatam - subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) - use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - real(kind(1.d0)) :: y(:), beta - real(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_dswapdatav - subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - integer :: y(:,:), beta - integer, target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_iswapdatam - subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) - use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - integer :: y(:), beta - integer, target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_iswapdatav - subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - complex(kind(1.d0)) :: y(:,:), beta - complex(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_zswapdatam - subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) - use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - complex(kind(1.d0)) :: y(:), beta - complex(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_zswapdatav + subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(kind(1.d0)) :: y(:,:), beta + real(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_dswapdatam + subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + real(kind(1.d0)) :: y(:), beta + real(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_dswapdatav + subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + integer :: y(:,:), beta + integer, target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_iswapdatam + subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + integer :: y(:), beta + integer, target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_iswapdatav + subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(kind(1.d0)) :: y(:,:), beta + complex(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_zswapdatam + subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + complex(kind(1.d0)) :: y(:), beta + complex(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_zswapdatav end interface interface psi_swaptran - subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info) - use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - real(kind(1.d0)) :: y(:,:), beta - real(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - end subroutine psi_dswaptranm - subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info) - use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - real(kind(1.d0)) :: y(:), beta - real(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - end subroutine psi_dswaptranv - subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info) - use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - integer :: y(:,:), beta - integer,target :: work(:) - type(psb_desc_type), target :: desc_a - end subroutine psi_iswaptranm - subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info) - use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - integer :: y(:), beta - integer,target :: work(:) - type(psb_desc_type), target :: desc_a - end subroutine psi_iswaptranv - subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info) - use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - complex(kind(1.d0)) :: y(:,:), beta - complex(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - end subroutine psi_zswaptranm - subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info) - use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - complex(kind(1.d0)) :: y(:), beta - complex(kind(1.d0)),target :: work(:) - type(psb_desc_type), target :: desc_a - end subroutine psi_zswaptranv - end interface - - interface psi_cnv_dsc - module procedure psi_cnv_dsc - end interface - - interface psi_inner_cnv - module procedure psi_inner_cnv1, psi_inner_cnv2 + subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(kind(1.d0)) :: y(:,:), beta + real(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + end subroutine psi_dswaptranm + subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + real(kind(1.d0)) :: y(:), beta + real(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + end subroutine psi_dswaptranv + subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + integer :: y(:,:), beta + integer,target :: work(:) + type(psb_desc_type), target :: desc_a + end subroutine psi_iswaptranm + subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + integer :: y(:), beta + integer,target :: work(:) + type(psb_desc_type), target :: desc_a + end subroutine psi_iswaptranv + subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(kind(1.d0)) :: y(:,:), beta + complex(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + end subroutine psi_zswaptranm + subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + complex(kind(1.d0)) :: y(:), beta + complex(kind(1.d0)),target :: work(:) + type(psb_desc_type), target :: desc_a + end subroutine psi_zswaptranv end interface interface @@ -217,100 +209,138 @@ module psi_mod end subroutine psi_extract_dep_list end interface interface psi_fnd_owner - subroutine psi_fnd_owner(nv,idx,iprc,desc,info) - use psb_descriptor_type - integer, intent(in) :: nv - integer, intent(in) :: idx(:) - integer, allocatable, intent(out) :: iprc(:) - type(psb_desc_type), intent(in) :: desc - integer, intent(out) :: info - end subroutine psi_fnd_owner - end interface - + subroutine psi_fnd_owner(nv,idx,iprc,desc,info) + use psb_descriptor_type + integer, intent(in) :: nv + integer, intent(in) :: idx(:) + integer, allocatable, intent(out) :: iprc(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + end subroutine psi_fnd_owner + end interface + interface psi_ldsc_pre_halo - subroutine psi_ldsc_pre_halo(desc,ext_hv,info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc - logical, intent(in) :: ext_hv - integer, intent(out) :: info - end subroutine psi_ldsc_pre_halo - end interface - + subroutine psi_ldsc_pre_halo(desc,ext_hv,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc + logical, intent(in) :: ext_hv + integer, intent(out) :: info + end subroutine psi_ldsc_pre_halo + end interface + interface psi_bld_hash - subroutine psi_bld_hash(desc,info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - end subroutine psi_bld_hash - end interface - + subroutine psi_bld_hash(desc,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + end subroutine psi_bld_hash + end interface + interface psi_bld_tmphalo - subroutine psi_bld_tmphalo(desc,info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - end subroutine psi_bld_tmphalo - end interface + subroutine psi_bld_tmphalo(desc,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + end subroutine psi_bld_tmphalo + end interface + + + interface psi_bld_tmpovrl + subroutine psi_bld_tmpovrl(iv,desc,info) + use psb_descriptor_type + integer, intent(in) :: iv(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + end subroutine psi_bld_tmpovrl + end interface + interface psi_idx_cnv - subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) - use psb_descriptor_type - integer, intent(in) :: nv - integer, intent(inout) :: idxin(:) - type(psb_desc_type), intent(in) :: desc - integer, intent(out) :: info - logical, intent(in), optional, target :: mask(:) - logical, intent(in), optional :: owned - end subroutine psi_idx_cnv1 - subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) - use psb_descriptor_type - integer, intent(in) :: nv, idxin(:) - integer, intent(out) :: idxout(:) - type(psb_desc_type), intent(in) :: desc - integer, intent(out) :: info - logical, intent(in), optional, target :: mask(:) - logical, intent(in), optional :: owned - end subroutine psi_idx_cnv2 - subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned) - use psb_descriptor_type - integer, intent(in) :: idxin - integer, intent(out) :: idxout - type(psb_desc_type), intent(in) :: desc - integer, intent(out) :: info - logical, intent(in), optional, target :: mask - logical, intent(in), optional :: owned - end subroutine psi_idx_cnvs + subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) + use psb_descriptor_type + integer, intent(in) :: nv + integer, intent(inout) :: idxin(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + logical, intent(in), optional :: owned + end subroutine psi_idx_cnv1 + subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) + use psb_descriptor_type + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + logical, intent(in), optional :: owned + end subroutine psi_idx_cnv2 + subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned) + use psb_descriptor_type + integer, intent(in) :: idxin + integer, intent(out) :: idxout + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask + logical, intent(in), optional :: owned + end subroutine psi_idx_cnvs end interface interface psi_idx_ins_cnv - subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) - use psb_descriptor_type - integer, intent(in) :: nv - integer, intent(inout) :: idxin(:) - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - logical, intent(in), optional, target :: mask(:) - end subroutine psi_idx_ins_cnv1 - subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) - use psb_descriptor_type - integer, intent(in) :: nv, idxin(:) - integer, intent(out) :: idxout(:) - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - logical, intent(in), optional, target :: mask(:) - end subroutine psi_idx_ins_cnv2 - subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask) - use psb_descriptor_type - integer, intent(in) :: idxin - integer, intent(out) :: idxout - type(psb_desc_type), intent(inout) :: desc - integer, intent(out) :: info - logical, intent(in), optional, target :: mask - end subroutine psi_idx_ins_cnvs + subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) + use psb_descriptor_type + integer, intent(in) :: nv + integer, intent(inout) :: idxin(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + end subroutine psi_idx_ins_cnv1 + subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) + use psb_descriptor_type + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + end subroutine psi_idx_ins_cnv2 + subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask) + use psb_descriptor_type + integer, intent(in) :: idxin + integer, intent(out) :: idxout + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask + end subroutine psi_idx_ins_cnvs end interface + interface psi_cnv_dsc + module procedure psi_cnv_dsc + end interface + + interface psi_inner_cnv + module procedure psi_inner_cnv1, psi_inner_cnv2 + end interface + + interface psi_ovrl_upd + module procedure psi_iovrl_updr1, psi_iovrl_updr2,& + & psi_dovrl_updr1, psi_dovrl_updr2, & + & psi_zovrl_updr1, psi_zovrl_updr2 + end interface + + interface psi_gth + module procedure psi_igthm, psi_igthv,& + & psi_dgthm, psi_dgthv,& + & psi_zgthm, psi_zgthv + end interface + + interface psi_sct + module procedure psi_isctm, psi_isctv,& + & psi_dsctm, psi_dsctv,& + & psi_zsctm, psi_zsctv + end interface + + contains - + subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) use psb_const_mod @@ -321,13 +351,13 @@ contains implicit none ! ....scalars parameters.... - integer, intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) + integer, intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) type(psb_desc_type), intent(inout) :: cdesc - integer, intent(out) :: info + integer, intent(out) :: info ! ....local scalars.... integer :: np,me - integer :: ictxt, err_act,nxch,nsnd,nrcv + integer :: ictxt, err_act,nxch,nsnd,nrcv,j,k ! ...local array... integer, allocatable :: idx_out(:) @@ -363,7 +393,7 @@ contains cdesc%matrix_data(psb_thal_xch_) = nxch cdesc%matrix_data(psb_thal_snd_) = nsnd cdesc%matrix_data(psb_thal_rcv_) = nrcv - + if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' @@ -379,12 +409,11 @@ contains cdesc%matrix_data(psb_text_xch_) = nxch cdesc%matrix_data(psb_text_snd_) = nsnd cdesc%matrix_data(psb_text_rcv_) = nrcv - + if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap' ! then the overlap index - call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psi_crea_index') @@ -402,7 +431,7 @@ contains if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem' ! next ovrlap_elem - call psi_crea_ovr_elem(cdesc%ovrlap_index,cdesc%ovrlap_elem,info) + call psi_crea_ovr_elem(me,cdesc%ovrlap_index,cdesc%ovrlap_elem,info) if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem' if(info /= 0) then call psb_errpush(4010,name,a_err='psi_crea_ovr_elem') @@ -446,7 +475,7 @@ contains ! ordered sublist. The hashing is based on the low-order bits ! for a width of psb_hash_bits ! - + do i=1, n key = x(i) ih = iand(key,hashmask) @@ -493,7 +522,7 @@ contains ! ordered sublist. The hashing is based on the low-order bits ! for a width of psb_hash_bits ! - + do i=1, n key = x(i) ih = iand(key,hashmask) @@ -529,4 +558,715 @@ contains end do end subroutine psi_inner_cnv2 + subroutine psi_dovrl_updr1(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(kind(1.d0)), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_dovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_updr1 + + + subroutine psi_dovrl_updr2(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(kind(1.d0)), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_dovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_updr2 + + subroutine psi_zovrl_updr1(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(kind(1.d0)), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_zovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_updr1 + + + subroutine psi_zovrl_updr2(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(kind(1.d0)), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_zovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_updr2 + + subroutine psi_iovrl_updr1(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_iovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + ! Square root does not make sense here +!!$ case(psb_square_root_) +!!$ do i=1,size(desc_a%ovrlap_elem,1) +!!$ idx = desc_a%ovrlap_elem(i,1) +!!$ ndm = desc_a%ovrlap_elem(i,2) +!!$ x(idx) = x(idx)/sqrt(real(ndm)) +!!$ end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_updr1 + + + subroutine psi_iovrl_updr2(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_iovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + ! Square root does not make sense here +!!$ case(psb_square_root_) +!!$ do i=1,size(desc_a%ovrlap_elem,1) +!!$ idx = desc_a%ovrlap_elem(i,1) +!!$ ndm = desc_a%ovrlap_elem(i,2) +!!$ x(idx,:) = x(idx,:)/sqrt(real(ndm)) +!!$ end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_updr2 + + + subroutine psi_dgthm(n,k,idx,x,y) + + use psb_const_mod + 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 subroutine psi_dgthm + + subroutine psi_dgthv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(kind(1.d0)) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_dgthv + + + subroutine psi_dsctm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(kind(1.d0)) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == dzero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == done) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + 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) + end do + end do + end if + end subroutine psi_dsctm + + subroutine psi_dsctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(kind(1.d0)) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == dzero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == done) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if + end subroutine psi_dsctv + + + subroutine psi_igthm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + integer :: 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 subroutine psi_igthm + + + subroutine psi_igthv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + integer :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_igthv + + + + subroutine psi_isctm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + integer :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == izero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == ione) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + 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) + end do + end do + end if + end subroutine psi_isctm + + subroutine psi_isctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + integer :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == izero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == ione) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if + end subroutine psi_isctv + + + subroutine psi_zgthm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(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 subroutine psi_zgthm + + + subroutine psi_zgthv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(kind(1.d0)) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_zgthv + + subroutine psi_zsctm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(kind(1.d0)) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == zzero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == zone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + 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) + end do + end do + end if + end subroutine psi_zsctm + + + subroutine psi_zsctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(kind(1.d0)) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == zzero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == zone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + 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 module psi_mod diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index 0d0c6f75..bad65311 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -64,7 +64,7 @@ function psb_damax (x,desc_a, info, jx) character(len=20) :: name, ch_err name='psb_damax' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -89,21 +89,21 @@ function psb_damax (x,desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then imax=idamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),1) amax=abs(x(iix+imax-1,jjx)) end if @@ -119,7 +119,7 @@ function psb_damax (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -190,7 +190,7 @@ function psb_damaxv (x,desc_a, info) character(len=20) :: name, ch_err name='psb_damaxv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -211,21 +211,21 @@ function psb_damaxv (x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then imax=idamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) amax=abs(x(iix+imax-1)) end if @@ -241,7 +241,7 @@ function psb_damaxv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -313,7 +313,7 @@ subroutine psb_damaxvs (res,x,desc_a, info) character(len=20) :: name, ch_err name='psb_damaxvs' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -334,21 +334,21 @@ subroutine psb_damaxvs (res,x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then imax=idamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) amax=abs(x(iix+imax-1)) end if @@ -364,7 +364,7 @@ subroutine psb_damaxvs (res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -435,7 +435,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) character(len=20) :: name, ch_err name='psb_dmamaxs' - if (psb_get_errstatus().ne.0) return + if (psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -461,21 +461,21 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) k = min(size(x,2),size(res,1)) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then do i=1,k imax=idamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx+i-1),1) res(i)=abs(x(iix+imax-1,jjx+i-1)) @@ -491,7 +491,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index d4fc9853..91e173c7 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -60,12 +60,12 @@ function psb_dasum (x,desc_a, info, jx) ! locals integer :: ictxt, np, me, err_act, & - & iix, jjx, ix, ijx, m, i + & iix, jjx, ix, ijx, m, i, idx, ndm real(kind(1.d0)) :: asum, dasum character(len=20) :: name, ch_err name='psb_dasum' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -91,31 +91,29 @@ function psb_dasum (x,desc_a, info, jx) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((m.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then asum=dasum(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),ione) ! adjust asum because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - asum = asum -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & abs(x(desc_a%ovrlap_elem(i)-iix+1,jjx)) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*abs(x(idx,jjx)) end do ! compute global sum @@ -139,7 +137,7 @@ function psb_dasum (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -203,12 +201,12 @@ function psb_dasumv (x,desc_a, info) real(kind(1.d0)) :: psb_dasumv ! locals - integer :: ictxt, np, me, err_act, iix, jjx, jx, ix, m, i - real(kind(1.d0)) :: asum, dasum - character(len=20) :: name, ch_err + integer :: ictxt, np, me, err_act, iix, jjx, jx, ix, m, i, idx, ndm + real(kind(1.d0)) :: asum, dasum + character(len=20) :: name, ch_err name='psb_dasumv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -230,31 +228,28 @@ function psb_dasumv (x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((m.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then asum=dasum(psb_cd_get_local_rows(desc_a),x,ione) - ! adjust asum because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - asum = asum -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & abs(x(desc_a%ovrlap_elem(i))) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*abs(x(idx)) end do ! compute global sum @@ -277,7 +272,7 @@ function psb_dasumv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -342,12 +337,12 @@ subroutine psb_dasumvs(res,x,desc_a, info) integer, intent(out) :: info ! locals - integer :: ictxt, np, me, err_act, iix, jjx, ix, jx, m, i - real(kind(1.d0)) :: asum, dasum - character(len=20) :: name, ch_err + integer :: ictxt, np, me, err_act, iix, jjx, ix, jx, m, i, idx, ndm + real(kind(1.d0)) :: asum, dasum + character(len=20) :: name, ch_err name='psb_dasumvs' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -369,31 +364,29 @@ subroutine psb_dasumvs(res,x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((m.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then asum=dasum(psb_cd_get_local_rows(desc_a),x,ione) ! adjust asum because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - asum = asum -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & abs(x(desc_a%ovrlap_elem(i))) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*abs(x(idx)) end do ! compute global sum @@ -417,12 +410,9 @@ subroutine psb_dasumvs(res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if return end subroutine psb_dasumvs - - - diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 1defa80b..d8303b86 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -70,7 +70,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) character(len=20) :: name, ch_err name='psb_dgeaxpby' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -98,8 +98,8 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) endif if (present(n)) then - if(((ijx+n).le.size(x,2)).and.& - & ((ijy+n).le.size(y,2))) then + if(((ijx+n) <= size(x,2)).and.& + & ((ijy+n) <= size(y,2))) then in = n else in = min(size(x,2),size(y,2)) @@ -108,7 +108,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) in = min(size(x,2),size(y,2)) endif - if(ijx.ne.ijy) then + if(ijx /= ijy) then info=3050 call psb_errpush(info,name) goto 9999 @@ -120,21 +120,21 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if ((in.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((in /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then call daxpby(psb_cd_get_local_rows(desc_a),in,& & alpha,x(iix,jjx),size(x,1),beta,& & y(iiy,jjy),size(y,1),info) @@ -147,7 +147,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -223,7 +223,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) character(len=20) :: name, ch_err name='psb_dgeaxpby' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -243,26 +243,26 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then 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,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then 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 + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) end if - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(psb_cd_get_local_rows(desc_a) > 0) then call daxpby(psb_cd_get_local_rows(desc_a),ione,& & alpha,x,size(x),beta,& & y,size(y),info) @@ -274,7 +274,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index 8c5da986..267f5616 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -61,19 +61,18 @@ function psb_ddot(x, y,desc_a, info, jx, jy) real(kind(1.D0)) :: psb_ddot ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m real(kind(1.D0)) :: dot_local real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_ddot' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) if (np == -ione) then info = 2010 @@ -95,7 +94,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy) ijy = ione endif - if(ijx.ne.ijy) then + if(ijx /= ijy) then info=3050 call psb_errpush(info,name) goto 9999 @@ -107,31 +106,28 @@ function psb_ddot(x, y,desc_a, info, jx, jy) call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then dot_local = ddot(psb_cd_get_local_rows(desc_a),& & 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)*& - & x(iix+desc_a%ovrlap_elem(i)-1,jjx)*& - & y(iiy+desc_a%ovrlap_elem(i)-1,jjy) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx,jjx)*y(idx,jjy)) end do else dot_local=0.d0 @@ -151,7 +147,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -216,14 +212,14 @@ function psb_ddotv(x, y,desc_a, info) real(kind(1.D0)) :: psb_ddotv ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m real(kind(1.D0)) :: dot_local real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_ddot' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -246,31 +242,28 @@ function psb_ddotv(x, y,desc_a, info) call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then dot_local = ddot(psb_cd_get_local_rows(desc_a),& & 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)*& - & x(desc_a%ovrlap_elem(i))*& - & y(desc_a%ovrlap_elem(i)) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) end do else dot_local=0.d0 @@ -290,7 +283,7 @@ function psb_ddotv(x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -355,14 +348,14 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) integer, intent(out) :: info ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m real(kind(1.D0)) :: dot_local real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_ddot' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -378,36 +371,32 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) ix = ione iy = ione m = psb_cd_get_global_rows(desc_a) - ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then dot_local = ddot(psb_cd_get_local_rows(desc_a),& & 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)*& - & x(desc_a%ovrlap_elem(i))*& - & y(desc_a%ovrlap_elem(i)) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) end do else dot_local=0.d0 @@ -427,7 +416,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -493,14 +482,14 @@ subroutine psb_dmdots(res, x, y, desc_a, info) integer, intent(out) :: info ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k real(kind(1.d0)),allocatable :: dot_local(:) real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_dmdots' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -520,21 +509,21 @@ subroutine psb_dmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - 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 call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,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 ((ix.ne.ione).or.(iy.ne.ione)) then + if ((ix /= ione).or.(iy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 @@ -543,20 +532,17 @@ subroutine psb_dmdots(res, x, y, desc_a, info) k = min(size(x,2),size(y,2)) allocate(dot_local(k)) - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then do j=1,k dot_local(j) = ddot(psb_cd_get_local_rows(desc_a),& & 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)*& - & x(desc_a%ovrlap_elem(i)-1,j)*& - & y(desc_a%ovrlap_elem(i)-1,j) - i = i+2 - end do + end do + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local(1:k) = dot_local(1:k) - (real(ndm-1)/real(ndm))*(x(idx,1:k)*y(idx,1:k)) end do else dot_local(:)=0.d0 @@ -576,10 +562,9 @@ subroutine psb_dmdots(res, x, y, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if return end subroutine psb_dmdots - diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 370982ce..39507ac9 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -58,13 +58,13 @@ function psb_dnrm2(x, desc_a, info, jx) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, ijx, i, m, id + & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm real(kind(1.d0)) :: nrm2, dnrm2, dd external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -85,35 +85,30 @@ function psb_dnrm2(x, desc_a, info, jx) endif m = psb_cd_get_global_rows(desc_a) - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if (psb_cd_get_local_rows(desc_a) .gt. 0) then + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then ndim = psb_cd_get_local_rows(desc_a) nrm2 = dnrm2( 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 * ( & - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_), jjx) & - & / nrm2 & - & ) ** 2 & - & ) - i = i+2 + + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx,jjx))/nrm2)**2) end do else nrm2 = dzero @@ -132,7 +127,7 @@ function psb_dnrm2(x, desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -196,13 +191,13 @@ function psb_dnrm2v(x, desc_a, info) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(kind(1.d0)) :: nrm2, dnrm2, dd external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2v' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -217,37 +212,31 @@ function psb_dnrm2v(x, desc_a, info) ix = 1 jx=1 - m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if (psb_cd_get_local_rows(desc_a) .gt. 0) then + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then ndim = psb_cd_get_local_rows(desc_a) nrm2 = dnrm2( 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 * ( & - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) & - & / nrm2 & - & ) ** 2 & - & ) - i = i+2 + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) end do else nrm2 = dzero @@ -266,7 +255,7 @@ function psb_dnrm2v(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -332,13 +321,13 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(kind(1.d0)) :: nrm2, dnrm2, dd external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -356,33 +345,28 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if (psb_cd_get_local_rows(desc_a) .gt. 0) then + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then ndim = psb_cd_get_local_rows(desc_a) nrm2 = dnrm2( 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 * ( & - & x(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) & - & / nrm2 & - & ) ** 2 & - & ) - i = i+2 + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) end do else nrm2 = dzero @@ -401,7 +385,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 6dc9c0e6..b3848e7a 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -60,7 +60,7 @@ function psb_dnrmi(a,desc_a,info) character(len=20) :: name, ch_err name='psb_dnrmi' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -79,27 +79,27 @@ function psb_dnrmi(a,desc_a,info) n = psb_cd_get_global_cols(desc_a) call psb_chkmat(m,n,ia,ja,desc_a,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) goto 9999 end if - if ((iia.ne.1).or.(jja.ne.1)) then + if ((iia /= 1).or.(jja /= 1)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if ((m.ne.0).and.(n.ne.0)) then + if ((m /= 0).and.(n /= 0)) then mdim = psb_cd_get_local_rows(desc_a) ndim = psb_cd_get_local_cols(desc_a) nrmi = dcsnmi('N',mdim,ndim,a%fida,& & a%descra,a%aspk,a%ia1,a%ia2,& & a%infoa,info) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='dcsnmi' call psb_errpush(info,name,a_err=ch_err) @@ -120,7 +120,7 @@ function psb_dnrmi(a,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index ee98a89b..a1ba80ef 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -90,17 +90,21 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& integer :: ictxt, np, me,& & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& - & i, ib, ib1 + & i, ib, ib1, ip, idx integer, parameter :: nb=4 - real(kind(1.d0)),pointer :: xp(:,:), yp(:,:), iwork(:) + real(kind(1.d0)), pointer :: xp(:,:), yp(:,:), iwork(:) + real(kind(1.d0)), allocatable :: wrkt(:,:) character :: trans_ character(len=20) :: name, ch_err logical :: aliw, doswap_ + integer :: debug_level, debug_unit name='psb_dspmm' if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() ictxt=psb_cd_get_context(desc_a) @@ -155,7 +159,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& end if m = psb_cd_get_global_rows(desc_a) - n = psb_cd_get_global_cols(desc_a) + n = psb_cd_get_global_cols(desc_a) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) lldx = size(x,1) @@ -163,8 +167,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) liwork = liwork + n * ik - if (a%pl(1) /= 0) liwork = liwork + m * ik + if (present(work)) then if (size(work) >= liwork) then aliw =.false. @@ -264,6 +267,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& end if else + ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented @@ -272,11 +276,6 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(desc_a%ovrlap_elem(1) /= -1) then - info = 3070 - call psb_errpush(info,name) - goto 9999 - end if ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) @@ -296,35 +295,54 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - y(iiy+nrow+1-1:iiy+ncol,1:ik)=dzero - - ! local Matrix-vector product - - call psb_csmm(alpha,a,x(iix:lldx,jjx:jjx+ik-1),& - & beta,y(iiy:lldy,jjy:jjy+ik-1),info,trans=trans_) - - if(info /= 0) then - info = 4010 - ch_err='csmm' + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + allocate(wrkt(ncol,ik),stat=info) + if (info /= 0) then + info=4010 + ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - yp => y(iiy:lldy,jjy:jjy+ik-1) - if (doswap_) & - & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& - & ik,done,yp,desc_a,iwork,info) + + ! + wrkt(1:nrow,1:ik) = x(1:nrow,1:ik) + wrkt(nrow+1:ncol,1:ik) = dzero + y(nrow+1:ncol,1:ik) = dzero + call psi_ovrl_upd(wrkt,desc_a,psb_avg_,info) + call psb_csmm(alpha,a,wrkt(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' csmm ', info if(info /= 0) then info = 4010 - ch_err='PSI_dSwapTran' + ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + if (doswap_)then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & ik,done,y(:,1:ik),desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + end if - if(aliw) deallocate(iwork) + if (aliw) deallocate(iwork) nullify(iwork) call psb_erractionrestore(err_act) @@ -417,7 +435,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - real(kind(1.d0)), optional, target :: work(:) + real(kind(1.d0)), optional, target :: work(:) character, intent(in), optional :: trans logical, intent(in), optional :: doswap @@ -425,7 +443,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& integer :: ictxt, np, me,& & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib + & ib, ip, idx integer, parameter :: nb=4 real(kind(1.d0)),pointer :: iwork(:), xp(:), yp(:) character :: trans_ @@ -486,8 +504,6 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& iwork => null() ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) liwork = liwork + n * ik - if (a%pl(1) /= 0) liwork = liwork + m * ik if (present(work)) then if (size(work) >= liwork) then @@ -574,12 +590,6 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(desc_a%ovrlap_elem(1) /= -1) then - info = 3070 - call psb_errpush(info,name) - goto 9999 - end if - ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) if (info == 0)& @@ -598,34 +608,46 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - xp => x(iix:lldx) - yp => y(iiy:lldy) - - yp(nrow+1:ncol)=dzero - if (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' checkvect ', info + xp => x(1:lldx) + yp => y(1:lldy) + + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + iwork(1:nrow) = x(1:nrow) + iwork(nrow+1:ncol) = dzero + yp(nrow+1:ncol) = dzero + call psi_ovrl_upd(iwork,desc_a,psb_avg_,info) + ! local Matrix-vector product - call psb_csmm(alpha,a,xp,beta,yp,info,trans=trans_) + call psb_csmm(alpha,a,iwork,beta,yp,info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if(info /= 0) then - info = 4010 - ch_err='dcsmm' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - if (doswap_)& - & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& - & done,yp,desc_a,iwork,info) - if (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then + if (info /= 0) then info = 4010 - ch_err='PSI_dSwapTran' + ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + + if (doswap_) then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & done,yp,desc_a,iwork,info) + + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if end if diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index 672fd1ee..2cf84a64 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -100,10 +100,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: k, jx, jy ! locals - integer :: int_err(5), ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, lchoice,& + integer :: ictxt, np, me,& + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, ijx, ijy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm character :: lunitd integer, parameter :: nb=4 @@ -113,7 +113,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_dspsm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -152,9 +152,9 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(choice)) then - lchoice = choice + choice_ = choice else - lchoice = psb_avg_ + choice_ = psb_avg_ endif if (present(unitd)) then @@ -165,7 +165,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& if (present(trans)) then itrans = toupper(trans) - if((itrans.eq.'N').or.(itrans.eq.'T').or. (itrans.eq.'C')) then + if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then ! OK else info = 70 @@ -179,11 +179,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& m = psb_cd_get_global_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) - lldx = size(x,1) lldy = size(y,1) - if((lldx.lt.ncol).or.(lldy.lt.ncol)) then + if((lldx < ncol).or.(lldy < ncol)) then info=3010 call psb_errpush(info,name) goto 9999 @@ -206,7 +205,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=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) @@ -234,24 +233,24 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if(ja.ne.ix) then + if(ja /= ix) then ! this case is not yet implemented info = 3030 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 end if - if(info.ne.0) then + if(info /= 0) then call psb_errpush(info,name) goto 9999 end if @@ -261,7 +260,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy,jjy:jjy+ik-1) call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) @@ -269,37 +268,16 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& end if ! update overlap elements - if(lchoice.gt.0) then + if (choice_ > 0) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& - & done,yp,desc_a,iwork,info) - - i=0 - ! switch on update type - select case (lchoice) - case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & y(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) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & y(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 - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,lchoice,0,0,0/) - call psb_errpush(info,name,i_err=int_err) + & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 - end select + end if end if if(aliw) deallocate(iwork) @@ -311,7 +289,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -408,10 +386,10 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& integer, intent(in), optional :: choice ! locals - integer :: int_err(5), ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, lchoice,& + integer :: ictxt, np, me, & + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm character :: lunitd integer, parameter :: nb=4 @@ -421,7 +399,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_dspsv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -444,9 +422,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& jy= 1 if (present(choice)) then - lchoice = choice + choice_ = choice else - lchoice = psb_avg_ + choice_ = psb_avg_ endif if (present(unitd)) then @@ -457,12 +435,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& if (present(trans)) then itrans = toupper(trans) - if((itrans.eq.'N').or.(itrans.eq.'T')) then + if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then ! Ok - else if (itrans.eq.'C') then - info = 3020 - call psb_errpush(info,name) - goto 9999 else info = 70 call psb_errpush(info,name) @@ -475,11 +449,10 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& m = psb_cd_get_global_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) - lldx = size(x) lldy = size(y) - if((lldx.lt.ncol).or.(lldy.lt.ncol)) then + if((lldx < ncol).or.(lldy < ncol)) then info=3010 call psb_errpush(info,name) goto 9999 @@ -488,8 +461,6 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& iwork => null() ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) llwork = liwork + m * ik - if (a%pl(1) /= 0) llwork = llwork + m * ik if (present(work)) then if (size(work) >= liwork) then @@ -503,7 +474,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=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) @@ -531,24 +502,24 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) if (info == 0)& & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if(ja.ne.ix) then + if(ja /= ix) then ! this case is not yet implemented info = 3030 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 end if - if(info.ne.0) then + if(info /= 0) then call psb_errpush(info,name) goto 9999 end if @@ -558,7 +529,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) @@ -566,36 +537,16 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& end if ! update overlap elements - if(lchoice.gt.0) then + if (choice_ > 0) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & done,yp,desc_a,iwork,info) - - i=0 - ! switch on update type - select case (lchoice) - case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & y(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) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & y(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 - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,lchoice,0,0,0/) - call psb_errpush(info,name,i_err=int_err) + & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 - end select + end if end if if (aliw) deallocate(iwork) @@ -607,7 +558,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index c1fe60dc..5f4dc86b 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -67,7 +67,7 @@ function psb_zamax (x,desc_a, info, jx) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zamax' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -92,21 +92,21 @@ function psb_zamax (x,desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then imax=izamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),1) amax=cabs1(x(iix+imax-1,jjx)) end if @@ -122,7 +122,7 @@ function psb_zamax (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -197,7 +197,7 @@ function psb_zamaxv (x,desc_a, info) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zamaxv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -218,21 +218,21 @@ function psb_zamaxv (x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then imax=izamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) cmax=(x(iix+imax-1)) amax=cabs1(cmax) @@ -249,7 +249,7 @@ function psb_zamaxv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -325,7 +325,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zamaxvs' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -345,21 +345,21 @@ subroutine psb_zamaxvs(res,x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then imax=izamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) cmax=(x(iix+imax-1)) amax=cabs1(cmax) @@ -376,7 +376,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -451,7 +451,7 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zmamaxs' - if (psb_get_errstatus().ne.0) return + if (psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -477,21 +477,21 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) k = min(size(x,2),size(res,1)) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((psb_cd_get_local_rows(desc_a).gt.0).and.(m.ne.0)) then + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then do i=1,k imax=izamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx+i-1),1) cmax=(x(iix+imax-1,jjx+i-1)) @@ -508,7 +508,7 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 094584fd..680c8317 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -60,7 +60,7 @@ function psb_zasum (x,desc_a, info, jx) ! locals integer :: ictxt, np, me, & - & err_act, iix, jjx, ix, ijx, m, i + & err_act, iix, jjx, ix, ijx, m, i, idx, ndm real(kind(1.d0)) :: asum, dzasum character(len=20) :: name, ch_err complex(kind(1.d0)) :: cmax @@ -69,7 +69,7 @@ function psb_zasum (x,desc_a, info, jx) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zasum' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -95,32 +95,29 @@ function psb_zasum (x,desc_a, info, jx) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((m.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then asum=dzasum(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),ione) ! adjust asum because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - cmax = x(desc_a%ovrlap_elem(i)-iix+1,jjx) - asum = asum -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & cabs1(cmax) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*cabs1(x(idx,jjx)) end do ! compute global sum @@ -144,7 +141,7 @@ function psb_zasum (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -209,7 +206,7 @@ function psb_zasumv(x,desc_a, info) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, i + & err_act, iix, jjx, jx, ix, m, i, idx, ndm real(kind(1.d0)) :: asum, dzasum character(len=20) :: name, ch_err complex(kind(1.d0)) :: cmax @@ -218,7 +215,7 @@ function psb_zasumv(x,desc_a, info) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zasumv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -240,32 +237,29 @@ function psb_zasumv(x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((m.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then asum=dzasum(psb_cd_get_local_rows(desc_a),x,ione) ! adjust asum because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - cmax = x(desc_a%ovrlap_elem(i)) - asum = asum -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & cabs1(cmax) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*cabs1(x(idx)) end do ! compute global sum @@ -288,7 +282,7 @@ function psb_zasumv(x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -354,7 +348,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ix, jx, m, i + & err_act, iix, jjx, ix, jx, m, i, idx, ndm real(kind(1.d0)) :: asum, dzasum character(len=20) :: name, ch_err complex(kind(1.d0)) :: cmax @@ -363,7 +357,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) name='psb_zasumvs' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -382,34 +376,32 @@ subroutine psb_zasumvs(res,x,desc_a, info) jx = 1 m = psb_cd_get_global_rows(desc_a) + ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - 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) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if ! compute local max - if ((m.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then asum=dzasum(psb_cd_get_local_rows(desc_a),x,ione) ! adjust asum because overlapped elements are computed more than once - i=1 - do while (desc_a%ovrlap_elem(i).ne.-ione) - cmax = x(desc_a%ovrlap_elem(i)) - asum = asum -& - & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & cabs1(cmax) - i = i+2 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*cabs1(x(idx)) end do ! compute global sum @@ -433,7 +425,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index 1b6b78dd..a7e63099 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -70,7 +70,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) character(len=20) :: name, ch_err name='psb_dgeaxpby' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -97,8 +97,8 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) endif if (present(n)) then - if(((ijx+n).le.size(x,2)).and.& - & ((ijy+n).le.size(y,2))) then + if(((ijx+n) <= size(x,2)).and.& + & ((ijy+n) <= size(y,2))) then in = n else in = min(size(x,2),size(y,2)) @@ -107,7 +107,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) in = min(size(x,2),size(y,2)) endif - if(ijx.ne.ijy) then + if(ijx /= ijy) then info=3050 call psb_errpush(info,name) goto 9999 @@ -119,21 +119,21 @@ 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,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if ((in.ne.0)) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if ((in /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then call zaxpby(psb_cd_get_local_cols(desc_a),in,& & alpha,x(iix,jjx),size(x,1),beta,& & y(iiy,jjy),size(y,1),info) @@ -146,7 +146,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -223,7 +223,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) logical, parameter :: debug=.false. name='psb_dgeaxpby' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -243,26 +243,26 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then 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,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then 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 + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) end if - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(psb_cd_get_local_rows(desc_a) > 0) then call zaxpby(psb_cd_get_local_cols(desc_a),ione,& & alpha,x,size(x),beta,& & y,size(y),info) @@ -274,7 +274,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index cc8383eb..b34101ae 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -61,14 +61,14 @@ function psb_zdot(x, y,desc_a, info, jx, jy) complex(kind(1.D0)) :: psb_zdot ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m complex(kind(1.D0)) :: dot_local complex(kind(1.d0)) :: zdotc character(len=20) :: name, ch_err name='psb_zdot' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -94,7 +94,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy) ijy = ione endif - if(ijx.ne.ijy) then + if(ijx /= ijy) then info=3050 call psb_errpush(info,name) goto 9999 @@ -106,31 +106,28 @@ function psb_zdot(x, y,desc_a, info, jx, jy) call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then dot_local = zdotc(psb_cd_get_local_rows(desc_a),& & 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 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(conjg(x(idx,jjx))*y(idx,jjy)) end do else dot_local=0.d0 @@ -150,7 +147,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -215,14 +212,14 @@ function psb_zdotv(x, y,desc_a, info) complex(kind(1.D0)) :: psb_zdotv ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m complex(kind(1.D0)) :: dot_local complex(kind(1.d0)) :: zdotc character(len=20) :: name, ch_err name='psb_zdot' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -245,31 +242,28 @@ function psb_zdotv(x, y,desc_a, info) call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) if (info == 0)& & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then dot_local = zdotc(psb_cd_get_local_rows(desc_a),& & 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 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(conjg(x(idx))*y(idx)) end do else dot_local=0.d0 @@ -289,7 +283,7 @@ function psb_zdotv(x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -354,14 +348,14 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) integer, intent(out) :: info ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m complex(kind(1.D0)) :: dot_local complex(kind(1.d0)) :: zdotc character(len=20) :: name, ch_err name='psb_zdot' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -381,31 +375,28 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,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.ione).or.(iiy.ne.ione)) then + if ((iix /= ione).or.(iiy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then dot_local = zdotc(psb_cd_get_local_rows(desc_a),& & 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 + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(conjg(x(idx))*y(idx)) end do else dot_local=0.d0 @@ -425,7 +416,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -491,14 +482,14 @@ subroutine psb_zmdots(res, x, y, desc_a, info) integer, intent(out) :: info ! locals - integer :: ictxt, np, me,& + integer :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k complex(kind(1.d0)),allocatable :: dot_local(:) complex(kind(1.d0)) :: zdotc character(len=20) :: name, ch_err name='psb_zmdots' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -518,21 +509,21 @@ subroutine psb_zmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - 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 call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,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 ((ix.ne.ione).or.(iy.ne.ione)) then + if ((ix /= ione).or.(iy /= ione)) then info=3040 call psb_errpush(info,name) goto 9999 @@ -541,20 +532,17 @@ subroutine psb_zmdots(res, x, y, desc_a, info) k = min(size(x,2),size(y,2)) allocate(dot_local(k)) - if(m.ne.0) then - if(psb_cd_get_local_rows(desc_a).gt.0) then + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then do j=1,k dot_local(j) = zdotc(psb_cd_get_local_rows(desc_a),& & 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 + end do + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local(1:k) = dot_local(1:k) - (real(ndm-1)/real(ndm))*(conjg(x(idx,1:k))*y(idx,1:k)) end do else dot_local(:)=0.d0 @@ -568,14 +556,13 @@ subroutine psb_zmdots(res, x, y, desc_a, info) res(1:k) = dot_local(1:k) - call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index d15bb43c..a266bec2 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -58,14 +58,14 @@ function psb_znrm2(x, desc_a, info, jx) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, ijx, i, m, id + & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm real(kind(1.d0)) :: nrm2, dznrm2, dd external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -87,32 +87,29 @@ function psb_znrm2(x, desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if (psb_cd_get_local_rows(desc_a) .gt. 0) then + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then ndim = psb_cd_get_local_rows(desc_a) 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 + + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx,jjx))/nrm2)**2) end do else nrm2 = dzero @@ -131,7 +128,7 @@ function psb_znrm2(x, desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -195,14 +192,14 @@ function psb_znrm2v(x, desc_a, info) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(kind(1.d0)) :: nrm2, dznrm2, dd external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2v' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -219,34 +216,29 @@ function psb_znrm2v(x, desc_a, info) jx=1 m = psb_cd_get_global_rows(desc_a) - call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if (psb_cd_get_local_rows(desc_a) .gt. 0) then + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then ndim = psb_cd_get_local_rows(desc_a) 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 + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) end do else nrm2 = dzero @@ -265,7 +257,7 @@ function psb_znrm2v(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -331,14 +323,14 @@ subroutine psb_znrm2vs(res, x, desc_a, info) ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm real(kind(1.d0)) :: nrm2, dznrm2, dd external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -356,30 +348,28 @@ subroutine psb_znrm2vs(res, x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if - if (iix.ne.1) then + if (iix /= 1) then info=3040 call psb_errpush(info,name) goto 9999 end if - if(m.ne.0) then - if (psb_cd_get_local_rows(desc_a) .gt. 0) then + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then ndim = psb_cd_get_local_rows(desc_a) 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 + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) end do else nrm2 = dzero @@ -398,7 +388,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 9beb0545..bbcca4f1 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -60,7 +60,7 @@ function psb_znrmi(a,desc_a,info) character(len=20) :: name, ch_err name='psb_znrmi' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -79,27 +79,27 @@ function psb_znrmi(a,desc_a,info) n = psb_cd_get_global_cols(desc_a) call psb_chkmat(m,n,ia,ja,desc_a,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) goto 9999 end if - if ((iia.ne.1).or.(jja.ne.1)) then + if ((iia /= 1).or.(jja /= 1)) then info=3040 call psb_errpush(info,name) goto 9999 end if - if ((m.ne.0).and.(n.ne.0)) then + if ((m /= 0).and.(n /= 0)) then mdim = psb_cd_get_local_rows(desc_a) ndim = psb_cd_get_local_cols(desc_a) nrmi = zcsnmi('N',mdim,ndim,a%fida,& & a%descra,a%aspk,a%ia1,a%ia2,& & a%infoa,info) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='dcsnmi' call psb_errpush(info,name,a_err=ch_err) @@ -120,7 +120,7 @@ function psb_znrmi(a,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index 3d4e0d5b..a0261456 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -37,7 +37,7 @@ ! ! sub( Y ) := alpha * Pr * A' * Pr * sub( X ) + beta * sub( Y ), ! -! +! where: ! ! sub( X ) denotes: X(1:N,JX:JX+K-1), ! @@ -90,17 +90,21 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& integer :: ictxt, np, me,& & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& - & i, ib, ib1 - integer, parameter :: nb=4 - complex(kind(1.d0)),pointer :: xp(:,:), yp(:,:), iwork(:) - character :: trans_ - character(len=20) :: name, ch_err - logical :: aliw, doswap_ + & i, ib, ib1, ip, idx + integer, parameter :: nb=4 + complex(kind(1.d0)), pointer :: xp(:,:), yp(:,:), iwork(:) + complex(kind(1.d0)), allocatable :: wrkt(:,:) + character :: trans_ + character(len=20) :: name, ch_err + logical :: aliw, doswap_ + integer :: debug_level, debug_unit name='psb_zspmm' if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() ictxt=psb_cd_get_context(desc_a) @@ -163,8 +167,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) liwork = liwork + n * ik - if (a%pl(1) /= 0) liwork = liwork + m * ik + if (present(work)) then if (size(work) >= liwork) then aliw =.false. @@ -264,6 +267,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& end if else + ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented @@ -272,11 +276,6 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(desc_a%ovrlap_elem(1) /= -1) then - info = 3070 - call psb_errpush(info,name) - goto 9999 - end if ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) @@ -296,35 +295,54 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - y(iiy+nrow+1-1:iiy+ncol,1:ik)=zzero - - ! local Matrix-vector product - - call psb_csmm(alpha,a,x(iix:lldx,jjx:jjx+ik-1),& - & beta,y(iiy:lldy,jjy:jjy+ik-1),info,trans=trans_) - - if(info /= 0) then - info = 4010 - ch_err='csmm' + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + allocate(wrkt(ncol,ik),stat=info) + if (info /= 0) then + info=4010 + ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - yp => y(iiy:lldy,jjy:jjy+ik-1) - if (doswap_) & - & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& - & ik,zone,yp,desc_a,iwork,info) + + ! + wrkt(1:nrow,1:ik) = x(1:nrow,1:ik) + wrkt(nrow+1:ncol,1:ik) = zzero + y(nrow+1:ncol,1:ik) = zzero + call psi_ovrl_upd(wrkt,desc_a,psb_avg_,info) + call psb_csmm(alpha,a,wrkt(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' csmm ', info if(info /= 0) then info = 4010 - ch_err='PSI_dSwapTran' + ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + if (doswap_)then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & ik,zone,y(:,1:ik),desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ik,zone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + end if - if(aliw) deallocate(iwork) + if (aliw) deallocate(iwork) nullify(iwork) call psb_erractionrestore(err_act) @@ -417,7 +435,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - complex(kind(1.d0)), optional, target :: work(:) + complex(kind(1.d0)), optional, target :: work(:) character, intent(in), optional :: trans logical, intent(in), optional :: doswap @@ -425,13 +443,13 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& integer :: ictxt, np, me,& & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib - integer, parameter :: nb=4 - complex(kind(1.d0)),pointer :: iwork(:), xp(:), yp(:) - character :: trans_ - character(len=20) :: name, ch_err - logical :: aliw, doswap_ - integer :: debug_level, debug_unit + & ib, ip, idx + integer, parameter :: nb=4 + complex(kind(1.d0)), pointer :: iwork(:), xp(:), yp(:) + character :: trans_ + character(len=20) :: name, ch_err + logical :: aliw, doswap_ + integer :: debug_level, debug_unit name='psb_zspmv' if(psb_get_errstatus() /= 0) return @@ -486,8 +504,6 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& iwork => null() ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) liwork = liwork + n * ik - if (a%pl(1) /= 0) liwork = liwork + m * ik if (present(work)) then if (size(work) >= liwork) then @@ -574,12 +590,6 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(desc_a%ovrlap_elem(1) /= -1) then - info = 3070 - call psb_errpush(info,name) - goto 9999 - end if - ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) if (info == 0)& @@ -598,34 +608,45 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - xp => x(iix:lldx) - yp => y(iiy:lldy) - - yp(nrow+1:ncol)=zzero - if (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' checkvect ', info + xp => x(1:lldx) + yp => y(1:lldy) + + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + iwork(1:nrow) = x(1:nrow) + iwork(nrow+1:ncol) = zzero + yp(nrow+1:ncol) = zzero + call psi_ovrl_upd(iwork,desc_a,psb_avg_,info) + ! local Matrix-vector product - call psb_csmm(alpha,a,xp,beta,yp,info,trans=trans_) + call psb_csmm(alpha,a,iwork,beta,yp,info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if(info /= 0) then - info = 4010 - ch_err='zcsmm' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - if (doswap_)& - & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& - & zone,yp,desc_a,iwork,info) - if (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then + if (info /= 0) then info = 4010 - ch_err='PSI_dSwapTran' + ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if + + if (doswap_) then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & zone,yp,desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if end if diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index 8cc8f022..072985a4 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -100,9 +100,9 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& ! locals integer :: ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, lchoice,& - & ix, iy, ik, ijx, ijy, i, lld, int_err(5),& - & m, nrow, ncol, liwork, llwork, iiy, jjy + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& + & ix, iy, ik, ijx, ijy, i, lld,& + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm character :: lunitd integer, parameter :: nb=4 @@ -112,7 +112,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_zspsm' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -151,9 +151,9 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(choice)) then - lchoice = choice + choice_ = choice else - lchoice = psb_avg_ + choice_ = psb_avg_ endif if (present(unitd)) then @@ -164,12 +164,8 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& if (present(trans)) then itrans = toupper(trans) - if((itrans.eq.'N').or.(itrans.eq.'T')) then - ! Ok - else if (itrans.eq.'C') then - info = 3020 - call psb_errpush(info,name) - goto 9999 + if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then + ! OK else info = 70 call psb_errpush(info,name) @@ -185,7 +181,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& lldx = size(x,1) lldy = size(y,1) - if((lldx.lt.ncol).or.(lldy.lt.ncol)) then + if((lldx < ncol).or.(lldy < ncol)) then info=3010 call psb_errpush(info,name) goto 9999 @@ -208,7 +204,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=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) @@ -236,24 +232,24 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if(ja.ne.ix) then + if(ja /= ix) then ! this case is not yet implemented info = 3030 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 end if - if(info.ne.0) then + if(info /= 0) then call psb_errpush(info,name) goto 9999 end if @@ -263,7 +259,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy,jjy:jjy+ik-1) call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='zcssm' call psb_errpush(info,name,a_err=ch_err) @@ -271,37 +267,16 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& end if ! update overlap elements - if(lchoice.gt.0) then + if (choice_ > 0) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& - & zone,yp,desc_a,iwork,info) - - i=0 - ! switch on update type - select case (lchoice) - case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & y(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) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_),:) =& - & y(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 - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,lchoice,0,0,0/) - call psb_errpush(info,name,i_err=int_err) + & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 - end select + end if end if if(aliw) deallocate(iwork) @@ -313,7 +288,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -411,9 +386,9 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& ! locals integer :: ictxt, np, me, & - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, lchoice,& - & ix, iy, ik, jx, jy, i, lld, int_err(5),& - & m, nrow, ncol, liwork, llwork, iiy, jjy + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& + & ix, iy, ik, jx, jy, i, lld,& + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm character :: lunitd integer, parameter :: nb=4 @@ -423,7 +398,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_zspsv' - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -446,9 +421,9 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& jy= 1 if (present(choice)) then - lchoice = choice + choice_ = choice else - lchoice = psb_avg_ + choice_ = psb_avg_ endif if (present(unitd)) then @@ -459,7 +434,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& if (present(trans)) then itrans = toupper(trans) - if((itrans.eq.'N').or.(itrans.eq.'T').or.(itrans.eq.'C')) then + if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then ! Ok else info = 70 @@ -476,7 +451,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& lldx = size(x) lldy = size(y) - if((lldx.lt.ncol).or.(lldy.lt.ncol)) then + if((lldx < ncol).or.(lldy < ncol)) then info=3010 call psb_errpush(info,name) goto 9999 @@ -485,8 +460,6 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& iwork => null() ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) llwork = liwork + m * ik - if (a%pl(1) /= 0) llwork = llwork + m * ik if (present(work)) then if (size(work) >= liwork) then @@ -500,7 +473,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=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) @@ -528,24 +501,24 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) if (info == 0) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if(ja.ne.ix) then + if(ja /= ix) then ! this case is not yet implemented info = 3030 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 end if - if(info.ne.0) then + if(info /= 0) then call psb_errpush(info,name) goto 9999 end if @@ -555,7 +528,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) - if(info.ne.0) then + if(info /= 0) then info = 4010 ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) @@ -563,36 +536,16 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& end if ! update overlap elements - if(lchoice.gt.0) then + if(choice_ > 0) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & zone,yp,desc_a,iwork,info) - - i=0 - ! switch on update type - select case (lchoice) - case(psb_square_root_) - do while(desc_a%ovrlap_elem(i).ne.-ione) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & y(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) - y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& - & y(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 - case default - ! wrong value for choice argument - info = 70 - int_err=(/10,lchoice,0,0,0/) - call psb_errpush(info,name,i_err=int_err) + & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') goto 9999 - end select + end if end if if (aliw) deallocate(iwork) @@ -604,7 +557,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/serial/psb_cest.f90 b/base/serial/psb_cest.f90 index e518fcb8..cc10c5ca 100644 --- a/base/serial/psb_cest.f90 +++ b/base/serial/psb_cest.f90 @@ -108,7 +108,7 @@ subroutine psb_cest(afmt,m,n,nnz, lia1, lia2, lar, iup,info) 9999 continue call psb_erractionrestore(err_act) - if ( err_act .ne. 0 ) then + if ( err_act /= 0 ) then call psb_error() return endif diff --git a/base/serial/psb_dcoins.f90 b/base/serial/psb_dcoins.f90 index c636cbb4..1af6723c 100644 --- a/base/serial/psb_dcoins.f90 +++ b/base/serial/psb_dcoins.f90 @@ -473,7 +473,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsmm.f90 b/base/serial/psb_dcsmm.f90 index 25ef3856..a80ba076 100644 --- a/base/serial/psb_dcsmm.f90 +++ b/base/serial/psb_dcsmm.f90 @@ -80,7 +80,7 @@ subroutine psb_dcsmm(alpha,a,b,beta,c,info,trans) & b,lb,beta,c,lc,work,iwsz,info) - if (info.ne.0) then + if (info /= 0) then info = 4010 ch_err='Serial csmm' call psb_errpush(info,name,a_err=ch_err) @@ -90,7 +90,7 @@ subroutine psb_dcsmm(alpha,a,b,beta,c,info,trans) end if deallocate(work,stat=info) - if (info.ne.0) then + if (info /= 0) then info = 4010 ch_err='Deallocate' call psb_errpush(info,name,a_err=ch_err) diff --git a/base/serial/psb_dcsmv.f90 b/base/serial/psb_dcsmv.f90 index 5d663512..6cb5207a 100644 --- a/base/serial/psb_dcsmv.f90 +++ b/base/serial/psb_dcsmv.f90 @@ -76,8 +76,8 @@ subroutine psb_dcsmv(alpha,a,b,beta,c,info,trans) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsnmi.f90 b/base/serial/psb_dcsnmi.f90 index 162ed872..6a60ee51 100644 --- a/base/serial/psb_dcsnmi.f90 +++ b/base/serial/psb_dcsnmi.f90 @@ -81,7 +81,7 @@ real(kind(1.d0)) function psb_dcsnmi(a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsrws.f90 b/base/serial/psb_dcsrws.f90 index fdfaba23..1c56add3 100644 --- a/base/serial/psb_dcsrws.f90 +++ b/base/serial/psb_dcsrws.f90 @@ -94,7 +94,7 @@ subroutine psb_dcsrws(rw,a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcssm.f90 b/base/serial/psb_dcssm.f90 index aaa326e9..8376b8f5 100644 --- a/base/serial/psb_dcssm.f90 +++ b/base/serial/psb_dcssm.f90 @@ -87,8 +87,8 @@ subroutine psb_dcssm(alpha,t,b,beta,c,info,trans,unitd,d) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcssv.f90 b/base/serial/psb_dcssv.f90 index e4a10494..66119f93 100644 --- a/base/serial/psb_dcssv.f90 +++ b/base/serial/psb_dcssv.f90 @@ -87,8 +87,8 @@ subroutine psb_dcssv(alpha,t,b,beta,c,info,trans,unitd,d) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dfixcoo.f90 b/base/serial/psb_dfixcoo.f90 index 770f8399..9ebc582a 100644 --- a/base/serial/psb_dfixcoo.f90 +++ b/base/serial/psb_dfixcoo.f90 @@ -84,17 +84,17 @@ subroutine psb_dfixcoo(a,info,idir) case(0) ! Row major order call msort_up(nza,a%ia1(1),iaux(1),iret) - if (iret.eq.0) call reordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + if (iret == 0) call reordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) i = 1 j = i - do while (i.le.nza) - do while ((a%ia1(j).eq.a%ia1(i))) + do while (i <= nza) + do while ((a%ia1(j) == a%ia1(i))) j = j+1 if (j > nza) exit enddo nzl = j - i call msort_up(nzl,a%ia2(i),iaux(1),iret) - if (iret.eq.0) & + if (iret == 0) & & call reordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) i = j enddo @@ -165,17 +165,17 @@ subroutine psb_dfixcoo(a,info,idir) case(1) ! Col major order call msort_up(nza,a%ia2(1),iaux(1),iret) - if (iret.eq.0) call reordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + if (iret == 0) call reordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) i = 1 j = i - do while (i.le.nza) - do while ((a%ia2(j).eq.a%ia2(i))) + do while (i <= nza) + do while ((a%ia2(j) == a%ia2(i))) j = j+1 if (j > nza) exit enddo nzl = j - i call msort_up(nzl,a%ia1(i),iaux(1),iret) - if (iret.eq.0) & + if (iret == 0) & & call reordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) i = j enddo @@ -254,7 +254,7 @@ subroutine psb_dfixcoo(a,info,idir) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dipcoo2csc.f90 b/base/serial/psb_dipcoo2csc.f90 index 0bbbfcd3..a9335aa5 100644 --- a/base/serial/psb_dipcoo2csc.f90 +++ b/base/serial/psb_dipcoo2csc.f90 @@ -204,7 +204,7 @@ subroutine psb_dipcoo2csc(a,info,clshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dipcoo2csr.f90 b/base/serial/psb_dipcoo2csr.f90 index 04be25a4..2390b848 100644 --- a/base/serial/psb_dipcoo2csr.f90 +++ b/base/serial/psb_dipcoo2csr.f90 @@ -203,7 +203,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dipcsr2coo.f90 b/base/serial/psb_dipcsr2coo.f90 index 62714db7..f74851c8 100644 --- a/base/serial/psb_dipcsr2coo.f90 +++ b/base/serial/psb_dipcsr2coo.f90 @@ -92,7 +92,7 @@ Subroutine psb_dipcsr2coo(a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dneigh.f90 b/base/serial/psb_dneigh.f90 index 8f125e2e..da467f82 100644 --- a/base/serial/psb_dneigh.f90 +++ b/base/serial/psb_dneigh.f90 @@ -86,7 +86,7 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev) ntl = 0 do i=ifl,ill nidx=neigh(i) - if ((nidx.ne.idx).and.(nidx.gt.0).and.(nidx.le.a%m)) then + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) if (info /= 0) then @@ -109,7 +109,7 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_drwextd.f90 b/base/serial/psb_drwextd.f90 index 5386db7f..ebfa694a 100644 --- a/base/serial/psb_drwextd.f90 +++ b/base/serial/psb_drwextd.f90 @@ -165,7 +165,7 @@ subroutine psb_drwextd(nr,a,info,b,rowscale) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspclip.f90 b/base/serial/psb_dspclip.f90 index 286d6797..1f4cea3a 100644 --- a/base/serial/psb_dspclip.f90 +++ b/base/serial/psb_dspclip.f90 @@ -146,7 +146,7 @@ subroutine psb_dspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspcnv.f90 b/base/serial/psb_dspcnv.f90 index ef205a55..fbffbdc9 100644 --- a/base/serial/psb_dspcnv.f90 +++ b/base/serial/psb_dspcnv.f90 @@ -360,7 +360,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -550,7 +550,7 @@ subroutine psb_dspcnv1(a, info, afmt, upd, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspgetrow.f90 b/base/serial/psb_dspgetrow.f90 index 2f13dc96..82f697de 100644 --- a/base/serial/psb_dspgetrow.f90 +++ b/base/serial/psb_dspgetrow.f90 @@ -118,7 +118,7 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) 9999 continue !!$ call psb_erractionrestore(err_act) call psb_erractionsave(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspgtdiag.f90 b/base/serial/psb_dspgtdiag.f90 index e083dbe9..81b576ee 100644 --- a/base/serial/psb_dspgtdiag.f90 +++ b/base/serial/psb_dspgtdiag.f90 @@ -89,7 +89,7 @@ subroutine psb_dspgtdiag(a,d,info) do i=1, rng, nrb irb=min(i+nrb-1,rng) call psb_sp_getblk(i,a,tmpa,info,lrw=irb) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_sp_getblk' call psb_errpush(info,name,a_err=ch_err) @@ -112,7 +112,7 @@ subroutine psb_dspgtdiag(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspscal.f90 b/base/serial/psb_dspscal.f90 index 9cfd16ad..21dc6cfa 100644 --- a/base/serial/psb_dspscal.f90 +++ b/base/serial/psb_dspscal.f90 @@ -88,7 +88,7 @@ subroutine psb_dspscal(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 88f3e266..d6024537 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -100,7 +100,7 @@ subroutine psb_dsymbmm(a,b,c,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -160,7 +160,7 @@ contains info=2 return else - if(index(ibcl(k)).eq.0) then + if(index(ibcl(k)) == 0) then index(ibcl(k))=istart istart=ibcl(k) length=length+1 diff --git a/base/serial/psb_getrow_mod.f90 b/base/serial/psb_getrow_mod.f90 index 63c22957..110f71ee 100644 --- a/base/serial/psb_getrow_mod.f90 +++ b/base/serial/psb_getrow_mod.f90 @@ -351,7 +351,7 @@ contains j=0 blkfnd: do j=j+1 - if(ia1(j).eq.indices(i)) then + if(ia1(j) == indices(i)) then blks(i)=j nz=nz+ia3(j)-ia2(j) ipx = ia1(j) ! the first row index of the block @@ -359,7 +359,7 @@ contains row = ia3(j)+rb nz = nz+ja_(row+1)-ja_(row) exit blkfnd - else if(ia1(j).gt.indices(i)) then + else if(ia1(j) > indices(i)) then blks(i)=j-1 nz=nz+ia3(j-1)-ia2(j-1) ipx = ia1(j-1) ! the first row index of the block @@ -775,7 +775,7 @@ contains j=0 blkfnd: do j=j+1 - if(ia1(j).eq.indices(i)) then + if(ia1(j) == indices(i)) then blks(i)=j nz=nz+ia3(j)-ia2(j) ipx = ia1(j) ! the first row index of the block @@ -783,7 +783,7 @@ contains row = ia3(j)+rb nz = nz+ja_(row+1)-ja_(row) exit blkfnd - else if(ia1(j).gt.indices(i)) then + else if(ia1(j) > indices(i)) then blks(i)=j-1 nz=nz+ia3(j-1)-ia2(j-1) ipx = ia1(j-1) ! the first row index of the block diff --git a/base/serial/psb_regen_mod.f90 b/base/serial/psb_regen_mod.f90 index c025cc20..2673dc0e 100644 --- a/base/serial/psb_regen_mod.f90 +++ b/base/serial/psb_regen_mod.f90 @@ -110,7 +110,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -216,7 +216,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -321,7 +321,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -428,7 +428,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -532,7 +532,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -637,7 +637,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_update_mod.f90 b/base/serial/psb_update_mod.f90 index 95e8fb15..8aa42837 100644 --- a/base/serial/psb_update_mod.f90 +++ b/base/serial/psb_update_mod.f90 @@ -708,13 +708,13 @@ contains j=0 blkfnd_gtl: do j=j+1 - if(ia1(j).eq.indices(i)) then + if(ia1(j) == indices(i)) then blks(i)=j ipx = ia1(j) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block row = ia3(j)+rb exit blkfnd_gtl - else if(ia1(j).gt.indices(i)) then + else if(ia1(j) > indices(i)) then blks(i)=j-1 ipx = ia1(j-1) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block @@ -800,13 +800,13 @@ contains j=0 blkfnd: do j=j+1 - if(ia1(j).eq.indices(i)) then + if(ia1(j) == indices(i)) then blks(i)=j ipx = ia1(j) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block row = ia3(j)+rb exit blkfnd - else if(ia1(j).gt.indices(i)) then + else if(ia1(j) > indices(i)) then blks(i)=j-1 ipx = ia1(j-1) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block @@ -1424,13 +1424,13 @@ contains j=0 blkfnd_gtl: do j=j+1 - if(ia1(j).eq.indices(i)) then + if(ia1(j) == indices(i)) then blks(i)=j ipx = ia1(j) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block row = ia3(j)+rb exit blkfnd_gtl - else if(ia1(j).gt.indices(i)) then + else if(ia1(j) > indices(i)) then blks(i)=j-1 ipx = ia1(j-1) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block @@ -1516,13 +1516,13 @@ contains j=0 blkfnd: do j=j+1 - if(ia1(j).eq.indices(i)) then + if(ia1(j) == indices(i)) then blks(i)=j ipx = ia1(j) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block row = ia3(j)+rb exit blkfnd - else if(ia1(j).gt.indices(i)) then + else if(ia1(j) > indices(i)) then blks(i)=j-1 ipx = ia1(j-1) ! the first row index of the block rb = indices(i)-ipx ! the row offset within the block diff --git a/base/serial/psb_zcoins.f90 b/base/serial/psb_zcoins.f90 index a55c1313..7ec8f71e 100644 --- a/base/serial/psb_zcoins.f90 +++ b/base/serial/psb_zcoins.f90 @@ -442,7 +442,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsmm.f90 b/base/serial/psb_zcsmm.f90 index 07cd38b9..0c261b53 100644 --- a/base/serial/psb_zcsmm.f90 +++ b/base/serial/psb_zcsmm.f90 @@ -76,8 +76,8 @@ subroutine psb_zcsmm(alpha,a,b,beta,c,info,trans) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsmv.f90 b/base/serial/psb_zcsmv.f90 index ea7708c5..9c369049 100644 --- a/base/serial/psb_zcsmv.f90 +++ b/base/serial/psb_zcsmv.f90 @@ -76,8 +76,8 @@ subroutine psb_zcsmv(alpha,a,b,beta,c,info,trans) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsnmi.f90 b/base/serial/psb_zcsnmi.f90 index 2c64a148..cf659916 100644 --- a/base/serial/psb_zcsnmi.f90 +++ b/base/serial/psb_zcsnmi.f90 @@ -81,7 +81,7 @@ real(kind(1.d0)) function psb_zcsnmi(a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsrws.f90 b/base/serial/psb_zcsrws.f90 index 6e8ecd39..8a84dfb6 100644 --- a/base/serial/psb_zcsrws.f90 +++ b/base/serial/psb_zcsrws.f90 @@ -94,7 +94,7 @@ subroutine psb_zcsrws(rw,a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcssm.f90 b/base/serial/psb_zcssm.f90 index 7528cb0d..8f7a1fad 100644 --- a/base/serial/psb_zcssm.f90 +++ b/base/serial/psb_zcssm.f90 @@ -87,8 +87,8 @@ subroutine psb_zcssm(alpha,t,b,beta,c,info,trans,unitd,d) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcssv.f90 b/base/serial/psb_zcssv.f90 index 66fe198d..1552443e 100644 --- a/base/serial/psb_zcssv.f90 +++ b/base/serial/psb_zcssv.f90 @@ -87,8 +87,8 @@ subroutine psb_zcssv(alpha,t,b,beta,c,info,trans,unitd,d) deallocate(work) call psb_erractionrestore(err_act) - if(info.ne.0) then - if (err_act.eq.psb_act_abort_) then + if(info /= 0) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zfixcoo.f90 b/base/serial/psb_zfixcoo.f90 index 8298e0fb..296a594c 100644 --- a/base/serial/psb_zfixcoo.f90 +++ b/base/serial/psb_zfixcoo.f90 @@ -84,17 +84,17 @@ Subroutine psb_zfixcoo(a,info,idir) case(0) ! Row major order call msort_up(nza,a%ia1(1),iaux(1),iret) - if (iret.eq.0) call zreordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + if (iret == 0) call zreordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) i = 1 j = i - do while (i.le.nza) - do while ((a%ia1(j).eq.a%ia1(i))) + do while (i <= nza) + do while ((a%ia1(j) == a%ia1(i))) j = j+1 if (j > nza) exit enddo nzl = j - i call msort_up(nzl,a%ia2(i),iaux(1),iret) - if (iret.eq.0) & + if (iret == 0) & & call zreordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) i = j enddo @@ -165,17 +165,17 @@ Subroutine psb_zfixcoo(a,info,idir) case(1) ! Col major order call msort_up(nza,a%ia2(1),iaux(1),iret) - if (iret.eq.0) call zreordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + if (iret == 0) call zreordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) i = 1 j = i - do while (i.le.nza) - do while ((a%ia2(j).eq.a%ia2(i))) + do while (i <= nza) + do while ((a%ia2(j) == a%ia2(i))) j = j+1 if (j > nza) exit enddo nzl = j - i call msort_up(nzl,a%ia1(i),iaux(1),iret) - if (iret.eq.0) & + if (iret == 0) & & call zreordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) i = j enddo @@ -254,7 +254,7 @@ Subroutine psb_zfixcoo(a,info,idir) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zgelp.f90 b/base/serial/psb_zgelp.f90 index 9e6da91f..228620e1 100644 --- a/base/serial/psb_zgelp.f90 +++ b/base/serial/psb_zgelp.f90 @@ -104,7 +104,7 @@ subroutine psb_zgelp(trans,iperm,x,info) call zgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='zgelp' call psb_errpush(info,name,a_err=ch_err) @@ -237,7 +237,7 @@ subroutine psb_zgelpv(trans,iperm,x,info) call zgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='zgelp' call psb_errpush(info,name,a_err=ch_err) diff --git a/base/serial/psb_zipcoo2csc.f90 b/base/serial/psb_zipcoo2csc.f90 index 4d8bc1ca..c6fd4334 100644 --- a/base/serial/psb_zipcoo2csc.f90 +++ b/base/serial/psb_zipcoo2csc.f90 @@ -204,7 +204,7 @@ subroutine psb_zipcoo2csc(a,info,clshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zipcoo2csr.f90 b/base/serial/psb_zipcoo2csr.f90 index 90f633a7..c6374aa3 100644 --- a/base/serial/psb_zipcoo2csr.f90 +++ b/base/serial/psb_zipcoo2csr.f90 @@ -203,7 +203,7 @@ subroutine psb_zipcoo2csr(a,info,rwshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zipcsr2coo.f90 b/base/serial/psb_zipcsr2coo.f90 index 1d1bf746..f0d14e49 100644 --- a/base/serial/psb_zipcsr2coo.f90 +++ b/base/serial/psb_zipcsr2coo.f90 @@ -92,7 +92,7 @@ Subroutine psb_zipcsr2coo(a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zneigh.f90 b/base/serial/psb_zneigh.f90 index 96ad646e..afb48cf8 100644 --- a/base/serial/psb_zneigh.f90 +++ b/base/serial/psb_zneigh.f90 @@ -86,7 +86,7 @@ subroutine psb_zneigh(a,idx,neigh,n,info,lev) ntl = 0 do i=ifl,ill nidx=neigh(i) - if ((nidx.ne.idx).and.(nidx.gt.0).and.(nidx.le.a%m)) then + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) if (info /= 0) then @@ -109,7 +109,7 @@ subroutine psb_zneigh(a,idx,neigh,n,info,lev) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zrwextd.f90 b/base/serial/psb_zrwextd.f90 index fe771a24..edfa8b3d 100644 --- a/base/serial/psb_zrwextd.f90 +++ b/base/serial/psb_zrwextd.f90 @@ -164,7 +164,7 @@ subroutine psb_zrwextd(nr,a,info,b,rowscale) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspclip.f90 b/base/serial/psb_zspclip.f90 index 144f1180..d3bfd0fd 100644 --- a/base/serial/psb_zspclip.f90 +++ b/base/serial/psb_zspclip.f90 @@ -146,7 +146,7 @@ subroutine psb_zspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspcnv.f90 b/base/serial/psb_zspcnv.f90 index 255a9cd7..2776541a 100644 --- a/base/serial/psb_zspcnv.f90 +++ b/base/serial/psb_zspcnv.f90 @@ -360,7 +360,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -550,7 +550,7 @@ subroutine psb_zspcnv1(a, info, afmt, upd, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspgetrow.f90 b/base/serial/psb_zspgetrow.f90 index e9cdf8b0..05607d82 100644 --- a/base/serial/psb_zspgetrow.f90 +++ b/base/serial/psb_zspgetrow.f90 @@ -118,7 +118,7 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) 9999 continue !!$ call psb_erractionrestore(err_act) call psb_erractionsave(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspgtdiag.f90 b/base/serial/psb_zspgtdiag.f90 index b4e225dd..2dce8539 100644 --- a/base/serial/psb_zspgtdiag.f90 +++ b/base/serial/psb_zspgtdiag.f90 @@ -89,7 +89,7 @@ subroutine psb_zspgtdiag(a,d,info) do i=1, rng, nrb irb=min(i+nrb-1,rng) call psb_sp_getblk(i,a,tmpa,info,lrw=irb) - if(info.ne.0) then + if(info /= 0) then info=4010 ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) @@ -112,7 +112,7 @@ subroutine psb_zspgtdiag(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspscal.f90 b/base/serial/psb_zspscal.f90 index 4ceca0dd..437023be 100644 --- a/base/serial/psb_zspscal.f90 +++ b/base/serial/psb_zspscal.f90 @@ -88,7 +88,7 @@ subroutine psb_zspscal(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index a487f748..1b4e277b 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -100,7 +100,7 @@ subroutine psb_zsymbmm(a,b,c,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -155,7 +155,7 @@ contains if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn else - if(index(ibcl(k)).eq.0) then + if(index(ibcl(k)) == 0) then index(ibcl(k))=istart istart=ibcl(k) length=length+1 diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 539bc66e..10c4724d 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -45,6 +45,7 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psi_mod use psb_penv_mod implicit None !....Parameters... @@ -57,7 +58,7 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) & loc_col,nprocs,n,itmpov, k,glx,& & l_ov_ix,l_ov_el,idx, flag_, err_act,m integer :: int_err(5),exch(3) - Integer, allocatable :: temp_ovrlap(:), ov_idx(:),ov_el(:),tmpgidx(:,:) + Integer, allocatable :: temp_ovrlap(:), tmpgidx(:,:) integer :: debug_level, debug_unit character(len=20) :: name @@ -331,66 +332,16 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) desc_a%loc_to_glob(:) = -1 do i=1,m k = desc_a%glob_to_loc(i) - if (k.gt.0) then + if (k > 0) then desc_a%loc_to_glob(k) = i endif enddo 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) - 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 - l_ov_el = l_ov_el+3 - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el - allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info) - if (info /= 0) then - info=4025 - int_err(1)=l_ov_ix+l_ov_el - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - end if + call psi_bld_tmpovrl(temp_ovrlap,desc_a,info) - 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) /= 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 - l_ov_ix = l_ov_ix + 1 - ov_idx(l_ov_ix) = -1 - - call psb_transfer(ov_idx,desc_a%ovrlap_index,info) - if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) deallocate(temp_ovrlap,stat=info) if (info /= 0) then info=4000 diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index 4bb03ddd..aa135e7d 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -48,6 +48,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) use psb_realloc_mod use psb_serial_mod use psb_const_mod + use psi_mod use psb_penv_mod implicit None include 'parts.fh' @@ -60,7 +61,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx integer :: int_err(5),exch(3) - integer, allocatable :: prc_v(:), temp_ovrlap(:), ov_idx(:),ov_el(:) + integer, allocatable :: prc_v(:), temp_ovrlap(:) integer :: debug_level, debug_unit character(len=20) :: name @@ -363,59 +364,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': error check:' ,err - 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) - 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 - l_ov_el = l_ov_el+3 - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el - allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info) - if (info /= psb_no_err_) then - info=4010 - err=info - call psb_errpush(err,name,a_err='psb_realloc') - 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) /= 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 - l_ov_ix = l_ov_ix + 1 - ov_idx(l_ov_ix) = -1 - - call psb_transfer(ov_idx,desc_a%ovrlap_index,info) - if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) + call psi_bld_tmpovrl(temp_ovrlap,desc_a,info) + if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info) if (info /= psb_no_err_) then info=4000 diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index 3d1a1257..9e42955b 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -47,6 +47,7 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) use psb_serial_mod use psb_const_mod use psb_error_mod + use psi_mod use psb_penv_mod implicit None !....Parameters... @@ -60,7 +61,7 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) & loc_col,nprocs,m,n,itmpov, k,glx,& & l_ov_ix,l_ov_el,idx, flag_, err_act integer :: int_err(5),exch(3) - Integer, allocatable :: temp_ovrlap(:), ov_idx(:),ov_el(:) + Integer, allocatable :: temp_ovrlap(:) integer :: debug_level, debug_unit character(len=20) :: name @@ -230,15 +231,6 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) call SearchInsKeyVal(desc_a%ptree,i,k,glx,info) endif enddo - if (k /= loc_row) then - write(0,*) 'Large cd init: ',k,loc_row - end if - - if (info /= 0) then - info=4000 - call psb_errpush(info,name) - goto 9999 - endif else @@ -301,66 +293,15 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) desc_a%loc_to_glob(:) = -1 do i=1,m k = desc_a%glob_to_loc(i) - if (k.gt.0) then + if (k > 0) then desc_a%loc_to_glob(k) = i endif enddo end if + + call psi_bld_tmpovrl(temp_ovrlap,desc_a,info) - 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) - 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 - l_ov_el = l_ov_el+3 - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el - allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info) - if (info /= 0) then - info=4025 - int_err(1)=l_ov_ix - call psb_errpush(info,name,i_err=int_err,a_err='integer') - 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) /= 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 - l_ov_ix = l_ov_ix + 1 - ov_idx(l_ov_ix) = -1 - - call psb_transfer(ov_idx,desc_a%ovrlap_index,info) - if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) deallocate(temp_ovrlap,stat=info) if (info /= 0) then info=4000 diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index 429e787c..acfc1b5e 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -145,7 +145,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index 4ebf0c58..f83b3717 100644 --- a/base/tools/psb_cdprt.f90 +++ b/base/tools/psb_cdprt.f90 @@ -129,13 +129,12 @@ subroutine psb_cdprt(iout,desc_p,glob,short) enddo write(iout,*) 'Ovrlap_elem' - counter = 1 - Do - idx=desc_p%ovrlap_elem(counter) - if (idx == -1) exit - n_elem_recv=desc_p%ovrlap_elem(counter+1) - if (.not.lshort) write(iout,*) idx,n_elem_Recv - counter = counter+2 + + Do counter = 1,size(desc_p%ovrlap_elem,1) + idx = desc_p%ovrlap_elem(counter,1) + n_elem_recv = desc_p%ovrlap_elem(counter,2) + proc = desc_p%ovrlap_elem(counter,3) + if (.not.lshort) write(iout,*) idx,n_elem_Recv,proc enddo else if (lglob) then @@ -236,15 +235,13 @@ subroutine psb_cdprt(iout,desc_p,glob,short) enddo write(iout,*) 'Ovrlap_elem' - counter = 1 - if (.not.lshort) then - Do - idx=desc_p%ovrlap_elem(counter) - if (idx == -1) exit - n_elem_recv=desc_p%ovrlap_elem(counter+1) - write(iout,*) desc_p%loc_to_glob(idx),idx,n_elem_Recv - counter = counter+2 - enddo - endif + + Do counter = 1,size(desc_p%ovrlap_elem,1) + idx = desc_p%ovrlap_elem(counter,1) + n_elem_recv = desc_p%ovrlap_elem(counter,2) + proc = desc_p%ovrlap_elem(counter,3) + if (.not.lshort) write(iout,*) idx,desc_p%loc_to_glob(idx),n_elem_Recv,proc + enddo + end if end subroutine psb_cdprt diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index f6e10f95..5ebd6153 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -181,15 +181,13 @@ subroutine psb_cdren(trans,iperm,desc_a,info) kh=desc_a%ovrlap_index(i) enddo if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': renumbering ovrlap_elem' - i = 1 - kh=desc_a%ovrlap_elem(i) - do while (kh /= -1) - desc_a%ovrlap_elem(i) = & - &desc_a%lprm(desc_a%ovrlap_elem(i)) - i = i+2 - kh=desc_a%ovrlap_elem(i) - enddo + & write(debug_unit,*) me,' ',& + & trim(name),': renumbering ovrlap_elem' + + do i=1, size(desc_a%ovrlap_elem,1) + desc_a%ovrlap_elem(i,1) = desc_a%lprm(desc_a%ovrlap_elem(i,1)) + end do + if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': done renumbering' else diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index f5574138..8f9fd854 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -179,7 +179,8 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) !count local rows number ! allocate work vector allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& - & desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info) + & desc_a%loc_to_glob(m),desc_a%lprm(1),& + & desc_a%ovrlap_elem(0,3),stat=info) if (info /= 0) then info=4025 int_err(1)=2*m+psb_mdata_size_+1 diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index bbc8db87..12da806f 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -239,7 +239,7 @@ subroutine psb_dallocv(x, desc_a,info,n) if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then n_col = max(1,psb_cd_get_local_cols(desc_a)) allocate(x(n_col),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4025 int_err(1)=n_col call psb_errpush(info,name,int_err,a_err='real(kind(1.d0))') @@ -252,7 +252,7 @@ subroutine psb_dallocv(x, desc_a,info,n) else if (psb_is_bld_desc(desc_a)) then n_row = max(1,psb_cd_get_local_rows(desc_a)) allocate(x(n_row),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4025 int_err(1)=n_row call psb_errpush(info,name,int_err,a_err='real(kind(1.d0))') diff --git a/base/tools/psb_dcdovr.F90 b/base/tools/psb_dcdovr.F90 index 5114d8c4..9f909a20 100644 --- a/base/tools/psb_dcdovr.F90 +++ b/base/tools/psb_dcdovr.F90 @@ -229,17 +229,16 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - halo(:) = desc_a%halo_index(:) - desc_ov%ovrlap_elem(:) = -1 - tmp_ovr_idx(:) = -1 - orig_ovr(:) = -1 - tmp_halo(:) = -1 - counter_e = 1 - tot_recv = 0 - counter_t = 1 - counter_h = 1 - counter_o = 1 - cntov_o = 1 + halo(:) = desc_a%halo_index(:) + tmp_ovr_idx(:) = -1 + orig_ovr(:) = -1 + tmp_halo(:) = -1 + counter_e = 1 + tot_recv = 0 + counter_t = 1 + counter_h = 1 + counter_o = 1 + cntov_o = 1 ! Init overlap with desc_a%ovrlap (if any) counter = 1 Do While (desc_a%ovrlap_index(counter) /= -1) @@ -388,7 +387,8 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype) Enddo if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) counter = counter+n_elem_recv ! @@ -462,16 +462,19 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype) tot_elem=i endif if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + & write(debug_unit,*) me,' ',trim(name),& + & ':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_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i Loop End',tmp_ovr_idx(1:10) + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop End',tmp_ovr_idx(1:10) Enddo if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),':End phase 1', m, n_col, tot_recv + & write(debug_unit,*) me,' ',trim(name),& + & ':End phase 1', m, n_col, tot_recv if (i_ovr <= novr) then ! @@ -549,7 +552,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype) ! owned the rows from the beginning! ! call psi_fnd_owner(iszs,works,temp,desc_a,info) - n_col=psb_cd_get_local_cols(desc_ov) + n_col = psb_cd_get_local_cols(desc_ov) do i=1,iszs idx = works(i) diff --git a/base/tools/psb_get_overlap.f90 b/base/tools/psb_get_overlap.f90 index 0aef5b6a..77d527f4 100644 --- a/base/tools/psb_get_overlap.f90 +++ b/base/tools/psb_get_overlap.f90 @@ -63,14 +63,9 @@ subroutine psb_get_ovrlap(ovrel,desc,info) goto 9999 end if - i=0 - j=1 - do while(desc%ovrlap_elem(j) /= -1) - i = i +1 - j = j + 2 - enddo + if (allocated(desc%ovrlap_elem) ) then - if (i > 0) then + i=size(desc%ovrlap_elem,1) allocate(ovrel(i),stat=info) if (info /= 0 ) then @@ -78,14 +73,10 @@ subroutine psb_get_ovrlap(ovrel,desc,info) call psb_errpush(info,name) goto 9999 end if - - i=0 - j=1 - do while(desc%ovrlap_elem(j) /= -1) - i = i +1 - ovrel(i) = desc%ovrlap_elem(j) - j = j + 2 - enddo + + do j=1,i + ovrel(j) = desc%ovrlap_elem(j,1) + end do else @@ -104,7 +95,7 @@ subroutine psb_get_ovrlap(ovrel,desc,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/tools/psb_ialloc.f90 b/base/tools/psb_ialloc.f90 index 6c46ee5d..9ffc6e21 100644 --- a/base/tools/psb_ialloc.f90 +++ b/base/tools/psb_ialloc.f90 @@ -238,7 +238,7 @@ subroutine psb_iallocv(x, desc_a, info,n) if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then n_col = max(1,psb_cd_get_local_cols(desc_a)) allocate(x(n_col),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4025 int_err(1)=n_col call psb_errpush(info,name,int_err,a_err='integer') @@ -247,7 +247,7 @@ subroutine psb_iallocv(x, desc_a, info,n) else if (psb_is_bld_desc(desc_a)) then n_row = max(1,psb_cd_get_local_rows(desc_a)) allocate(x(n_row),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4025 int_err(1)=n_row call psb_errpush(info,name,int_err,a_err='integer') diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index 20b8b4ee..63a2cda2 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -182,7 +182,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_ret_) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index 395d3696..25d01faf 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -79,15 +79,15 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) n=size(x) do i=1,n - if ((x(i).gt.psb_cd_get_local_cols(desc_a)).or.& - & (x(i).le.zero)) then + if ((x(i) > psb_cd_get_local_cols(desc_a)).or.& + & (x(i) <= zero)) then info=140 int_err(1)=tmp int_err(2)=psb_cd_get_local_cols(desc_a) exit else tmp=desc_a%loc_to_glob(x(i)) - if((tmp.gt.zero).or.(tmp.le.psb_cd_get_global_rows(desc_a))) then + if((tmp > zero).or.(tmp <= psb_cd_get_global_rows(desc_a))) then y(i)=tmp else info = 140 @@ -204,15 +204,15 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) n=size(x) do i=1,n - if ((x(i).gt.psb_cd_get_local_cols(desc_a)).or.& - & (x(i).le.zero)) then + if ((x(i) > psb_cd_get_local_cols(desc_a)).or.& + & (x(i) <= zero)) then info=140 int_err(1)=x(i) int_err(2)=psb_cd_get_local_cols(desc_a) exit else tmp=desc_a%loc_to_glob(x(i)) - if((tmp.gt.zero).or.(tmp.le.psb_cd_get_global_rows(desc_a))) then + if((tmp > zero).or.(tmp <= psb_cd_get_global_rows(desc_a))) then x(i)=tmp else info = 140 diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index 3b9053bc..2ca1edf1 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -238,7 +238,7 @@ subroutine psb_zallocv(x, desc_a,info,n) if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then n_col = max(1,psb_cd_get_local_cols(desc_a)) allocate(x(n_col),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4025 int_err(1)=n_col call psb_errpush(info,name,int_err,a_err='complex(kind(1.d0))') @@ -251,7 +251,7 @@ subroutine psb_zallocv(x, desc_a,info,n) else if (psb_is_bld_desc(desc_a)) then n_row = max(1,psb_cd_get_local_rows(desc_a)) allocate(x(n_row),stat=info) - if (info.ne.0) then + if (info /= 0) then info=4025 int_err(1)=n_row call psb_errpush(info,name,int_err,a_err='complex(kind(1.d0))') diff --git a/base/tools/psb_zcdovr.F90 b/base/tools/psb_zcdovr.F90 index 2fa68972..0093f75b 100644 --- a/base/tools/psb_zcdovr.F90 +++ b/base/tools/psb_zcdovr.F90 @@ -228,17 +228,16 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if - halo(:) = desc_a%halo_index(:) - desc_ov%ovrlap_elem(:) = -1 - tmp_ovr_idx(:) = -1 - orig_ovr(:) = -1 - tmp_halo(:) = -1 - counter_e = 1 - tot_recv = 0 - counter_t = 1 - counter_h = 1 - counter_o = 1 - cntov_o = 1 + halo(:) = desc_a%halo_index(:) + tmp_ovr_idx(:) = -1 + orig_ovr(:) = -1 + tmp_halo(:) = -1 + counter_e = 1 + tot_recv = 0 + counter_t = 1 + counter_h = 1 + counter_o = 1 + cntov_o = 1 ! Init overlap with desc_a%ovrlap (if any) counter = 1 Do While (desc_a%ovrlap_index(counter) /= -1) diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index 48da34a2..87db30a3 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -55,7 +55,7 @@ subroutine psb_zspfree(a, desc_a,info) integer :: ictxt, err_act character(len=20) :: name - if(psb_get_errstatus().ne.0) return + if(psb_get_errstatus() /= 0) return info=0 name = 'psb_zspfree' call psb_erractionsave(err_act)