fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-16 19:02:09 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas2-dev:

Browse Source 
base/modules/psb_tools_mod.f90
 base/serial/psb_dcoins.f90
 base/serial/psb_update_mod.f90
 base/serial/psb_zcoins.f90
 docs/pdf/toolsrout.tex
 docs/userguide.pdf
 test/pargen/Makefile
 test/pargen/ppde.f90

Defined new is_owned, is_local routines.
Merged performance fix for SP5.
This commit is contained in:
Salvatore Filippone
2008-04-15 12:18:04 +00:00
parent 486a011f4b
commit 93b9ebbcf0
8 changed files with 6931 additions and 5371 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_tools_mod.f90
+107
View File
@@ -586,9 +586,116 @@ Module psb_tools_mod
module procedure psb_dlinmap_asb, psb_zlinmap_asb
end interface
interface psb_is_owned
module procedure psb_is_owned
end interface
interface psb_is_local
module procedure psb_is_local
end interface
interface psb_owned_index
module procedure psb_owned_index, psb_owned_index_v
end interface
interface psb_local_index
module procedure psb_local_index, psb_local_index_v
end interface
contains
function psb_is_owned(idx,desc)
use psb_descriptor_type
implicit none
integer, intent(in) :: idx
type(psb_desc_type), intent(in) :: desc
logical :: psb_is_owned
logical :: res
integer :: info
call psb_owned_index(res,idx,desc,info)
if (info /= 0) res=.false.
psb_is_owned = res
end function psb_is_owned
function psb_is_local(idx,desc)
use psb_descriptor_type
implicit none
integer, intent(in) :: idx
type(psb_desc_type), intent(in) :: desc
logical :: psb_is_local
logical :: res
integer :: info
call psb_local_index(res,idx,desc,info)
if (info /= 0) res=.false.
psb_is_local = res
end function psb_is_local
subroutine psb_owned_index(res,idx,desc,info)
use psb_descriptor_type
implicit none
integer, intent(in) :: idx
type(psb_desc_type), intent(in) :: desc
logical, intent(out) :: res
integer, intent(out) :: info
integer :: lx
call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.)
res = (lx>0)
end subroutine psb_owned_index
subroutine psb_owned_index_v(res,idx,desc,info)
use psb_descriptor_type
implicit none
integer, intent(in) :: idx(:)
type(psb_desc_type), intent(in) :: desc
logical, intent(out) :: res(:)
integer, intent(out) :: info
integer, allocatable :: lx(:)
allocate(lx(size(idx)),stat=info)
res=.false.
if (info /= 0) return
call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.)
res = (lx>0)
end subroutine psb_owned_index_v
subroutine psb_local_index(res,idx,desc,info)
use psb_descriptor_type
implicit none
integer, intent(in) :: idx
type(psb_desc_type), intent(in) :: desc
logical, intent(out) :: res
integer, intent(out) :: info
integer :: lx
call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.)
res = (lx>0)
end subroutine psb_local_index
subroutine psb_local_index_v(res,idx,desc,info)
use psb_descriptor_type
implicit none
integer, intent(in) :: idx(:)
type(psb_desc_type), intent(in) :: desc
logical, intent(out) :: res(:)
integer, intent(out) :: info
integer, allocatable :: lx(:)
allocate(lx(size(idx)),stat=info)
res=.false.
if (info /= 0) return
call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.)
res = (lx>0)
end subroutine psb_local_index_v
subroutine psb_get_boundary(bndel,desc,info)
use psb_descriptor_type
use psi_mod
base/serial/psb_dcoins.f90
+5
View File
@@ -494,6 +494,10 @@ contains
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(:)
integer :: i,ir,ic
character(len=20) :: name, ch_err
name='psb_inner_upd'
if (present(gtl)) then
if (.not.present(ng)) then
@@ -504,6 +508,7 @@ contains
do i=1, nz
nza = nza + 1
if (nza>maxsz) then
call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /))
info = -71
return
endif
base/serial/psb_update_mod.f90
+68 -191
View File
@@ -62,11 +62,11 @@ contains
type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
real(psb_dpk_), intent(in) :: val(*)
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
info = 0
@@ -107,11 +107,11 @@ contains
type(psb_zspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
complex(psb_dpk_), intent(in) :: val(*)
complex(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
info = 0
@@ -170,11 +170,11 @@ contains
type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
real(psb_dpk_), intent(in) :: val(*)
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
integer :: debug_level, debug_unit
character(len=20) :: name='d_csr_srch_upd'
@@ -211,51 +211,20 @@ contains
i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
!!$
ip = -1
lb = i1
ub = i2-1
do
if (lb > ub) exit
m = (lb+ub)/2
if (ic == a%ia1(m)) then
ip = m
lb = ub + 1
else if (ic < a%ia1(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Discarding row that does not belong to us.'
@@ -277,7 +246,7 @@ contains
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc = i2-i1
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
@@ -322,48 +291,18 @@ contains
i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
ip = -1
lb = i1
ub = i2-1
do
if (lb > ub) exit
m = (lb+ub)/2
if (ic == a%ia1(m)) then
ip = m
lb = ub + 1
else if (ic < a%ia1(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
@@ -383,7 +322,7 @@ contains
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc = i2-i1
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
@@ -419,11 +358,11 @@ contains
type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
real(psb_dpk_), intent(in) :: val(*)
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
integer :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,nnz,dupl
integer :: debug_level, debug_unit
@@ -644,11 +583,11 @@ contains
type(psb_dspmat_type), intent(inout), target :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
real(psb_dpk_), intent(in) :: val(*)
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
integer, pointer :: ia1(:), ia2(:), ia3(:),&
& ja_(:), ka_(:)
@@ -882,11 +821,11 @@ contains
type(psb_zspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
complex(psb_dpk_), intent(in) :: val(*)
complex(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
integer :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m,dupl
@@ -924,50 +863,18 @@ contains
i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
!!$
ip = -1
lb = i1
ub = i2-1
do
if (lb > ub) exit
m = (lb+ub)/2
if (ic == a%ia1(m)) then
ip = m
lb = ub + 1
else if (ic < a%ia1(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
@@ -1035,48 +942,18 @@ contains
i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
ip = -1
lb = i1
ub = i2-1
do
if (lb > ub) exit
m = (lb+ub)/2
if (ic == a%ia1(m)) then
ip = m
lb = ub + 1
else if (ic < a%ia1(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',a%ia1(i1:i2-1)
info = i
return
end if
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
@@ -1096,7 +973,7 @@ contains
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc = i2-i1
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
call ibsrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
@@ -1132,11 +1009,11 @@ contains
type(psb_zspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
complex(psb_dpk_), intent(in) :: val(*)
complex(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
integer :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,nnz,dupl
integer :: debug_level, debug_unit
@@ -1360,11 +1237,11 @@ contains
type(psb_zspmat_type), intent(inout), target :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(in) :: ia(:),ja(:)
integer, intent(inout) :: nza
complex(psb_dpk_), intent(in) :: val(*)
complex(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, intent(in), optional :: ng,gtl(:)
integer, pointer :: ia1(:), ia2(:), ia3(:),&
& ja_(:), ka_(:)
base/serial/psb_zcoins.f90
+67 -32
View File
@@ -29,9 +29,30 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psbzcoins.f90
! Subroutine:
! Parameters:
! File: psb_zcoins.f90
! Subroutine: psb_zcoins
! Takes a cloud of coefficients and inserts them into a sparse matrix.
! This subroutine is the serial, inner counterpart to the outer, user-level
! psb_spins.
!
! Arguments:
!
! nz - integer, input The number of points to insert.
! ia(:) - integer, input The row indices of the coefficients.
! ja(:) - integer, input The column indices of the coefficients.
! val(:) - complex, input The values of the coefficients to be inserted.
! a - type(psb_zspmat_type), inout The sparse destination matrix.
! imin - integer, input The minimum valid row index
! imax - integer, input The maximum valid row index
! jmin - integer, input The minimum valid col index
! jmax - integer, input The maximum valid col index
! info - integer, output Return code.
! gtl(:) - integer, input,optional An index mapping to be applied
! default: identity
! rebuild - logical, input, optional Rebuild in case of update
! finding a new index. Default: false.
! Not fully tested.
!
subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type
@@ -54,7 +75,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
character(len=5) :: ufida
integer :: ng, nza, isza,spstate, &
& ip1, nzl, err_act, int_err(5), iupd, irst
logical, parameter :: debug=.false.
integer :: debug_level, debug_unit
logical :: rebuild_
character(len=20) :: name, ch_err
type(psb_zspmat_type) :: tmp
@@ -62,6 +83,8 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
name='psb_zcoins'
info = 0
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0
if (nz <= 0) then
@@ -140,9 +163,9 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
endif
if (debug) then
if (debug_level >= psb_debug_serial_) then
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
write(debug_unit,*) trim(name),': insert discarded items '
end if
end if
if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
@@ -172,9 +195,9 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
endif
if (debug) then
if (debug_level >= psb_debug_serial_) then
if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items '
write(debug_unit,*) trim(name),': update discarded items '
end if
end if
@@ -185,7 +208,8 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
a%ia2(ip1+psb_nnz_) = nza
end select
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),': (UPD) : NZA:',nza
case (psb_upd_srch_)
@@ -194,8 +218,10 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
if (info > 0) then
if (rebuild_) then
if (debug) write(0,*)&
& 'COINS: Going through rebuild_ fingers crossed!'
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*)&
& trim(name),&
& ': Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
call psb_spcnv(a,tmp,info,afmt='coo')
@@ -206,9 +232,9 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
goto 9999
endif
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Rebuild size',tmp%infoa(psb_nnz_) ,irst
call psb_sp_transfer(tmp,a,info)
if(info /= izero) then
info=4010
@@ -225,8 +251,9 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
goto 9999
endif
if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza,irst,nz
if (debug_level >= psb_debug_serial_) write(debug_unit,*)&
& trim(name),': Reinserting',a%fida,nza,isza,irst,nz
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then
@@ -245,7 +272,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
ch_err='psb_inner_ins'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
endif
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
end if
@@ -321,14 +348,13 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
goto 9999
endif
if (debug) then
if (debug_level >= psb_debug_serial_) then
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
write(debug_unit,*) trim(name),': insert discarded items '
end if
end if
if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
!!$ write(0,*) 'Settind del_bnd_ 2: ',nza
endif
call psb_sp_setifld(nza,psb_nnz_,a,info)
@@ -350,14 +376,15 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
goto 9999
endif
if (debug) then
if (debug_level >= psb_debug_serial_) then
if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items '
write(debug_unit,*) trim(name),': update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),':(UPD) : NZA:',nza
case (psb_upd_srch_)
@@ -366,15 +393,17 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
if (info > 0) then
if (rebuild_) then
if (debug) write(0,*)&
& 'COINS: Going through rebuild_ fingers crossed!'
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*)&
& trim(name),&
& ': Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
call psb_spcnv(a,tmp,info,afmt='coo')
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Rebuild size',tmp%infoa(psb_nnz_) ,irst
call psb_sp_transfer(tmp,a,info)
call psb_sp_info(psb_nztotreq_,a,nza,info)
call psb_sp_info(psb_nzsizereq_,a,isza,info)
@@ -385,8 +414,9 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
goto 9999
endif
if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza
if (debug_level >= psb_debug_serial_) write(debug_unit,*)&
& trim(name),': Reinserting',a%fida,nza,isza
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then
@@ -405,7 +435,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
ch_err='psb_inner_ins'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
endif
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
end if
@@ -438,6 +468,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif
call psb_erractionrestore(err_act)
return
@@ -463,6 +494,10 @@ contains
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(:)
integer :: i,ir,ic
character(len=20) :: name, ch_err
name='psb_inner_upd'
if (present(gtl)) then
if (.not.present(ng)) then
@@ -473,7 +508,7 @@ contains
do i=1, nz
nza = nza + 1
if (nza>maxsz) then
write(0,*) 'Out of bounds in INNER_UPD ',nza,maxsz
call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /))
info = -71
return
endif
docs/pdf/toolsrout.tex
+174 -5
View File
@@ -1058,11 +1058,6 @@ An integer value; 0 means no error has been detected.
\item The default \verb|I|gnore means that the negative output is the
only action taken on an out-of-range input.
\end{enumerate}
%
%% psb_loc_to_glob %%
%
\subroutine{psb\_loc\_to\_glob}{Local to global indices conversion}
\syntax{call psb\_loc\_to\_glob}{x, y, desc\_a, info, iact}
@@ -1113,6 +1108,180 @@ An integer value; 0 means no error has been detected.
%
%% psb_loc_to_glob %%
%
\subroutine{psb\_is\_owned}{}
\syntax{call psb\_is\_owned}{x, desc\_a}
\begin{description}
\item[Type:] Asynchronous.
\item[\bf On Entry]
\item[x] Integer index.\\
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf in}.\\
Specified as: a scalar integer.\\
\item[desc\_a] the communication descriptor.\\
Scope:{\bf local}.\\
Type:{\bf required}.\\
Intent: {\bf in}.\\
Specified as: a structured data of type \descdata.
\end{description}
\begin{description}
\item[\bf On Return]
\item[Function value] A logical mask which is true if
$x$ is owned by the current process
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf out}.\\
\end{description}
\section*{Notes}
\begin{enumerate}
\item This routine returns a \verb|.true.| value for an index
that is strictly owned by the current process, excluding the halo
indices
\end{enumerate}
\subroutine{psb\_owned\_index}{}
\syntax{call psb\_owned\_index}{y, x, desc\_a, info}
\begin{description}
\item[Type:] Asynchronous.
\item[\bf On Entry]
\item[x] Integer indices.\\
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf in, inout}.\\
Specified as: a scalar or a rank one integer array.\\
\item[desc\_a] the communication descriptor.\\
Scope:{\bf local}.\\
Type:{\bf required}.\\
Intent: {\bf in}.\\
Specified as: a structured data of type \descdata.
\item[iact] specifies action to be taken in case of range errors.
Scope: {\bf global} \\
Type: {\bf optional}\\
Intent: {\bf in}.\\
Specified as: a character variable \verb|I|gnore, \verb|W|arning or
\verb|A|bort, default \verb|I|gnore.
\end{description}
\begin{description}
\item[\bf On Return]
\item[y] A logical mask which is true for all corresponding entries of
$x$ that are owned by the current process
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf out}.\\
Specified as: a scalar or rank one logical array.
\item[info] Error code.\\
Scope: {\bf local} \\
Type: {\bf required} \\
Intent: {\bf out}.\\
An integer value; 0 means no error has been detected.
\end{description}
\section*{Notes}
\begin{enumerate}
\item This routine returns a \verb|.true.| value for those indices
that are strictly owned by the current process, excluding the halo
indices
\end{enumerate}
\subroutine{psb\_is\_local}{}
\syntax{call psb\_is\_local}{x, desc\_a}
\begin{description}
\item[Type:] Asynchronous.
\item[\bf On Entry]
\item[x] Integer index.\\
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf in}.\\
Specified as: a scalar integer.\\
\item[desc\_a] the communication descriptor.\\
Scope:{\bf local}.\\
Type:{\bf required}.\\
Intent: {\bf in}.\\
Specified as: a structured data of type \descdata.
\end{description}
\begin{description}
\item[\bf On Return]
\item[Function value] A logical mask which is true if
$x$ is local to the current process
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf out}.\\
\end{description}
\section*{Notes}
\begin{enumerate}
\item This routine returns a \verb|.true.| value for an index
that is local to the current process, including the halo
indices
\end{enumerate}
\subroutine{psb\_local\_index}{}
\syntax{call psb\_local\_index}{y, x, desc\_a, info}
\begin{description}
\item[Type:] Asynchronous.
\item[\bf On Entry]
\item[x] Integer indices.\\
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf in, inout}.\\
Specified as: a scalar or a rank one integer array.\\
\item[desc\_a] the communication descriptor.\\
Scope:{\bf local}.\\
Type:{\bf required}.\\
Intent: {\bf in}.\\
Specified as: a structured data of type \descdata.
\item[iact] specifies action to be taken in case of range errors.
Scope: {\bf global} \\
Type: {\bf optional}\\
Intent: {\bf in}.\\
Specified as: a character variable \verb|I|gnore, \verb|W|arning or
\verb|A|bort, default \verb|I|gnore.
\end{description}
\begin{description}
\item[\bf On Return]
\item[y] A logical mask which is true for all corresponding entries of
$x$ that are local to the current process
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf out}.\\
Specified as: a scalar or rank one logical array.
\item[info] Error code.\\
Scope: {\bf local} \\
Type: {\bf required} \\
Intent: {\bf out}.\\
An integer value; 0 means no error has been detected.
\end{description}
\section*{Notes}
\begin{enumerate}
\item This routine returns a \verb|.true.| value for those indices
that are local to the current process, including the halo
indices.
\end{enumerate}
%
%% psb_ins %%
docs/userguide.pdf
+6379 -5011
View File
File diff suppressed because one or more lines are too long
test/pargen/Makefile
+4
View File
@@ -19,6 +19,10 @@ ppde: ppde.o
$(F90LINK) ppde.o -o ppde $(PSBLAS_LIB) $(LDLIBS)
/bin/mv ppde $(EXEDIR)
tpde: tpde.o
$(F90LINK) tpde.o -pg -o tpde $(PSBLAS_LIB) $(LDLIBS)
/bin/mv tpde $(EXEDIR)
.f90.o:
$(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
test/pargen/ppde.f90
+127 -132
View File
@@ -361,14 +361,12 @@ contains
end interface ! local variables
type(psb_dspmat_type) :: a
real(psb_dpk_) :: zt(nbmax),glob_x,glob_y,glob_z
integer :: m,n,nnz,glob_row
integer :: m,n,nnz,glob_row,loc_row
integer :: x,y,z,ia,indx_owner
integer :: np, iam
integer :: element
integer :: nv, inv
integer, allocatable :: irow(:),icol(:)
real(psb_dpk_), allocatable :: val(:)
integer, allocatable :: prv(:)
! deltah dimension of each grid cell
! deltat discretization time
real(psb_dpk_) :: deltah
@@ -414,7 +412,7 @@ contains
! a bunch of rows per call.
!
allocate(val(20*nbmax),irow(20*nbmax),&
&icol(20*nbmax),prv(np),stat=info)
&icol(20*nbmax),stat=info)
if (info /= 0 ) then
info=4000
call psb_errpush(info,name)
@@ -430,138 +428,135 @@ contains
! icol(1)=1
do glob_row = 1, n
call parts(glob_row,n,np,prv,nv)
do inv = 1, nv
indx_owner = prv(inv)
if (indx_owner == iam) then
! local matrix pointer
element=1
! compute gridpoint coordinates
if (mod(glob_row,(idim*idim)) == 0) then
x = glob_row/(idim*idim)
else
x = glob_row/(idim*idim)+1
endif
if (mod((glob_row-(x-1)*idim*idim),idim) == 0) then
y = (glob_row-(x-1)*idim*idim)/idim
else
y = (glob_row-(x-1)*idim*idim)/idim+1
endif
z = glob_row-(x-1)*idim*idim-(y-1)*idim
! glob_x, glob_y, glob_x coordinates
glob_x=x*deltah
glob_y=y*deltah
glob_z=z*deltah
! Figure out which rows are local to the current process:
if (psb_is_owned(glob_row,desc_a)) then
! local matrix pointer
element=1
! compute gridpoint coordinates
if (mod(glob_row,(idim*idim)) == 0) then
x = glob_row/(idim*idim)
else
x = glob_row/(idim*idim)+1
endif
if (mod((glob_row-(x-1)*idim*idim),idim) == 0) then
y = (glob_row-(x-1)*idim*idim)/idim
else
y = (glob_row-(x-1)*idim*idim)/idim+1
endif
z = glob_row-(x-1)*idim*idim-(y-1)*idim
! glob_x, glob_y, glob_x coordinates
glob_x=x*deltah
glob_y=y*deltah
glob_z=z*deltah
! check on boundary points
zt(1) = 0.d0
! internal point: build discretization
!
! term depending on (x-1,y,z)
!
if (x==1) then
val(element)=-b1(glob_x,glob_y,glob_z)&
& -a1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*(-val(element))
else
val(element)=-b1(glob_x,glob_y,glob_z)&
& -a1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-2)*idim*idim+(y-1)*idim+(z)
element=element+1
endif
! term depending on (x,y-1,z)
if (y==1) then
val(element)=-b2(glob_x,glob_y,glob_z)&
& -a2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b2(glob_x,glob_y,glob_z)&
& -a2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-2)*idim+(z)
element=element+1
endif
! term depending on (x,y,z-1)
if (z==1) then
val(element)=-b3(glob_x,glob_y,glob_z)&
& -a3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b3(glob_x,glob_y,glob_z)&
& -a3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z-1)
element=element+1
endif
! term depending on (x,y,z)
val(element)=2*b1(glob_x,glob_y,glob_z)&
& +2*b2(glob_x,glob_y,glob_z)&
& +2*b3(glob_x,glob_y,glob_z)&
& +a1(glob_x,glob_y,glob_z)&
& +a2(glob_x,glob_y,glob_z)&
& +a3(glob_x,glob_y,glob_z)
! check on boundary points
zt(1) = 0.d0
! internal point: build discretization
!
! term depending on (x-1,y,z)
!
if (x==1) then
val(element)=-b1(glob_x,glob_y,glob_z)&
& -a1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z)
element=element+1
! term depending on (x,y,z+1)
if (z==idim) then
val(element)=-b1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z+1)
element=element+1
endif
! term depending on (x,y+1,z)
if (y==idim) then
val(element)=-b2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y)*idim+(z)
element=element+1
endif
! term depending on (x+1,y,z)
if (x<idim) then
val(element)=-b3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x)*idim*idim+(y-1)*idim+(z)
element=element+1
endif
irow(1:element-1)=glob_row
ia=glob_row
zt(1) = exp(-glob_y**2-glob_z**2)*(-val(element))
else
val(element)=-b1(glob_x,glob_y,glob_z)&
& -a1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-2)*idim*idim+(y-1)*idim+(z)
element=element+1
endif
! term depending on (x,y-1,z)
if (y==1) then
val(element)=-b2(glob_x,glob_y,glob_z)&
& -a2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b2(glob_x,glob_y,glob_z)&
& -a2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-2)*idim+(z)
element=element+1
endif
! term depending on (x,y,z-1)
if (z==1) then
val(element)=-b3(glob_x,glob_y,glob_z)&
& -a3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b3(glob_x,glob_y,glob_z)&
& -a3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z-1)
element=element+1
endif
! term depending on (x,y,z)
val(element)=2*b1(glob_x,glob_y,glob_z)&
& +2*b2(glob_x,glob_y,glob_z)&
& +2*b3(glob_x,glob_y,glob_z)&
& +a1(glob_x,glob_y,glob_z)&
& +a2(glob_x,glob_y,glob_z)&
& +a3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z)
element=element+1
! term depending on (x,y,z+1)
if (z==idim) then
val(element)=-b1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b1(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z+1)
element=element+1
endif
! term depending on (x,y+1,z)
if (y==idim) then
val(element)=-b2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
else
val(element)=-b2(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x-1)*idim*idim+(y)*idim+(z)
element=element+1
endif
! term depending on (x+1,y,z)
if (x<idim) then
val(element)=-b3(glob_x,glob_y,glob_z)
val(element) = val(element)/(deltah*&
& deltah)
icol(element)=(x)*idim*idim+(y-1)*idim+(z)
element=element+1
endif
irow(1:element-1)=glob_row
ia=glob_row
t3 = psb_wtime()
call psb_spins(element-1,irow,icol,val,a,desc_a,info)
if(info /= 0) exit
tins = tins + (psb_wtime()-t3)
call psb_geins(1,(/ia/),zt(1:1),b,desc_a,info)
if(info /= 0) exit
zt(1)=0.d0
call psb_geins(1,(/ia/),zt(1:1),xv,desc_a,info)
if(info /= 0) exit
end if
end do
t3 = psb_wtime()
call psb_spins(element-1,irow,icol,val,a,desc_a,info)
if(info /= 0) exit
tins = tins + (psb_wtime()-t3)
call psb_geins(1,(/ia/),zt(1:1),b,desc_a,info)
if(info /= 0) exit
zt(1)=0.d0
call psb_geins(1,(/ia/),zt(1:1),xv,desc_a,info)
if(info /= 0) exit
end if
end do
call psb_barrier(ictxt)