cphyc / fortran-parallel-sort Goto Github PK

View Code? Open in Web Editor NEW

27.0 5.0 3.0 44 KB

A fortran library to perform parallel sorts.

License: Creative Commons Zero v1.0 Universal

Makefile 0.45% Fortran 99.55%

fortran-parallel-sort's Introduction

Fortran-parallel-sort

A fortran library to perform parallel sorts.

Install

Download the library in any working directory.

Compile

You need to compile both mrgrnk.f90 and sort.f90. The latter has to be compiled against openmp (e.g. with gfortran, do gfortran -fopenmp sort.f90 -c sort.o). To use, simply use mod_sort in your fortran files.

Doc

parallel_sort

A (in): an integer array, containing the element to sort
order(out): an integer array, containing the positions so that A(order(:)) is ordered

fortran-parallel-sort's People

Contributors

Stargazers

Watchers

Forkers

ocsteve selena1 14ngiestas

fortran-parallel-sort's Issues

New Fortran code for serial sorting character arrays, and parallelizing SP, DP, and character arrays

New Fortran code for serial sorting character arrays, and parallelizing SP, DP, and character arrays. Four more routines created, for a total of eight routines. Overloaded the user interface so that a call to Parallel_Sort(A, order) will handle array A of type: integer, real(4), real(8), or character(:).

fpm support

Do you have any plans to offer this as an fpm package (https://github.com/fortran-lang/fpm)?

If not, would you be open to a PR for this?

Code to perform sorting on tiny arrays in serial to avoid OpenMP overhead within (4) parallel subroutines

Code to perform sorting on tiny arrays in serial to avoid OpenMP overhead within (4) parallel subroutines. For the case where chunk2 is zero we get a divide-by-zero error. This modification solves this trivial bug.

module mod_sort
use omp_lib
use m_mrgrnk

implicit none

integer, parameter :: max_simple_sort_size = 20
private
public :: parallel_sort

interface parallel_sort
module procedure C_parallel_sort, D_parallel_sort, R_parallel_sort, I_parallel_sort
end interface parallel_sort
contains

subroutine C_parallel_sort (A, order)
character(*), intent(in), dimension(:) :: A
integer, intent(out), dimension(size(A)) :: order

integer :: ilen, from, middle, ito, nthreads, thread, chunk, chunk2, i, iremainder, extraThread

ilen      = size(A)
nthreads = omp_get_max_threads()
chunk    = ilen / nthreads
!----------------------------------------
! Perform sorting on tiny arrays in serial to avoid OpenMP overhead
!----------------------------------------
if (chunk < 1) then
   do i = 1, ilen
      order(i) = i
   end do

   call mrgrnk(A(:), order(:))
   return
endif    
!----------------------------------------

iremainder = mod(ilen, nthreads)
if (iremainder /= 0) then
    extraThread = 1
else
    extraThread = 0
endif
!----------------------------------------
! Initialize order
!----------------------------------------
!$OMP parallel do shared(order) schedule(static)
do i = 1, ilen
   order(i) = i
end do
!$OMP end parallel do

!----------------------------------------
! Sort each chunk
!----------------------------------------
!$OMP parallel do default(shared) private(thread, from, ito) schedule(guided)
do thread = 0, nthreads-1 + extraThread
   from = thread*chunk + 1
   ito  = min((thread + 1)*chunk, ilen)

   call mrgrnk(A(from:ito), order(from:ito))
   order(from:ito) = order(from:ito) + from - 1
end do
!$OMP end parallel do

!----------------------------------------
! Merge pieces together
!----------------------------------------
i = 1
chunk2 = chunk
do while (chunk2 < size(A))

   !$OMP parallel do default(shared) private(thread, from, middle, ito)
   do thread = 0, ceiling(.5 * size(A) / chunk2)
      from   = thread*2     * chunk2 + 1
      middle = (thread*2 + 1) * chunk2
      ito     = (thread*2 + 2) * chunk2

      middle = min(middle, size(A))
      ito     = min(ito, size(A))
      if (from < ito) then
         call C_merge(A, order, from, middle, ito)
      end if
   end do
   !$OMP end parallel do

   chunk2 = chunk2 * 2
   i = i + 1
end do

end subroutine C_parallel_sort

!> Merge two parts of A, ordered by order from left to right
!! around middle.
subroutine C_merge (A, order, left, middle, right)
character(*), intent(in), dimension(:) :: A
integer, intent(inout), dimension(size(A)) :: order

integer, intent(in) :: left, middle, right

integer :: leftA, rightA, leftB, rightB
integer :: iA, iB, i

integer, dimension(left    :middle) :: orderA
integer, dimension(middle+1:right ) :: orderB

! copy order
orderA = order(left    :middle)
orderB = order(middle+1:right)

! more explicit variables
leftA  = left
rightA = middle
leftB  = middle+1
rightB = right

! initialize iA, iB to their leftmost position
iA = leftA
iB = leftB

i = leftA

do while ((iA <= rightA) .and. (iB <= rightB))
   if (A(orderA(iA)) <= A(orderB(iB))) then
      order(i) = orderA(iA)
      iA = iA + 1
   else
      order(i) = orderB(iB)
      iB = iB + 1
   end if

   i = i + 1
end do

! either A or B still have elements, append them to the new order
do while (iA <= rightA)
   order(i) = orderA(iA)
   iA = iA + 1

   i  = i + 1
end do

do while (iB <= rightB)
   order(i) = orderB(iB)
   iB = iB + 1

   i  = i + 1
end do

end subroutine C_merge

subroutine D_parallel_sort (A, order)
real(8), intent(in), dimension(:) :: A
integer, intent(out), dimension(size(A)) :: order

integer :: ilen, from, middle, ito, nthreads, thread, chunk, chunk2, i, iremainder, extraThread

ilen      = size(A)
nthreads = omp_get_max_threads()
chunk    = ilen / nthreads
!----------------------------------------
! Perform sorting on tiny arrays in serial to avoid OpenMP overhead
!----------------------------------------
if (chunk < 1) then
   do i = 1, ilen
      order(i) = i
   end do

   call mrgrnk(A(:), order(:))
   return
endif    
!----------------------------------------

iremainder = mod(ilen, nthreads)
if (iremainder /= 0) then
    extraThread = 1
else
    extraThread = 0
endif
!----------------------------------------
! Initialize order
!----------------------------------------
!$OMP parallel do shared(order)
do i = 1, ilen
   order(i) = i
end do
!$OMP end parallel do

!----------------------------------------
! Sort each chunk
!----------------------------------------
!$OMP parallel do default(shared) private(thread, from, ito) schedule(guided)
do thread = 0, nthreads-1 + extraThread
   from = thread*chunk + 1
   ito  = min((thread + 1)*chunk, ilen)

   call mrgrnk(A(from:ito), order(from:ito))
   order(from:ito) = order(from:ito) + from - 1
end do
!$OMP end parallel do

!----------------------------------------
! Merge pieces together
!----------------------------------------
i = 1
chunk2 = chunk
do while (chunk2 < size(A))

   !$OMP parallel do default(shared) private(thread, from, middle, ito)
   do thread = 0, ceiling(.5 * size(A) / chunk2)
      from   = thread*2     * chunk2 + 1
      middle = (thread*2 + 1) * chunk2
      ito     = (thread*2 + 2) * chunk2

      middle = min(middle, size(A))
      ito     = min(ito, size(A))
      if (from < ito) then
         call D_merge(A, order, from, middle, ito)
      end if
   end do
   !$OMP end parallel do

   chunk2 = chunk2 * 2
   i = i + 1
end do

end subroutine D_parallel_sort

!> Merge two parts of A, ordered by order from left to right
!! around middle.
subroutine D_merge (A, order, left, middle, right)
real(8), intent(in), dimension(:) :: A
integer, intent(inout), dimension(size(A)) :: order

integer, intent(in) :: left, middle, right

integer :: leftA, rightA, leftB, rightB
integer :: iA, iB, i

integer, dimension(left    :middle) :: orderA
integer, dimension(middle+1:right ) :: orderB

! copy order
orderA = order(left    :middle)
orderB = order(middle+1:right)

! more explicit variables
leftA  = left
rightA = middle
leftB  = middle+1
rightB = right

! initialize iA, iB to their leftmost position
iA = leftA
iB = leftB

i = leftA

do while ((iA <= rightA) .and. (iB <= rightB))
   if (A(orderA(iA)) <= A(orderB(iB))) then
      order(i) = orderA(iA)
      iA = iA + 1
   else
      order(i) = orderB(iB)
      iB = iB + 1
   end if

   i = i + 1
end do

! either A or B still have elements, append them to the new order
do while (iA <= rightA)
   order(i) = orderA(iA)
   iA = iA + 1

   i  = i + 1

end do
do while (iB <= rightB)
   order(i) = orderB(iB)
   iB = iB + 1

   i  = i + 1
end do

end subroutine D_merge

subroutine R_parallel_sort (A, order)
real(4), intent(in), dimension(:) :: A
integer, intent(out), dimension(size(A)) :: order

integer :: ilen, from, middle, ito, nthreads, thread, chunk, chunk2, i, iremainder, extraThread

ilen      = size(A)
nthreads = omp_get_max_threads()
chunk    = ilen / nthreads
!----------------------------------------
! Perform sorting on tiny arrays in serial to avoid OpenMP overhead
!----------------------------------------
if (chunk < 1) then
   do i = 1, ilen
      order(i) = i
   end do

   call mrgrnk(A(:), order(:))
   return
endif    
!----------------------------------------

iremainder = mod(ilen, nthreads)
if (iremainder /= 0) then
    extraThread = 1
else
    extraThread = 0
endif
!----------------------------------------
! Initialize order
!----------------------------------------
!$OMP parallel do shared(order) schedule(static)
do i = 1, ilen
   order(i) = i
end do
!$OMP end parallel do

!----------------------------------------
! Sort each chunk
!----------------------------------------
!$OMP parallel do default(shared) private(thread, from, ito) schedule(guided)
do thread = 0, nthreads-1 + extraThread
   from = thread*chunk + 1
   ito  = min((thread + 1)*chunk, ilen)

   call mrgrnk(A(from:ito), order(from:ito))
   order(from:ito) = order(from:ito) + from - 1
end do
!$OMP end parallel do

!----------------------------------------
! Merge pieces together
!----------------------------------------
i = 1
chunk2 = chunk
do while (chunk2 < size(A))

   !$OMP parallel do default(shared) private(thread, from, middle, ito)
   do thread = 0, ceiling(.5 * size(A) / chunk2)
      from   = thread*2     * chunk2 + 1
      middle = (thread*2 + 1) * chunk2
      ito     = (thread*2 + 2) * chunk2

      middle = min(middle, size(A))
      ito     = min(ito, size(A))
      if (from < ito) then
         call R_merge(A, order, from, middle, ito)
      end if
   end do
   !$OMP end parallel do

   chunk2 = chunk2 * 2
   i = i + 1
end do

end subroutine R_parallel_sort

!> Merge two parts of A, ordered by order from left to right
!! around middle.
subroutine R_merge (A, order, left, middle, right)
real(4), intent(in), dimension(:) :: A
integer, intent(inout), dimension(size(A)) :: order

integer, intent(in) :: left, middle, right

integer :: leftA, rightA, leftB, rightB
integer :: iA, iB, i

integer, dimension(left    :middle) :: orderA
integer, dimension(middle+1:right ) :: orderB

! copy order
orderA = order(left    :middle)
orderB = order(middle+1:right)

! more explicit variables
leftA  = left
rightA = middle
leftB  = middle+1
rightB = right

! initialize iA, iB to their leftmost position
iA = leftA
iB = leftB

i = leftA

do while ((iA <= rightA) .and. (iB <= rightB))
   if (A(orderA(iA)) <= A(orderB(iB))) then
      order(i) = orderA(iA)
      iA = iA + 1
   else
      order(i) = orderB(iB)
      iB = iB + 1
   end if

   i = i + 1
end do

! either A or B still have elements, append them to the new order
do while (iA <= rightA)
   order(i) = orderA(iA)
   iA = iA + 1

   i  = i + 1

end do
do while (iB <= rightB)
   order(i) = orderB(iB)
   iB = iB + 1

   i  = i + 1
end do

end subroutine R_merge

subroutine I_parallel_sort (A, order)
integer, intent(in), dimension(:) :: A
integer, intent(out), dimension(size(A)) :: order

integer :: ilen, from, middle, ito, nthreads, thread, chunk, chunk2, i, iremainder, extraThread

ilen      = size(A)
nthreads = omp_get_max_threads()
chunk    = ilen / nthreads
!----------------------------------------
! Perform sorting on tiny arrays in serial to avoid OpenMP overhead
!----------------------------------------
if (chunk < 1) then
   do i = 1, ilen
      order(i) = i
   end do

   call mrgrnk(A(:), order(:))
   return
endif    
!----------------------------------------

iremainder = mod(ilen, nthreads)
if (iremainder /= 0) then
    extraThread = 1
else
    extraThread = 0
endif
!----------------------------------------
! Initialize order
!----------------------------------------
do i = 1, ilen
   order(i) = i
end do

!----------------------------------------
! Sort each chunk
!----------------------------------------
!$OMP parallel do default(shared) private(thread, from, ito)
do thread = 0, nthreads-1 + extraThread
   from = thread*chunk + 1
   ito  = min((thread + 1)*chunk, ilen)

   call mrgrnk(A(from:ito), order(from:ito))
   order(from:ito) = order(from:ito) + from - 1
end do
!$OMP end parallel do

!----------------------------------------
! Merge pieces together
!----------------------------------------
i = 1
chunk2 = chunk
do while (chunk2 < size(A))

   !$OMP parallel do default(shared) private(thread, from, middle, ito) schedule(guided)
   do thread = 0, ceiling(.5 * size(A) / chunk2)
      from   = thread*2     * chunk2 + 1
      middle = (thread*2 + 1) * chunk2
      ito     = (thread*2 + 2) * chunk2

      middle = min(middle, size(A))
      ito     = min(ito, size(A))
      if (from < ito) then
         call I_merge(A, order, from, middle, ito)
      end if
   end do
   !$OMP end parallel do

   chunk2 = chunk2 * 2
   i = i + 1
end do

end subroutine I_parallel_sort

!> Merge two parts of A, ordered by order from left to right
!! around middle.
subroutine I_merge (A, order, left, middle, right)
integer, intent(in), dimension(:) :: A
integer, intent(inout), dimension(size(A)) :: order

integer, intent(in) :: left, middle, right

integer :: leftA, rightA, leftB, rightB
integer :: iA, iB, i

integer, dimension(left    :middle) :: orderA
integer, dimension(middle+1:right ) :: orderB

! copy order
orderA = order(left    :middle)
orderB = order(middle+1:right)

! more explicit variables
leftA  = left
rightA = middle
leftB  = middle+1
rightB = right

! initialize iA, iB to their leftmost position
iA = leftA
iB = leftB

i = leftA

do while ((iA <= rightA) .and. (iB <= rightB))
   if (A(orderA(iA)) <= A(orderB(iB))) then
      order(i) = orderA(iA)
      iA = iA + 1
   else
      order(i) = orderB(iB)
      iB = iB + 1
   end if

   i = i + 1
end do

! either A or B still have elements, append them to the new order
do while (iA <= rightA)
   order(i) = orderA(iA)
   iA = iA + 1

   i  = i + 1

end do
do while (iB <= rightB)
   order(i) = orderB(iB)
   iB = iB + 1

   i  = i + 1
end do

end subroutine I_merge

end module mod_sort

Recommend Projects

React

A declarative, efficient, and flexible JavaScript library for building user interfaces.
Vue.js

🖖 Vue.js is a progressive, incrementally-adoptable JavaScript framework for building UI on the web.
Typescript

TypeScript is a superset of JavaScript that compiles to clean JavaScript output.
TensorFlow

An Open Source Machine Learning Framework for Everyone
Django

The Web framework for perfectionists with deadlines.
Laravel

A PHP framework for web artisans
D3

Bring data to life with SVG, Canvas and HTML. 📊📈🎉

Recommend Topics

javascript

JavaScript (JS) is a lightweight interpreted programming language with first-class functions.
web

Some thing interesting about web. New door for the world.
server

A server is a program made to process requests and deliver data to clients.
Machine learning

Machine learning is a way of modeling and interpreting data that allows a piece of software to respond intelligently.
Visualization

Some thing interesting about visualization, use data art
Game

Some thing interesting about game, make everyone happy.

Recommend Org

Facebook

We are working to build community through open source technology. NB: members must have two-factor auth.
Microsoft

Open source projects and samples from Microsoft.
Google

Google ❤️ Open Source for everyone.
Alibaba

Alibaba Open Source for everyone
D3

Data-Driven Documents codes.
Tencent

China tencent open source team.