You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
618 lines
18 KiB
Fortran
618 lines
18 KiB
Fortran
!!$
|
|
!!$ Parallel Sparse BLAS v2.0
|
|
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
|
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
!!$
|
|
!!$ Redistribution and use in source and binary forms, with or without
|
|
!!$ modification, are permitted provided that the following conditions
|
|
!!$ are met:
|
|
!!$ 1. Redistributions of source code must retain the above copyright
|
|
!!$ notice, this list of conditions and the following disclaimer.
|
|
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
|
!!$ notice, this list of conditions, and the following disclaimer in the
|
|
!!$ documentation and/or other materials provided with the distribution.
|
|
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
|
!!$ not be used to endorse or promote products derived from this
|
|
!!$ software without specific written permission.
|
|
!!$
|
|
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
|
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
|
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
!!$
|
|
!!$
|
|
|
|
module psb_item_mod
|
|
type psb_item_int2
|
|
integer :: key, val
|
|
end type psb_item_int2
|
|
interface psb_sizeof
|
|
module procedure psb_item_int2_size
|
|
end interface
|
|
contains
|
|
function psb_item_int2_size(node)
|
|
use psb_const_mod
|
|
type(psb_item_int2) :: node
|
|
psb_item_int2_size = psb_sizeof_int * 2
|
|
end function psb_item_int2_size
|
|
|
|
subroutine psb_print_item_key_val(iout,item)
|
|
integer, intent(in) :: iout
|
|
type(psb_item_int2), intent(in) :: item
|
|
write(iout,*) 'Value: ',item%key,item%val
|
|
end subroutine psb_print_item_key_val
|
|
end module psb_item_mod
|
|
|
|
module psb_avl_mod
|
|
|
|
use psb_item_mod
|
|
|
|
integer, parameter :: LeftHigh = -1, EqualHeight=0, RightHigh=1
|
|
integer, parameter :: AVLTreeDuplicate = -123, AVLTreeOK=0, &
|
|
& AVLTreeOutOfMemory=-512, AVLTreeFatalError=-1024
|
|
integer :: level,outlev
|
|
integer, parameter :: poolsize = 1024
|
|
|
|
type psb_treenode_int2
|
|
type(psb_item_int2) :: item
|
|
type(psb_treenode_int2), pointer :: left=>null(), right=>null()
|
|
integer :: balance
|
|
end type psb_treenode_int2
|
|
|
|
type psb_treevect_int2
|
|
type(psb_treenode_int2) :: pool(poolsize)
|
|
integer :: avail
|
|
type(psb_treevect_int2), pointer :: next=>null(), prev=>null()
|
|
end type psb_treevect_int2
|
|
|
|
type psb_tree_int2
|
|
type(psb_treevect_int2), pointer :: head=>null(), current=>null()
|
|
type(psb_treenode_int2), pointer :: root=>null()
|
|
integer :: nnodes
|
|
end type psb_tree_int2
|
|
|
|
interface psb_sizeof
|
|
module procedure psb_Sizeof_Tree_int2, psb_sizeof_node_int2
|
|
end interface
|
|
|
|
interface InitSearchTree
|
|
module procedure InitSearchTree_int2
|
|
end interface
|
|
|
|
interface FreeSearchTree
|
|
module procedure FreeSearchTree_int2
|
|
end interface
|
|
|
|
interface SearchKey
|
|
module procedure SearchKey_int2
|
|
end interface
|
|
|
|
interface SearchInsKey
|
|
module procedure SearchInsKey_int2
|
|
end interface
|
|
|
|
interface GetAVLTree
|
|
module procedure GetAVLTree_int2
|
|
end interface
|
|
|
|
interface CloneSearchTree
|
|
module procedure CloneSearchTree_int2
|
|
end interface
|
|
|
|
interface CloneAVLTree
|
|
module procedure CloneAVLTree_int2
|
|
end interface
|
|
|
|
interface GetAVLNode
|
|
module procedure GetAVLNode_int2
|
|
end interface
|
|
interface UnGetAVLNode
|
|
module procedure UnGetAVLNode_int2
|
|
end interface
|
|
|
|
interface VisitAVLTree
|
|
module procedure VisitAVLTree_int2, VisitAVLTreeNode_int2
|
|
end interface
|
|
|
|
interface VisitAVLTreeLev
|
|
module procedure VisitAVLTreeLev_int2, VisitAVLTreeNodeLev_int2
|
|
end interface
|
|
|
|
interface AVLTreeLeftBalance
|
|
module procedure AVLTreeLeftBalance_int2
|
|
end interface
|
|
|
|
interface AVLTreeRightBalance
|
|
module procedure AVLTreeRightBalance_int2
|
|
end interface
|
|
|
|
interface AVLTreeRotateLeft
|
|
module procedure AVLTreeRotateLeft_int2
|
|
end interface
|
|
|
|
interface AVLTreeRotateRight
|
|
module procedure AVLTreeRotateRight_int2
|
|
end interface
|
|
|
|
interface AVLSearchKey
|
|
module procedure AVLSearchKey_int2
|
|
end interface
|
|
|
|
interface AVLSearchInsKey
|
|
module procedure AVLSearchInsKey_int2
|
|
end interface
|
|
|
|
interface AVLSearchInsNode
|
|
module procedure AVLSearchInsNode_int2
|
|
end interface
|
|
|
|
contains
|
|
|
|
subroutine InitSearchTree_int2(tree, info)
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: info
|
|
|
|
if (associated(tree)) then
|
|
call FreeSearchTree(tree,info)
|
|
end if
|
|
call GetAVLTree(tree,info)
|
|
|
|
end subroutine InitSearchTree_int2
|
|
|
|
subroutine CloneSearchTree_int2(treein, treeout)
|
|
type(psb_tree_int2), pointer :: treein,treeout
|
|
integer :: info
|
|
if (.not.associated(treein)) then
|
|
treeout => null()
|
|
return
|
|
endif
|
|
call GetAVLTree(treeout,info)
|
|
call CloneAVLTree(treein%root,treeout)
|
|
|
|
end subroutine CloneSearchTree_int2
|
|
|
|
recursive subroutine CloneAVLTree_int2(root, tree)
|
|
type(psb_treenode_int2), pointer :: root
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: info, key,val,next
|
|
if (.not.associated(root)) return
|
|
key = root%item%key
|
|
next = root%item%val
|
|
call SearchInsKey(tree,key,val,next,info)
|
|
call CloneAVLTree(root%left,tree)
|
|
call CloneAVLTree(root%right,tree)
|
|
end subroutine CloneAVLTree_int2
|
|
|
|
subroutine FreeSearchTree_int2(tree, info)
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: info
|
|
type(psb_treevect_int2), pointer :: current,next
|
|
|
|
if (.not.associated(tree)) return
|
|
current => tree%head
|
|
do
|
|
if (.not.associated(current)) exit
|
|
next => current%next
|
|
deallocate(current,stat=info)
|
|
if (info /= 0) then
|
|
info = AVLTreeFatalError
|
|
return
|
|
end if
|
|
current => next
|
|
end do
|
|
deallocate(tree,stat=info)
|
|
if (info /= 0) then
|
|
info = AVLTreeFatalError
|
|
return
|
|
end if
|
|
|
|
end subroutine FreeSearchTree_int2
|
|
|
|
function psb_Sizeof_Tree_int2(tree)
|
|
use psb_const_mod
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: psb_Sizeof_Tree_int2
|
|
integer :: val
|
|
type(psb_treevect_int2), pointer :: current,next
|
|
|
|
val = 0
|
|
if (associated(tree)) then
|
|
current => tree%head
|
|
do
|
|
if (.not.associated(current)) exit
|
|
val = val + 3*psb_sizeof_int + poolsize*psb_sizeof(current%pool(1))
|
|
current => current%next
|
|
end do
|
|
end if
|
|
psb_Sizeof_Tree_int2 = val
|
|
end function psb_Sizeof_Tree_int2
|
|
|
|
function psb_sizeof_node_int2(node)
|
|
|
|
use psb_const_mod
|
|
type(psb_treenode_int2) :: node
|
|
integer :: psb_sizeof_node_int2
|
|
integer :: val
|
|
|
|
|
|
psb_sizeof_node_int2 = 3*psb_sizeof_int + psb_sizeof(node%item)
|
|
|
|
end function psb_sizeof_node_int2
|
|
|
|
subroutine SearchKey_int2(tree,key,val,info)
|
|
type(psb_tree_int2), target :: tree
|
|
integer :: key,val,info
|
|
type(psb_item_int2), pointer :: retval
|
|
info = 0
|
|
call AVLSearchKey(tree,key,retval,info)
|
|
if (associated(retval)) then
|
|
val = retval%val
|
|
else
|
|
val = -1
|
|
end if
|
|
end subroutine SearchKey_int2
|
|
|
|
subroutine SearchInsKey_int2(tree,key,val, nextval,info)
|
|
type(psb_tree_int2), target :: tree
|
|
integer :: key,val,nextval,info
|
|
|
|
call AVLSearchInsKey(tree,key,val,nextval,info)
|
|
|
|
end subroutine SearchInsKey_int2
|
|
|
|
subroutine GetAVLTree_int2(tree, info)
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: info
|
|
|
|
allocate(tree, stat=info)
|
|
if (info == 0) allocate(tree%head,stat=info)
|
|
if (info == 0) then
|
|
tree%current => tree%head
|
|
tree%head%avail = 0
|
|
tree%nnodes=0
|
|
end if
|
|
|
|
if (info /= 0) then
|
|
write(0,*) 'Failed allocation 1 GetAVLTree '
|
|
info = AVLTreeOutOfMemory
|
|
|
|
return
|
|
end if
|
|
|
|
end subroutine GetAVLTree_int2
|
|
|
|
subroutine VisitAVLTree_int2(tree, info,iout)
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: info
|
|
integer, optional :: iout
|
|
|
|
info = 0
|
|
if (.not.associated(tree)) return
|
|
call VisitAVLTree(tree%root,iout)
|
|
|
|
end subroutine VisitAVLTree_int2
|
|
|
|
recursive subroutine VisitAVLTreeNode_int2(root,iout)
|
|
type(psb_treenode_int2), pointer :: root
|
|
integer, optional :: iout
|
|
integer :: info
|
|
|
|
if (.not.associated(root)) return
|
|
call VisitAVLTree(root%left,iout)
|
|
if (present(iout)) then
|
|
call psb_print_item_key_val(iout,root%item)
|
|
else
|
|
call psb_print_item_key_val(6,root%item)
|
|
end if
|
|
call VisitAVLTree(root%right,iout)
|
|
end subroutine VisitAVLTreeNode_int2
|
|
|
|
subroutine VisitAVLTreeLev_int2(tree, info)
|
|
type(psb_tree_int2), pointer :: tree
|
|
integer :: info
|
|
|
|
if (.not.associated(tree)) return
|
|
do outlev = 0, 3
|
|
write(6,*) 'Tree level : ',outlev
|
|
call VisitAVLTreeLev(tree%root,0)
|
|
end do
|
|
|
|
end subroutine VisitAVLTreeLev_int2
|
|
|
|
recursive subroutine VisitAVLTreeNodeLev_int2(root,level)
|
|
type(psb_treenode_int2), pointer :: root
|
|
integer :: info,level
|
|
|
|
if (.not.associated(root)) return
|
|
call VisitAVLTreeLev(root%left,level+1)
|
|
if (level == outlev) call psb_print_item_key_val(6,root%item)
|
|
call VisitAVLTreeLev(root%right,level+1)
|
|
end subroutine VisitAVLTreeNodeLev_int2
|
|
|
|
|
|
function GetAVLNode_int2(tree, info)
|
|
type(psb_tree_int2), target :: tree
|
|
type(psb_treenode_int2), pointer :: GetAVLNode_int2
|
|
integer :: info
|
|
type(psb_treevect_int2), pointer :: current, temp
|
|
|
|
GetAVLNode_int2 => null()
|
|
|
|
if (.not.associated(tree%current)) then
|
|
allocate(tree%head,stat=info)
|
|
if (info /= 0) then
|
|
info = AVLTreeOutOfMemory
|
|
return
|
|
end if
|
|
tree%current => tree%head
|
|
tree%current%avail = 0
|
|
end if
|
|
current => tree%current
|
|
do
|
|
if (current%avail < poolsize) exit
|
|
if (.not.(associated(current%next))) then
|
|
allocate(temp,stat=info)
|
|
if (info /= 0) then
|
|
info = AVLTreeOutOfMemory
|
|
return
|
|
end if
|
|
temp%avail = 0
|
|
temp%prev => current
|
|
current%next => temp
|
|
end if
|
|
current => current%next
|
|
end do
|
|
tree%current => current
|
|
current%avail = current%avail + 1
|
|
GetAVLNode_int2 => current%pool(current%avail)
|
|
|
|
end function GetAVLNode_int2
|
|
|
|
subroutine UnGetAVLNode_int2(tree, info)
|
|
type(psb_tree_int2), target :: tree
|
|
integer :: info
|
|
|
|
|
|
if (.not.associated(tree%current)) then
|
|
return
|
|
end if
|
|
if (tree%current%avail > 0) &
|
|
& tree%current%avail = tree%current%avail - 1
|
|
return
|
|
end subroutine UnGetAVLNode_int2
|
|
|
|
subroutine AVLSearchKey_int2(tree,key,retval,info)
|
|
type(psb_tree_int2), target :: tree
|
|
integer :: key,info
|
|
type(psb_item_int2), pointer :: retval
|
|
type(psb_treenode_int2), pointer :: root
|
|
|
|
retval => null()
|
|
root => tree%root
|
|
do
|
|
if (.not.associated(root)) exit
|
|
if (key < root%item%key) then
|
|
root => root%left
|
|
else if (key == root%item%key) then
|
|
retval => root%item
|
|
exit
|
|
else if (key > root%item%key) then
|
|
root => root%right
|
|
end if
|
|
end do
|
|
|
|
end subroutine AVLSearchKey_int2
|
|
|
|
subroutine AVLSearchInsKey_int2(tree,key,val,nextval,info)
|
|
type(psb_tree_int2), target :: tree
|
|
integer :: key,val,nextval,info
|
|
type(psb_treenode_int2), pointer :: itemp
|
|
logical :: taller
|
|
|
|
itemp => GetAVLNode(tree,info)
|
|
if (info /=0) then
|
|
return
|
|
end if
|
|
if (.not.associated(itemp)) then
|
|
info = -5
|
|
return
|
|
endif
|
|
itemp%item%key = key
|
|
itemp%item%val = nextval
|
|
itemp%left => null()
|
|
itemp%right => null()
|
|
|
|
call AVLSearchInsNode(tree%root,itemp,taller,info)
|
|
val = itemp%item%val
|
|
if (info == AVLTreeDuplicate) then
|
|
call UnGetAVLNode(tree,info)
|
|
!!$ write(0,*) 'From searchInsNode ',key,val,nextval
|
|
info = 0
|
|
return
|
|
else if (info == AVLTreeOK) then
|
|
tree%nnodes = tree%nnodes + 1
|
|
info = 0
|
|
return
|
|
else
|
|
write(0,*) 'Error from inner SearchInsNode '
|
|
endif
|
|
|
|
end subroutine AVLSearchInsKey_int2
|
|
|
|
|
|
recursive subroutine AVLSearchInsNode_int2(root,node,taller,info)
|
|
type(psb_treenode_int2), pointer :: root, node
|
|
integer :: info
|
|
logical :: taller
|
|
|
|
info = AVLTreeOK
|
|
taller = .false.
|
|
if (.not.associated(root)) then
|
|
root => node
|
|
node%balance = EqualHeight
|
|
node%left => null()
|
|
node%right => null()
|
|
taller = .true.
|
|
else if (node%item%key == root%item%key) then
|
|
!!$ write(0,*) 'SearchInsNode : found key',node%item%key,node%item%val,&
|
|
!!$ &root%item%key,root%item%val
|
|
info = AVLTreeDuplicate
|
|
node%item%val = root%item%val
|
|
return
|
|
|
|
else if (node%item%key < root%item%key) then
|
|
|
|
call AVLSearchInsNode(root%left,node,taller,info)
|
|
if (info == AVLTreeDuplicate) return
|
|
if (info == AVLTreeFatalError) return
|
|
if (taller) then
|
|
select case(root%balance)
|
|
case(LeftHigh)
|
|
call AVLTreeLeftBalance(root,taller)
|
|
case(EqualHeight)
|
|
root%balance = LeftHigh
|
|
case(RightHigh)
|
|
root%balance = EqualHeight
|
|
taller = .false.
|
|
case default
|
|
info = AVLTreeFatalError
|
|
end select
|
|
end if
|
|
else if (node%item%key > root%item%key) then
|
|
call AVLSearchInsNode(root%right,node,taller,info)
|
|
if (info == AVLTreeDuplicate) return
|
|
if (info == AVLTreeFatalError) return
|
|
if (taller) then
|
|
select case(root%balance)
|
|
case(LeftHigh)
|
|
root%balance = EqualHeight
|
|
taller = .false.
|
|
case(EqualHeight)
|
|
root%balance = RightHigh
|
|
case(RightHigh)
|
|
call AVLTreeRightBalance(root,taller)
|
|
case default
|
|
info = AVLTreeFatalError
|
|
end select
|
|
end if
|
|
end if
|
|
|
|
end subroutine AVLSearchInsNode_int2
|
|
|
|
|
|
|
|
recursive subroutine AVLTreeLeftBalance_int2(root,taller)
|
|
type(psb_treenode_int2), pointer :: root
|
|
logical :: taller
|
|
|
|
type(psb_treenode_int2), pointer :: rs, ls
|
|
|
|
ls => root%left
|
|
select case (ls%balance)
|
|
case(LeftHigh)
|
|
root%balance = EqualHeight
|
|
ls%balance = EqualHeight
|
|
call AVLTreeRotateRight(root)
|
|
taller = .false.
|
|
case(EqualHeight)
|
|
write(0,*) 'Warning: balancing and already balanced left tree? '
|
|
case(RightHigh)
|
|
rs => ls%right
|
|
select case(rs%balance)
|
|
case(LeftHigh)
|
|
root%balance = RightHigh
|
|
ls%balance = EqualHeight
|
|
case(EqualHeight)
|
|
root%balance = EqualHeight
|
|
ls%balance = EqualHeight
|
|
case(RightHigh)
|
|
root%balance = EqualHeight
|
|
ls%balance = LeftHigh
|
|
end select
|
|
rs%balance = EqualHeight
|
|
call AVLTreeRotateLeft(root%left)
|
|
call AVLTreeRotateRight(root)
|
|
taller = .false.
|
|
end select
|
|
|
|
end subroutine AVLTreeLeftBalance_int2
|
|
|
|
|
|
recursive subroutine AVLTreeRightBalance_int2(root,taller)
|
|
type(psb_treenode_int2), pointer :: root
|
|
logical :: taller
|
|
type(psb_treenode_int2), pointer :: rs, ls
|
|
|
|
rs => root%right
|
|
select case (rs%balance)
|
|
case(RightHigh)
|
|
root%balance = EqualHeight
|
|
rs%balance = EqualHeight
|
|
call AVLTreeRotateLeft(root)
|
|
taller = .false.
|
|
case(EqualHeight)
|
|
write(0,*) 'Warning: balancing and already balanced right tree? '
|
|
case(LeftHigh)
|
|
ls => rs%left
|
|
select case(ls%balance)
|
|
case(RightHigh)
|
|
root%balance = LeftHigh
|
|
rs%balance = EqualHeight
|
|
case(EqualHeight)
|
|
root%balance = EqualHeight
|
|
rs%balance = EqualHeight
|
|
case(LeftHigh)
|
|
root%balance = EqualHeight
|
|
rs%balance = RightHigh
|
|
end select
|
|
ls%balance = EqualHeight
|
|
call AVLTreeRotateRight(root%right)
|
|
call AVLTreeRotateLeft(root)
|
|
taller = .false.
|
|
end select
|
|
end subroutine AVLTreeRightBalance_int2
|
|
|
|
|
|
|
|
subroutine AVLTreeRotateLeft_int2(root)
|
|
type(psb_treenode_int2), pointer :: root
|
|
type(psb_treenode_int2), pointer :: temp
|
|
if (.not.associated(root)) then
|
|
return
|
|
endif
|
|
if (.not.associated(root%right)) then
|
|
return
|
|
endif
|
|
temp => root%right
|
|
root%right => temp%left
|
|
temp%left => root
|
|
root => temp
|
|
|
|
end subroutine AVLTreeRotateLeft_int2
|
|
|
|
subroutine AVLTreeRotateRight_int2(root)
|
|
type(psb_treenode_int2), pointer :: root
|
|
type(psb_treenode_int2), pointer :: temp
|
|
if (.not.associated(root)) then
|
|
return
|
|
endif
|
|
if (.not.associated(root%left)) then
|
|
return
|
|
endif
|
|
temp => root%left
|
|
root%left => temp%right
|
|
temp%right => root
|
|
root => temp
|
|
|
|
end subroutine AVLTreeRotateRight_int2
|
|
|
|
|
|
end module psb_avl_mod
|