From 83a9ee01881f6acd46069e1baa5bc7c9bcb9c389 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 23 Mar 2006 14:10:50 +0000 Subject: [PATCH] Fixes from complex version. --- src/modules/psb_prec_mod.f90 | 12 ---- src/psblas/psb_dspmm.f90 | 61 +++++++------------ src/psblas/psb_dspsm.f90 | 25 +++----- src/serial/dp/dcoco.f | 23 ++++--- src/serial/dp/dcoinco.f | 112 ----------------------------------- 5 files changed, 47 insertions(+), 186 deletions(-) delete mode 100644 src/serial/dp/dcoinco.f diff --git a/src/modules/psb_prec_mod.f90 b/src/modules/psb_prec_mod.f90 index a837c322..ed5e9071 100644 --- a/src/modules/psb_prec_mod.f90 +++ b/src/modules/psb_prec_mod.f90 @@ -140,16 +140,4 @@ end interface end subroutine psb_dprc_aply1 end interface - - interface psb_splu - subroutine psb_dsplu(a,l,u,d,info,blck) - use psb_spmat_type - integer, intent(out) :: info - type(psb_dspmat_type),intent(in) :: a - type(psb_dspmat_type),intent(inout) :: l,u - type(psb_dspmat_type),intent(in), optional, target :: blck - real(kind(1.d0)), intent(inout) :: d(:) - end subroutine psb_dsplu - end interface - end module psb_prec_mod diff --git a/src/psblas/psb_dspmm.f90 b/src/psblas/psb_dspmm.f90 index d61ff0ef..f292ddfc 100644 --- a/src/psblas/psb_dspmm.f90 +++ b/src/psblas/psb_dspmm.f90 @@ -207,7 +207,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if end if - iwork(1)=0.d0 + iwork(1)=dzero ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) @@ -245,16 +245,12 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(idoswap.lt.0) x(nrow:ncol,1:ik)=0.d0 ib1=min(nb,ik) xp => x(iix:lldx,jjx:jjx+ib1-1) if(idoswap.gt.0)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,dzero,xp,desc_a,iwork,info) -!!$ & call PSI_dSwapData(ior(SWAP_SEND,SWAP_RECV),ib1,& -!!$ & dzero,x(iix,jjx),lldx,desc_a%matrix_data,& -!!$ & desc_a%halo_index,iwork,liwork,info) blk: do i=1, ik, nb @@ -264,24 +260,19 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if((ib1.gt.0).and.(idoswap.gt.0))& & call psi_swapdata(psb_swap_send_,ib1,& & dzero,xp,desc_a,iwork,info) -!!$ & call PSI_dSwapData(SWAP_SEND,ib1,& -!!$ & dzero,x(iix,jjx+i+ib-1),lldx,desc_a%matrix_data,& -!!$ & desc_a%halo_index,iwork,liwork,info) + if(info.ne.0) exit blk ! local Matrix-vector product - call dcsmm(itrans,nrow,ib,ncol,alpha,a%pr,a%fida,& - & a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pl,& - & x(iix,jjx+i-1),lldx,beta,y(iiy,jjy+i-1),lldy,& - & iwork,liwork,info) + call psb_csmm(alpha,a,x(iix:lldx,jjx:jjx+ib-1),& + & beta,y(iiy:lldy,jjy:jjy+ib-1),info,trans=itrans) + if(info.ne.0) exit blk if((ib1.gt.0).and.(idoswap.gt.0))& & call psi_swapdata(psb_swap_send_,ib1,& & dzero,xp,desc_a,iwork,info) -!!$ & call PSI_dSwapData(SWAP_RECV,ib1,& -!!$ & dzero,x(iix,jjx+i+ib-1),lldx,desc_a%matrix_data,& -!!$ & desc_a%halo_index,iwork,liwork,info) + if(info.ne.0) exit blk end do blk @@ -323,27 +314,25 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(idoswap.lt.0) y(nrow:ncol,1:ik)=0.d0 + y(iiy+nrow+1-1:iiy+ncol,1:ik)=dzero ! local Matrix-vector product - call dcsmm(itrans,ncol,ik,nrow,alpha,a%pr,a%fida,& - & a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pl,& - & x(iix,jjx),lldx,beta,y(iiy,jjy),lldy,& - & iwork,liwork,info) + + call psb_csmm(alpha,a,x(iix:lldx,jjx:jjx+ik-1),& + & beta,y(iiy:lldy,jjy:jjy+ik-1),info,trans=itrans) + if(info.ne.0) then info = 4010 - ch_err='dcsmm' + ch_err='csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if yp => y(iiy:lldy,jjy:jjy+ik-1) - if(idoswap.gt.0)& + if (idoswap/=0)& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,done,yp,desc_a,iwork,info) -!!$ & call PSI_dSwapTran(ior(SWAP_SEND,SWAP_RECV),& -!!$ & ik,done,y(iiy,jjy),lldy,desc_a%matrix_data,& -!!$ & desc_a%halo_index,iwork,liwork,info) + if(info.ne.0) then info = 4010 ch_err='PSI_dSwapTran' @@ -579,18 +568,16 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(idoswap.lt.0) then - x(nrow:ncol)=0.d0 + if (idoswap == 0) then + x(nrow+1:ncol)=dzero else call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & dzero,x,desc_a,iwork,info,data=psb_comm_halo_) end if ! local Matrix-vector product - call dcsmm(itrans,nrow,ib,ncol,alpha,a%pl,a%fida,& - & a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & x(iix),lldx,beta,y(iiy),lldy,& - & iwork,liwork,info) + call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info) + if(info.ne.0) then info = 4011 call psb_errpush(info,name) @@ -630,15 +617,13 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& end if xp => x(iix:lldx) - yp => x(iiy:lldy) + yp => y(iiy:lldy) - if(idoswap.lt.0) y(nrow:ncol)=0.d0 + yp(nrow+1:ncol)=dzero ! local Matrix-vector product - call dcsmm(itrans,ncol,ik,nrow,alpha,a%pr,a%fida,& - & a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pl,& - & x(iix),lldx,beta,y(iiy),lldy,& - & iwork,liwork,info) + call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans) + if(info.ne.0) then info = 4010 ch_err='dcsmm' @@ -646,7 +631,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if - if(idoswap.gt.0)& + if(idoswap /= 0)& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info) if(info.ne.0) then diff --git a/src/psblas/psb_dspsm.f90 b/src/psblas/psb_dspsm.f90 index a00e1fbc..666a5a35 100644 --- a/src/psblas/psb_dspsm.f90 +++ b/src/psblas/psb_dspsm.f90 @@ -256,10 +256,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& end if ! Perform local triangular system solve - call dcssm(itrans,nrow,ik,alpha,lunitd,id,a%pr,& - & a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,& - & a%pl,x(iix,jjx),lldx,beta,y(iiy,jjy),lldy,& - & iwork,liwork,info) + xp => x(iix:lldx,jjx:jjx+ik-1) + 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 info = 4010 ch_err='dcssm' @@ -269,12 +269,9 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if(lchoice.gt.0) then - yp => y(iiy:lldy,jjy:jjy+ik-1) + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & done,yp,desc_a,iwork,info) -!!$ call PSI_dSwapData(ior(SWAP_SEND,SWAP_RECV),ik,& -!!$ & done,y,lldy,desc_a%matrix_data,desc_a%ovrlap_index,& -!!$ & iwork,liwork,info) i=0 ! switch on update type @@ -547,10 +544,10 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& end if ! Perform local triangular system solve - call dcssm(itrans,nrow,ik,alpha,lunitd,id,a%pr,& - & a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,& - & a%pl,x,lldx,beta,y,lldy,& - & iwork,liwork,info) + xp => x(iix:lldx) + yp => y(iiy:lldy) + call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) + if(info.ne.0) then info = 4010 ch_err='dcssm' @@ -560,12 +557,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if(lchoice.gt.0) then - yp => y(iiy:lldy) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info) -!!$ call PSI_dSwapData(ior(SWAP_SEND,SWAP_RECV),ik,& -!!$ & done,y,lldy,desc_a%matrix_data,desc_a%ovrlap_index,& -!!$ & iwork,liwork,info) i=0 ! switch on update type diff --git a/src/serial/dp/dcoco.f b/src/serial/dp/dcoco.f index 4db7752e..abe6a008 100644 --- a/src/serial/dp/dcoco.f +++ b/src/serial/dp/dcoco.f @@ -108,8 +108,8 @@ c c error handling c if(ierror.ne.0) then - call fcpsb_errpush(ierror,name,int_val) - goto 9999 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 end if if (descra(1:1).eq.'G') then @@ -250,18 +250,25 @@ c ... sum the duplicated element ... 20 continue else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then - + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + end if c else if (trans.ne.'N') then c c to do c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 end if @@ -272,8 +279,8 @@ c call fcpsb_erractionrestore(err_act) if ( err_act .ne. 0 ) then - call fcpsb_serror() - return + call fcpsb_serror() + return endif return diff --git a/src/serial/dp/dcoinco.f b/src/serial/dp/dcoinco.f deleted file mode 100644 index fc0cbe82..00000000 --- a/src/serial/dp/dcoinco.f +++ /dev/null @@ -1,112 +0,0 @@ -C -C Parallel Sparse BLAS v2.0 -C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCOINCO(M,N,DESCRA,A,IA1,IA2, - + INFOA,IA,JA,LATOT,LIA1TOT,LIA2TOT, - + DESCRH,H,IH1,IH2,INFOH,IH,JH,WORK,LWORK,IERROR) - - IMPLICIT NONE - INCLUDE 'psb_const.fh' -C .. Scalar Arguments .. - INTEGER LWORK, M, N, IERROR - INTEGER LATOT,LIA1TOT,LIA2TOT,IA,JA,IH,JH -C .. Array Arguments .. - DOUBLE PRECISION A(*), H(*), WORK(LWORK) - INTEGER IA1(*), IA2(*), IH1(*), IH2(*), - + INFOA(*), INFOH(*) - CHARACTER DESCRA*11, DESCRH*11 - -C .. Local scalars .. - INTEGER I, J, NZH, nza -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'DCOINCO\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - NZH = INFOH(NNZ_) - NZA = INFOA(NNZ_) - - if ((nza+nzh).le.min(latot,lia1tot,lia2tot)) then -C -C In this case we are (hopefully) safe -C - -C Insert Element in COO Format - DO J = 1, NZH - IF ((IH1(J).GE.IH).AND.(IH1(J).LT.IH+M).AND. - $ (IH2(J).GE.JH).AND.(IH2(J).LT.JH+N)) THEN -C If current element belongs to submatrix to insert - nza = nza + 1 - A(nza) = H(J) - IA1(nza) = IH1(J)+IA-IH - IA2(nza) = IH2(J)+JA-JH - ENDIF - ENDDO - - else - -C -C Most likely will have to give up, but try anyway -C -C Insert Element in COO Format - DO J = 1, NZH - IF ((IH1(J).GE.IH).AND.(IH1(J).LT.IH+M).AND. - $ (IH2(J).GE.JH).AND.(IH2(J).LT.JH+N)) THEN -C If current element belongs to submatrix to insert - nza = nza + 1 - - IF ((nza.le.LATOT) .and.(nza.le.LIA1TOT) - + .and.(nza.le.LIA2TOT)) THEN - A(nza) = H(J) - IA1(nza) = IH1(J)+IA-IH - IA2(nza) = IH2(J)+JA-JH - else - IF (nza.GT.LATOT) THEN - IERRV(1) = 10 - IERRV(2) = nza - ELSE IF (nza.GT.LIA1TOT) THEN - IERRV(1) = 20 - IERRV(2) = nza - ELSE IF (nza.GT.LIA2TOT) THEN - IERRV(1) = 30 - IERRV(2) = nza - ENDIF - RETURN - endif - ENDIF - ENDDO - endif - infoa(nnz_) = nza - - return - END