fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent e97cd11ce0
commit 62d596676a
2 changed files with 105 additions and 118 deletions
Show Stats Download Patch File Download Diff File

15
src/psblas/psb_damax.f90
Unescape Escape View File

@ -60,8 +60,7 @@ function psb_damax (x,desc_a, info, jx)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, i, k, imax, idamax & 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)) :: amax
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_damax' name='psb_damax'
@ -69,7 +68,6 @@ function psb_damax (x,desc_a, info, jx)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -194,8 +192,7 @@ function psb_damaxv (x,desc_a, info)
! locals ! locals
integer :: int_err(5), err, icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), err, icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, jx, temp(2), ix, ijx, m, imax, idamax & err_act, n, iix, jjx, jx, temp(2), ix, ijx, m, imax, idamax
real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)) :: amax
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_damaxv' name='psb_damaxv'
@ -203,7 +200,6 @@ function psb_damaxv (x,desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -325,7 +321,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, idamax & err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, idamax
real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_damaxvs' name='psb_damaxvs'
@ -333,7 +329,6 @@ subroutine psb_damaxvs (res,x,desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -454,8 +449,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ix, temp(2), ijx, m, imax, i, k, idamax & err_act, n, iix, jjx, ix, temp(2), ijx, m, imax, i, k, idamax
real(kind(1.d0)) :: locmax(2), amax real(kind(1.d0)) :: amax
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dmamaxs' name='psb_dmamaxs'
@ -463,7 +457,6 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)

196
src/psblas/psb_dasum.f90
Unescape Escape View File

@ -49,6 +49,7 @@ function psb_dasum (x,desc_a, info, jx)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:,:) real(kind(1.d0)), intent(in) :: x(:,:)
@ -61,7 +62,6 @@ function psb_dasum (x,desc_a, info, jx)
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, i & err_act, n, iix, jjx, temp(2), ix, ijx, m, i
real(kind(1.d0)) :: asum, dasum real(kind(1.d0)) :: asum, dasum
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dasum' name='psb_dasum'
@ -88,9 +88,9 @@ function psb_dasum (x,desc_a, info, jx)
ix = 1 ix = 1
if (present(jx)) then if (present(jx)) then
ijx = jx ijx = jx
else else
ijx = 1 ijx = 1
endif endif
m = desc_a%matrix_data(psb_m_) m = desc_a%matrix_data(psb_m_)
@ -98,44 +98,42 @@ function psb_dasum (x,desc_a, info, jx)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%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 if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (iix.ne.1) then if (iix.ne.1) then
info=3040 info=3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! compute local max ! compute local max
if ((m.ne.0)) then if ((m.ne.0)) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then 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) 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 ! adjust asum because overlapped elements are computed more than once
i=1 i=1
do while (desc_a%ovrlap_elem(i).ne.-ione) do while (desc_a%ovrlap_elem(i).ne.-ione)
asum = asum -& asum = asum -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& tmpx(desc_a%ovrlap_elem(i)) & abs(x(desc_a%ovrlap_elem(i)-iix+1,jjx))
i = i+2 i = i+2
end do end do
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,& call gsum2d(icontxt, 'A', asum)
& ione, mone ,mycol)
else
else asum=0.d0
asum=0.d0 ! compute global sum
! compute global sum call gsum2d(icontxt, 'A', asum)
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,& end if
& ione, mone ,mycol)
end if
else else
asum=0.d0 asum=0.d0
end if end if
@ -148,8 +146,8 @@ function psb_dasum (x,desc_a, info, jx)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end function psb_dasum end function psb_dasum
@ -201,6 +199,7 @@ function psb_dasumv (x,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:) real(kind(1.d0)), intent(in) :: x(:)
@ -212,7 +211,6 @@ function psb_dasumv (x,desc_a, info)
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i & err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i
real(kind(1.d0)) :: asum, dasum real(kind(1.d0)) :: asum, dasum
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dasumv' name='psb_dasumv'
@ -245,44 +243,42 @@ function psb_dasumv (x,desc_a, info)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a%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 if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (iix.ne.1) then if (iix.ne.1) then
info=3040 info=3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! compute local max ! compute local max
if ((m.ne.0)) then if ((m.ne.0)) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then if(desc_a%matrix_data(psb_n_row_).gt.0) then
asum=dasum(desc_a%matrix_data(psb_n_row_),x,ione) asum=dasum(desc_a%matrix_data(psb_n_row_),x,ione)
! adjust asum because overlapped elements are computed more than once ! adjust asum because overlapped elements are computed more than once
i=1 i=1
do while (desc_a%ovrlap_elem(i).ne.-ione) do while (desc_a%ovrlap_elem(i).ne.-ione)
asum = asum -& asum = asum -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& tmpx(desc_a%ovrlap_elem(i)) & abs(x(desc_a%ovrlap_elem(i)))
i = i+2 i = i+2
end do end do
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,& call gsum2d(icontxt, 'A', asum)
& ione, mone ,mycol)
else
else asum=0.d0
asum=0.d0 ! compute global sum
! compute global sum call gsum2d(icontxt, 'A', asum)
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,& end if
& ione, mone ,mycol)
end if
else else
asum=0.d0 asum=0.d0
end if end if
psb_dasumv=asum psb_dasumv=asum
@ -294,8 +290,8 @@ function psb_dasumv (x,desc_a, info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end function psb_dasumv end function psb_dasumv
@ -348,6 +344,7 @@ subroutine psb_dasumvs (res,x,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:) real(kind(1.d0)), intent(in) :: x(:)
@ -359,7 +356,6 @@ subroutine psb_dasumvs (res,x,desc_a, info)
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i & err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i
real(kind(1.d0)) :: asum, dasum real(kind(1.d0)) :: asum, dasum
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dasumvs' name='psb_dasumvs'
@ -392,44 +388,42 @@ subroutine psb_dasumvs (res,x,desc_a, info)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a%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 if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (iix.ne.1) then if (iix.ne.1) then
info=3040 info=3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! compute local max ! compute local max
if ((m.ne.0)) then if ((m.ne.0)) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then if(desc_a%matrix_data(psb_n_row_).gt.0) then
asum=dasum(desc_a%matrix_data(psb_n_row_),x,ione) asum=dasum(desc_a%matrix_data(psb_n_row_),x,ione)
! adjust asum because overlapped elements are computed more than once ! adjust asum because overlapped elements are computed more than once
i=1 i=1
do while (desc_a%ovrlap_elem(i).ne.-ione) do while (desc_a%ovrlap_elem(i).ne.-ione)
asum = asum -& asum = asum -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& tmpx(desc_a%ovrlap_elem(i)) & abs(x(desc_a%ovrlap_elem(i)))
i = i+2 i = i+2
end do end do
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,& call gsum2d(icontxt, 'A',asum)
& ione, mone ,mycol)
else
else asum=0.d0
asum=0.d0 ! compute global sum
! compute global sum call gsum2d(icontxt, 'A', asum)
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,& end if
& ione, mone ,mycol)
end if
else else
asum=0.d0 asum=0.d0
end if end if
@ -442,8 +436,8 @@ subroutine psb_dasumvs (res,x,desc_a, info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end subroutine psb_dasumvs end subroutine psb_dasumvs

Write Preview
Loading…
Cancel
Save