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
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(:)
real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err
name='psb_damax'
@ -69,7 +68,6 @@ function psb_damax (x,desc_a, info, jx)
info=0
call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_)
@ -194,8 +192,7 @@ function psb_damaxv (x,desc_a, info)
! locals
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(:)
real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err
name='psb_damaxv'
@ -203,7 +200,6 @@ function psb_damaxv (x,desc_a, info)
info=0
call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_)
@ -325,7 +321,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
! locals
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)) :: amax
character(len=20) :: name, ch_err
name='psb_damaxvs'
@ -333,7 +329,6 @@ subroutine psb_damaxvs (res,x,desc_a, info)
info=0
call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_)
@ -454,8 +449,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& 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)),pointer :: tmpx(:)
real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err
name='psb_dmamaxs'
@ -463,7 +457,6 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
info=0
call psb_erractionsave(err_act)
locmax(:)=0.d0
amax=0.d0
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_check_mod
use psb_error_mod
use psb_blacs_mod
implicit none
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,&
& 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
name='psb_dasum'
@ -88,9 +88,9 @@ function psb_dasum (x,desc_a, info, jx)
ix = 1
if (present(jx)) then
ijx = jx
ijx = jx
else
ijx = 1
ijx = 1
endif
m = desc_a%matrix_data(psb_m_)
@ -98,44 +98,42 @@ function psb_dasum (x,desc_a, info, jx)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx)
if(info.ne.0) then
info=4010
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
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
info=3040
call psb_errpush(info,name)
goto 9999
end if
! compute local max
if ((m.ne.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)
! 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)*&
& tmpx(desc_a%ovrlap_elem(i))
i = i+2
end do
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,&
& ione, mone ,mycol)
else
asum=0.d0
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,&
& ione, mone ,mycol)
end if
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
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
end do
! compute global sum
call gsum2d(icontxt, 'A', asum)
else
asum=0.d0
! compute global sum
call gsum2d(icontxt, 'A', asum)
end if
else
asum=0.d0
asum=0.d0
end if
@ -148,8 +146,8 @@ function psb_dasum (x,desc_a, info, jx)
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
end function psb_dasum
@ -201,6 +199,7 @@ function psb_dasumv (x,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
implicit none
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,&
& 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
name='psb_dasumv'
@ -245,44 +243,42 @@ function psb_dasumv (x,desc_a, info)
! check vector correctness
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
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
info=3040
call psb_errpush(info,name)
goto 9999
end if
! compute local max
if ((m.ne.0)) then
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
do while (desc_a%ovrlap_elem(i).ne.-ione)
asum = asum -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& tmpx(desc_a%ovrlap_elem(i))
i = i+2
end do
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,&
& ione, mone ,mycol)
else
asum=0.d0
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,&
& ione, mone ,mycol)
end if
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
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
end do
! compute global sum
call gsum2d(icontxt, 'A', asum)
else
asum=0.d0
! compute global sum
call gsum2d(icontxt, 'A', asum)
end if
else
asum=0.d0
asum=0.d0
end if
psb_dasumv=asum
@ -294,8 +290,8 @@ function psb_dasumv (x,desc_a, info)
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
end function psb_dasumv
@ -348,6 +344,7 @@ subroutine psb_dasumvs (res,x,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
implicit none
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,&
& 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
name='psb_dasumvs'
@ -392,44 +388,42 @@ subroutine psb_dasumvs (res,x,desc_a, info)
! check vector correctness
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
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
info=3040
call psb_errpush(info,name)
goto 9999
end if
! compute local max
if ((m.ne.0)) then
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
do while (desc_a%ovrlap_elem(i).ne.-ione)
asum = asum -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& tmpx(desc_a%ovrlap_elem(i))
i = i+2
end do
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,&
& ione, mone ,mycol)
else
asum=0.d0
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, asum,&
& ione, mone ,mycol)
end if
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
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
end do
! compute global sum
call gsum2d(icontxt, 'A',asum)
else
asum=0.d0
! compute global sum
call gsum2d(icontxt, 'A', asum)
end if
else
asum=0.d0
asum=0.d0
end if
@ -442,8 +436,8 @@ subroutine psb_dasumvs (res,x,desc_a, info)
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
end subroutine psb_dasumvs

Write Preview
Loading…
Cancel
Save