From b20b2cacbb603a2cabb388a27f9969cb05961111 Mon Sep 17 00:00:00 2001 From: Alfredo Buttari Date: Mon, 12 Sep 2005 08:42:32 +0000 Subject: [PATCH] *** empty log message *** --- src/psblas/psb_damax.f90 | 107 ++++++++++++++++++--------------------- src/psblas/psb_dasum.f90 | 82 +++++++++++++----------------- src/serial/f77/Makefile | 38 ++++++++++++++ src/serial/f77/ddot.f | 49 ++++++++++++++++++ 4 files changed, 170 insertions(+), 106 deletions(-) create mode 100644 src/serial/f77/Makefile create mode 100644 src/serial/f77/ddot.f diff --git a/src/psblas/psb_damax.f90 b/src/psblas/psb_damax.f90 index d2821b2b..5eda35b9 100644 --- a/src/psblas/psb_damax.f90 +++ b/src/psblas/psb_damax.f90 @@ -27,8 +27,8 @@ function psb_damax (x,desc_a, info, jx) real(kind(1.d0)) :: psb_damax ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, m, i, k, imax, idamax real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -40,15 +40,15 @@ function psb_damax (x,desc_a, info, jx) locmax(:)=0.d0 amax=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) - goto 9999 - else if (npcol /= 1) then + goto 9999 + else if (npcol /= 1) then info = 2030 int_err(1) = npcol call psb_errpush(info,name) @@ -62,9 +62,9 @@ function psb_damax (x,desc_a, info, jx) ijx = 1 endif - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' @@ -79,10 +79,9 @@ function psb_damax (x,desc_a, info, jx) end if ! compute local max - if ((desc_data(psb_n_row_).gt.0).and.(m.ne.0)) then - tmpx => x(iix:,jjx) - imax=idamax(desc_data(n_row),tmpx,1) - amax=abs(tmpx(imax)) + if ((desc_a%matrix_data(psb_n_row_).gt.0).and.(m.ne.0)) then + imax=idamax(desc_a%matrix_data(psb_n_row_)-iix+1,x(iix,jjx),1) + amax=abs(x(iix+imax-1,jjx)) end if ! compute global max @@ -126,11 +125,11 @@ function psb_damaxv (x,desc_a, info) real(kind(1.d0)), intent(in) :: x(:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - real(kind(1.d0)) :: psb_damax + real(kind(1.d0)) :: psb_damaxv ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, ix, jx, temp(2) + integer :: int_err(5), err, icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, jx, temp(2), ix, ijx, m, imax, idamax real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -142,10 +141,10 @@ function psb_damaxv (x,desc_a, info) locmax(:)=0.d0 amax=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) @@ -160,29 +159,26 @@ function psb_damaxv (x,desc_a, info) ix = 1 jx = 1 - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) - call psb_chkvect(m,1,size(x,1),ix,jx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x,1),ix,jx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix.ne.1) then info=3040 call psb_errpush(info,name) + goto 9999 end if - err=info - call psb_errcomm(icontxt,err) - if(err.ne.0) goto 9999 - ! compute local max - if ((desc_data(psb_n_row_).gt.0).and.(m.ne.0)) then - tmpx => x(iix:,jjx) - imax=idamax(desc_data(n_row),tmpx,1) - amax=abs(tmpx(imax)) + if ((desc_a%matrix_data(psb_n_row_).gt.0).and.(m.ne.0)) then + imax=idamax(desc_a%matrix_data(psb_n_row_)-iix+1,x(iix),1) + amax=abs(x(iix+imax-1)) end if ! compute global max @@ -225,16 +221,15 @@ subroutine psb_damaxvs (res,x,desc_a, info, jx) use psb_error_mod implicit none - real(kind(1.d0)), intent(in) :: x(:,:) + real(kind(1.d0)), intent(in) :: x(:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info integer, optional, intent(in) :: jx real(kind(1.D0)), intent(out) :: res - real(kind(1.d0)) :: psb_damax ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, idamax real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -246,10 +241,10 @@ subroutine psb_damaxvs (res,x,desc_a, info, jx) locmax(:)=0.d0 amax=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) @@ -268,29 +263,26 @@ subroutine psb_damaxvs (res,x,desc_a, info, jx) ijx = 1 endif - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix.ne.1) then info=3040 call psb_errpush(info,name) + goto 9999 end if - err=info - call psb_errcomm(icontxt,err) - if(err.ne.0) goto 9999 - ! compute local max - if ((desc_data(psb_n_row_).gt.0).and.(m.ne.0)) then - tmpx => x(iix:,jjx) - imax=idamax(desc_data(n_row),tmpx,1) - amax=abs(tmpx(imax)) + if ((desc_a%matrix_data(psb_n_row_).gt.0).and.(m.ne.0)) then + imax=idamax(desc_a%matrix_data(psb_n_row_)-iix+1,x(iix),1) + amax=abs(tmpx(iix+imax-1)) end if ! compute global max @@ -332,15 +324,15 @@ subroutine psb_dmamaxs (res,x,desc_a, info) use psb_error_mod implicit none - real(kind(1.d0)), intent(in) :: x(:) + real(kind(1.d0)), intent(in) :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info real(kind(1.d0)), intent(out) :: res(:) ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, ix, jx, temp(2) - real(kind(1.d0)) :: locmax(2) + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, ix, jx, temp(2), ijx, m, imax, i, k, idamax + real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -351,10 +343,10 @@ subroutine psb_dmamaxs (res,x,desc_a, info) locmax(:)=0.d0 amax=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) @@ -369,31 +361,28 @@ subroutine psb_dmamaxs (res,x,desc_a, info) ix = 1 jx = 1 - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) k = min(size(x,2),size(res,1)) - call psb_chkvect(m,1,size(x,1),ix,jx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x,1),ix,jx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix.ne.1) then info=3040 call psb_errpush(info,name) + goto 9999 end if - err=info - call psb_errcomm(icontxt,err) - if(err.ne.0) goto 9999 - ! compute local max - if ((desc_data(psb_n_row_).gt.0).and.(m.ne.0)) then + if ((desc_a%matrix_data(psb_n_row_).gt.0).and.(m.ne.0)) then do i=1,k - tmpx => x(iix:,i) - imax=idamax(desc_data(n_row),tmpx,1) - res(i)=abs(tmpx(imax)) + imax=idamax(desc_a%matrix_data(psb_n_row_)-iix+1,x(iix,jjx),1) + res(i)=abs(x(iix+imax-1,jjx+i-1)) end do end if diff --git a/src/psblas/psb_dasum.f90 b/src/psblas/psb_dasum.f90 index 645dce06..1a1acbed 100644 --- a/src/psblas/psb_dasum.f90 +++ b/src/psblas/psb_dasum.f90 @@ -27,9 +27,9 @@ function psb_dasum (x,desc_a, info, jx) real(kind(1.d0)) :: psb_dasum ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) - real(kind(1.d0)) :: asum + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, m, i + real(kind(1.d0)) :: asum, dasum real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -39,10 +39,10 @@ function psb_dasum (x,desc_a, info, jx) asum=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) @@ -61,30 +61,27 @@ function psb_dasum (x,desc_a, info, jx) ijx = 1 endif - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,1,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix.ne.1) then info=3040 call psb_errpush(info,name) + goto 9999 end if - err=info - call psb_errcomm(icontxt,err) - if(err.ne.0) goto 9999 - ! compute local max if ((m.ne.0)) then - if(desc_data(psb_n_row_).gt.0) then - tmpx => x(iix:,jjx) - asum=dasum(desc_data(n_row),tmpx,ione) + if(desc_a%matrix_data(psb_n_row_).gt.0) then + asum=dasum(desc_a%matrix_data(psb_n_row_)-iix+1,x(iix,jjx),ione) ! adjust asum because overlapped elements are computed more than once i=1 @@ -149,9 +146,9 @@ function psb_dasumv (x,desc_a, info) real(kind(1.d0)) :: psb_dasumv ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) - real(kind(1.d0)) :: asum + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i + real(kind(1.d0)) :: asum, dasum real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -159,13 +156,12 @@ function psb_dasumv (x,desc_a, info) info=0 call psb_erractionsave(err_act) - locmax(:)=0.d0 asum=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) @@ -178,32 +174,29 @@ function psb_dasumv (x,desc_a, info) endif ix = 1 - jx = 1 + jx=1 - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,jx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix.ne.1) then info=3040 call psb_errpush(info,name) + goto 9999 end if - err=info - call psb_errcomm(icontxt,err) - if(err.ne.0) goto 9999 - ! compute local max if ((m.ne.0)) then - if(desc_data(psb_n_row_).gt.0) then - tmpx => x(:) - asum=dasum(desc_data(n_row),tmpx,ione) + if(desc_a%matrix_data(psb_n_row_).gt.0) then + asum=dasum(desc_a%matrix_data(psb_n_row_),x,ione) ! adjust asum because overlapped elements are computed more than once i=1 @@ -228,7 +221,6 @@ function psb_dasumv (x,desc_a, info) asum=0.d0 end if - psb_dasumv=asum call psb_erractionrestore(err_act) @@ -242,7 +234,7 @@ function psb_dasumv (x,desc_a, info) return end if return -end function psb_dasum +end function psb_dasumv ! Subroutine: psb_dasum vs @@ -269,9 +261,9 @@ subroutine psb_dasumvs (res,x,desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) - real(kind(1.d0)) :: asum + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i + real(kind(1.d0)) :: asum, dasum real(kind(1.d0)),pointer :: tmpx(:) character(len=20) :: name, ch_err @@ -279,13 +271,12 @@ subroutine psb_dasumvs (res,x,desc_a, info) info=0 call psb_erractionsave(err_act) - locmax(:)=0.d0 asum=0.d0 - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -1) then info = 2010 call psb_errpush(info,name) @@ -300,30 +291,27 @@ subroutine psb_dasumvs (res,x,desc_a, info) ix = 1 jx = 1 - m = desc_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,1,size(x),ix,jx,desc_data%matrix_data,info,iix,jjx) + call psb_chkvect(m,1,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) if(info.ne.0) then info=4010 ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix.ne.1) then info=3040 call psb_errpush(info,name) + goto 9999 end if - err=info - call psb_errcomm(icontxt,err) - if(err.ne.0) goto 9999 - ! compute local max if ((m.ne.0)) then - if(desc_data(psb_n_row_).gt.0) then - tmpx => x(:) - asum=dasum(desc_data(n_row),tmpx,ione) + if(desc_a%matrix_data(psb_n_row_).gt.0) then + asum=dasum(desc_a%matrix_data(psb_n_row_),x,ione) ! adjust asum because overlapped elements are computed more than once i=1 diff --git a/src/serial/f77/Makefile b/src/serial/f77/Makefile new file mode 100644 index 00000000..581cae9f --- /dev/null +++ b/src/serial/f77/Makefile @@ -0,0 +1,38 @@ +include ../../../Make.inc + +# +# The object files +# +FOBJS = daxpby.o dcsmm.o dcsnmi.o dcsrp.o dcssm.o \ + dcsupd.o dgelp.o dlpupd.o dswmm.o dswprt.o \ + dswsm.o smmp.o ddot.o + + +#zcsrck.o zcrnrmi.o zcsrmm.o zsrmv.o zcsrsm.o zsrsv.o + +OBJS=$(FOBJS) + +# +# Where the library should go, and how it is called. +# Note that we are regenerating most of libsparker.a on the fly. +LIBDIR=../../../lib +#LIBNAME=libsparker.a +LIBFILE=$(LIBDIR)/$(LIBNAME) +INCDIRS=-I. -I$(LIBDIR) + +# +# No change should be needed below +# + + +default: lib + +lib: $(OBJS) + +clean: cleanobjs + +veryclean: cleanobjs + +cleanobjs: + /bin/rm -f $(OBJS) + diff --git a/src/serial/f77/ddot.f b/src/serial/f77/ddot.f new file mode 100644 index 00000000..e04c7c25 --- /dev/null +++ b/src/serial/f77/ddot.f @@ -0,0 +1,49 @@ + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end