[Dart-dev] [6102] DART/branches/development/sort/sort_mod.f90: Overloaded sort() to take both r8 and integer arguments ...
nancy at ucar.edu
nancy at ucar.edu
Fri May 3 09:12:01 MDT 2013
Revision: 6102
Author: thoar
Date: 2013-05-03 09:12:00 -0600 (Fri, 03 May 2013)
Log Message:
-----------
Overloaded sort() to take both r8 and integer arguments ... ditto for the index_sort().
Modified Paths:
--------------
DART/branches/development/sort/sort_mod.f90
-------------- next part --------------
Modified: DART/branches/development/sort/sort_mod.f90
===================================================================
--- DART/branches/development/sort/sort_mod.f90 2013-05-02 18:08:55 UTC (rev 6101)
+++ DART/branches/development/sort/sort_mod.f90 2013-05-03 15:12:00 UTC (rev 6102)
@@ -26,11 +26,21 @@
logical, save :: module_initialized = .false.
+interface sort
+ module procedure rsort
+ module procedure isort
+end interface sort
+
+interface index_sort
+ module procedure index_sort_real
+ module procedure index_sort_int
+end interface
+
contains
-
!=======================================================================
+
subroutine initialize_module
call register_module(source, revision, revdate)
@@ -38,6 +48,7 @@
end subroutine initialize_module
+
!=======================================================================
! a silly, inefficient sort for real(r8) array data
@@ -109,13 +120,14 @@
!=========================================================================
-function sort(x)
+function rsort(x)
+
! Uses a heap sort alogrithm on x, returns sorted array
implicit none
real(r8), intent(in) :: x(:)
-real(r8) :: sort(size(x))
+real(r8) :: rsort(size(x))
integer :: num, level, ind, i, j
real(r8) :: l_val
@@ -124,7 +136,7 @@
num = size(x)
! Initial copy over
-sort = x
+rsort = x
! Only one element, just send it back
if(num <= 1) return
@@ -137,13 +149,13 @@
! Keep going down levels until bottom
if(level > 1) then
level = level - 1
- l_val = sort(level)
+ l_val = rsort(level)
else
- l_val = sort(ind)
- sort(ind) = sort(1)
+ l_val = rsort(ind)
+ rsort(ind) = rsort(1)
ind = ind - 1
if(ind == 1) then
- sort(1) = l_val
+ rsort(1) = l_val
return
endif
endif
@@ -153,10 +165,10 @@
do while(j <= ind)
if(j < ind) then
- if(sort(j) < sort(j + 1)) j = j + 1
+ if(rsort(j) < rsort(j + 1)) j = j + 1
endif
- if(l_val < sort(j)) then
- sort(i) = sort(j)
+ if(l_val < rsort(j)) then
+ rsort(i) = rsort(j)
i = j
j = 2 * j
else
@@ -164,18 +176,83 @@
endif
end do
- sort(i) = l_val
+ rsort(i) = l_val
end do
-end function sort
+end function rsort
!=========================================================================
-subroutine index_sort(x, index, num)
+function isort(x)
+! Uses a heap sort alogrithm on x, returns sorted array
+implicit none
+
+integer, intent(in) :: x(:)
+integer :: isort(size(x))
+
+integer :: num, level, ind, i, j
+integer :: l_val
+
+! Get the size
+num = size(x)
+
+! Initial copy over
+isort = x
+
+! Only one element, just send it back
+if(num <= 1) return
+
+level = num / 2 + 1
+ind = num
+
+! Keep looping until finished
+do
+ ! Keep going down levels until bottom
+ if(level > 1) then
+ level = level - 1
+ l_val = isort(level)
+ else
+ l_val = isort(ind)
+ isort(ind) = isort(1)
+ ind = ind - 1
+ if(ind == 1) then
+ isort(1) = l_val
+ return
+ endif
+ endif
+
+ i = level
+ j = 2 * level
+
+ do while(j <= ind)
+ if(j < ind) then
+ if(isort(j) < isort(j + 1)) j = j + 1
+ endif
+ if(l_val < isort(j)) then
+ isort(i) = isort(j)
+ i = j
+ j = 2 * j
+ else
+ j = ind + 1
+ endif
+
+ end do
+ isort(i) = l_val
+
+end do
+
+end function isort
+
+
+!=========================================================================
+
+
+subroutine index_sort_real(x, index, num)
+
! Uses a heap sort alogrithm on x, returns array of sorted indices
implicit none
@@ -183,7 +260,7 @@
real(r8), intent(in) :: x(num)
integer, intent(out) :: index(num)
-integer :: ind, i, j, l_val_index, level
+integer :: ind, i, j, l_val_index, level
real(r8) :: l_val
@@ -234,15 +311,88 @@
else
j = ind + 1
endif
-
+
end do
index(i) = l_val_index
end do
-end subroutine index_sort
+end subroutine index_sort_real
!=========================================================================
+
+subroutine index_sort_int(x, index, num)
+
+! Uses a heap sort alogrithm on x (an array of integers)
+! returns array of sorted indices and the sorted array
+implicit none
+
+integer, intent(in) :: num
+integer, intent(in) :: x(num)
+integer, intent(out) :: index(num)
+
+integer :: ind, i, j, l_val_index, level
+integer :: l_val
+
+if ( .not. module_initialized ) call initialize_module
+
+! INITIALIZE THE INDEX ARRAY TO INPUT ORDER
+do i = 1, num
+ index(i) = i
+end do
+
+! Only one element, just send it back
+if(num <= 1) return
+
+level = num / 2 + 1
+ind = num
+
+! Keep looping until finished
+do
+ ! Keep going down levels until bottom
+ if(level > 1) then
+ level = level - 1
+ l_val = x(index(level))
+ l_val_index = index(level)
+ else
+ l_val = x(index(ind))
+ l_val_index = index(ind)
+
+
+ index(ind) = index(1)
+ ind = ind - 1
+ if(ind == 1) then
+ index(1) = l_val_index
+ return
+ endif
+ endif
+
+ i = level
+ j = 2 * level
+
+ do while(j <= ind)
+ if(j < ind) then
+ if(x(index(j)) < x(index(j + 1))) j = j + 1
+ endif
+ if(l_val < x(index(j))) then
+ index(i) = index(j)
+ i = j
+ j = 2 * j
+ else
+ j = ind + 1
+ endif
+
+ end do
+
+ index(i) = l_val_index
+
+end do
+
+end subroutine index_sort_int
+
+
+!=========================================================================
+
end module sort_mod
More information about the Dart-dev
mailing list