Thanks for using Compiler Explorer
Sponsors
Jakt
C++
Ada
Analysis
Android Java
Android Kotlin
Assembly
C
C3
Carbon
C++ (Circle)
CIRCT
Clean
CMake
CMakeScript
COBOL
C++ for OpenCL
MLIR
Cppx
Cppx-Blue
Cppx-Gold
Cpp2-cppfront
Crystal
C#
CUDA C++
D
Dart
Elixir
Erlang
Fortran
F#
Go
Haskell
HLSL
Hook
Hylo
ispc
Java
Julia
Kotlin
LLVM IR
LLVM MIR
Modula-2
Nim
Objective-C
Objective-C++
OCaml
OpenCL C
Pascal
Pony
Python
Racket
Ruby
Rust
Snowball
Scala
Solidity
Spice
Swift
LLVM TableGen
Toit
TypeScript Native
V
Vala
Visual Basic
Zig
Javascript
GIMPLE
fortran source #1
Output
Compile to binary object
Link to binary
Execute the code
Intel asm syntax
Demangle identifiers
Verbose demangling
Filters
Unused labels
Library functions
Directives
Comments
Horizontal whitespace
Debug intrinsics
Compiler
AARCH64 gfortran 10.5.0
AARCH64 gfortran 11.4.0
AARCH64 gfortran 12.1.0
AARCH64 gfortran 12.2.0
AARCH64 gfortran 12.3.0
AARCH64 gfortran 13.1.0
AARCH64 gfortran 13.2.0
AARCH64 gfortran 6.4
AARCH64 gfortran 7.3
AARCH64 gfortran 8.2
ARM (32bit) gfortran 10.5.0
ARM (32bit) gfortran 11.4.0
ARM (32bit) gfortran 12.1.0
ARM (32bit) gfortran 12.2.0
ARM (32bit) gfortran 12.3.0
ARM (32bit) gfortran 13.1.0
ARM (32bit) gfortran 13.2.0
ARM (32bit) gfortran 6.4
ARM (32bit) gfortran 7.3
ARM (32bit) gfortran 8.2
LOONGARCH64 gfortran 12.2.0
LOONGARCH64 gfortran 12.3.0
LOONGARCH64 gfortran 13.1.0
LOONGARCH64 gfortran 13.2.0
MIPS gfortran 12.1.0
MIPS gfortran 12.2.0
MIPS gfortran 12.3.0
MIPS gfortran 13.1.0
MIPS gfortran 13.2.0
MIPS gfortran 4.9.4
MIPS gfortran 5.5.0
MIPS gfortran 9.5.0
MIPS64 gfortran 12.1.0
MIPS64 gfortran 12.2.0
MIPS64 gfortran 12.3.0
MIPS64 gfortran 13.1.0
MIPS64 gfortran 13.2.0
MIPS64 gfortran 4.9.4
MIPS64 gfortran 5.5.0
MIPS64 gfortran 9.5.0
MIPS64el gfortran 12.1.0
MIPS64el gfortran 12.2.0
MIPS64el gfortran 12.3.0
MIPS64el gfortran 13.1.0
MIPS64el gfortran 13.2.0
MIPS64el gfortran 4.9.4
MIPS64el gfortran 5.5.0
MIPS64el gfortran 9.5.0
MIPSel gfortran 12.1.0
MIPSel gfortran 12.2.0
MIPSel gfortran 12.3.0
MIPSel gfortran 13.1.0
MIPSel gfortran 13.2.0
MIPSel gfortran 4.9.4
MIPSel gfortran 5.5.0
MIPSel gfortran 9.5.0
POWER gfortran 12.1.0
POWER gfortran 12.2.0
POWER gfortran 12.3.0
POWER gfortran 13.1.0
POWER gfortran 13.2.0
POWER64 gfortran 12.1.0
POWER64 gfortran 12.2.0
POWER64 gfortran 12.3.0
POWER64 gfortran 13.1.0
POWER64 gfortran 13.2.0
POWER64 gfortran trunk
POWER64le gfortran 12.1.0
POWER64le gfortran 12.2.0
POWER64le gfortran 12.3.0
POWER64le gfortran 13.1.0
POWER64le gfortran 13.2.0
POWER64le gfortran trunk
RISC-V 32-bits gfortran (trunk)
RISC-V 32-bits gfortran 12.1.0
RISC-V 64-bits gfortran (trunk)
RISC-V 64-bits gfortran 12.1.0
RISCV (32bit) gfortran 11.4.0
RISCV (32bit) gfortran 12.2.0
RISCV (32bit) gfortran 12.3.0
RISCV (32bit) gfortran 13.1.0
RISCV (32bit) gfortran 13.2.0
RISCV64 gfortran 11.4.0
RISCV64 gfortran 12.2.0
RISCV64 gfortran 12.3.0
RISCV64 gfortran 13.1.0
RISCV64 gfortran 13.2.0
SPARC LEON gfortran 12.2.0
SPARC LEON gfortran 12.3.0
SPARC LEON gfortran 13.1.0
SPARC LEON gfortran 13.2.0
SPARC gfortran 12.2.0
SPARC gfortran 12.3.0
SPARC gfortran 13.1.0
SPARC gfortran 13.2.0
SPARC64 gfortran 12.2.0
SPARC64 gfortran 12.3.0
SPARC64 gfortran 13.1.0
SPARC64 gfortran 13.2.0
flang-trunk (flang-new)
flang-trunk (flang-to-external-fc)
power64 AT12.0
power64 AT13.0
power64le AT12.0
power64le AT13.0
s390x gfortran 12.1.0
s390x gfortran 12.2.0
s390x gfortran 12.3.0
s390x gfortran 13.1.0
s390x gfortran 13.2.0
x86-64 gfortran (trunk)
x86-64 gfortran 10.1
x86-64 gfortran 10.2
x86-64 gfortran 10.3
x86-64 gfortran 10.4
x86-64 gfortran 10.5
x86-64 gfortran 11.1
x86-64 gfortran 11.2
x86-64 gfortran 11.3
x86-64 gfortran 11.4
x86-64 gfortran 12.1
x86-64 gfortran 12.2
x86-64 gfortran 12.3
x86-64 gfortran 13.1
x86-64 gfortran 13.2
x86-64 gfortran 4.9.4
x86-64 gfortran 5.5
x86-64 gfortran 6.3
x86-64 gfortran 7.1
x86-64 gfortran 7.2
x86-64 gfortran 7.3
x86-64 gfortran 8.1
x86-64 gfortran 8.2
x86-64 gfortran 8.3
x86-64 gfortran 8.4
x86-64 gfortran 8.5
x86-64 gfortran 9.1
x86-64 gfortran 9.2
x86-64 gfortran 9.3
x86-64 gfortran 9.4
x86-64 ifort 19.0.0
x86-64 ifort 2021.1.2
x86-64 ifort 2021.10.0
x86-64 ifort 2021.11.0
x86-64 ifort 2021.2.0
x86-64 ifort 2021.3.0
x86-64 ifort 2021.4.0
x86-64 ifort 2021.5.0
x86-64 ifort 2021.6.0
x86-64 ifort 2021.7.0
x86-64 ifort 2021.7.1
x86-64 ifort 2021.8.0
x86-64 ifort 2021.9.0
x86-64 ifx (latest)
x86-64 ifx 2021.1.2
x86-64 ifx 2021.2.0
x86-64 ifx 2021.3.0
x86-64 ifx 2021.4.0
x86-64 ifx 2022.0.0
x86-64 ifx 2022.1.0
x86-64 ifx 2022.2.0
x86-64 ifx 2022.2.1
x86-64 ifx 2023.0.0
x86-64 ifx 2023.1.0
x86-64 ifx 2023.2.1
x86-64 ifx 2024.0.0
Options
Source code
module sorting_f use iso_fortran_env, only: int32,int64 implicit none private integer, parameter, public :: IKIND = int32 integer, parameter, public :: ISIZE = int64 public :: argsort_f contains !> Argsort: Federico's implementation subroutine argsort_f(n,list,keys) integer(ISIZE), intent(in) :: n integer(ISIZE), intent(inout) :: list(*) ! indices to the sorted array integer(IKIND), intent(in) :: keys(*) ! Array to be sorted integer :: sorted(n) sorted = keys(1:n) call int_quick_sort_andlist(sorted,list(1:n)) end subroutine argsort_f pure recursive subroutine int_quick_sort_andlist(list,ilist,down) integer(IKIND), dimension(:), intent(inout) :: list integer(ISIZE), dimension(size(list)), intent(inout) :: ilist logical, optional, intent(in) :: down integer(ISIZE) :: i, j, n integer(ISIZE), parameter :: max_simple_sort_size = 8 integer(IKIND) :: chosen logical :: descending descending = .false.; if (present(down)) descending = down n = size(list) choose_sorting_algorithm: if (n <= max_simple_sort_size) then ! Use interchange sort for small lists do i = 1, size(list) - 1 do j = i + 1, size(list) if (toBeSwapped(list(i),list(j),.false.)) then call swap(list(i),list(j)) call swaplist(ilist(i),ilist(j)) end if end do end do else ! Use partition (quick) sort if the list is big chosen = list(int(n/2)) i = 0 j = n + 1 scan_lists: do ! Scan list from left end ! until element >= chosen is found scan_from_left: do i = i + 1 if (toBeSwapped(list(i),chosen,.true.) .or. i==n) exit scan_from_left end do scan_from_left ! Scan list from right end ! until element <= chosen is found scan_from_right: do j = j - 1 if (toBeSwapped(chosen,list(j),.true.) .or. j==1) exit scan_from_right end do scan_from_right swap_element: if (i < j) then ! Swap two out of place elements call swap(list(i),list(j)) call swaplist(ilist(i),ilist(j)) else if (i == j) then i = i + 1 exit else exit endif swap_element end do scan_lists if (1 < j) call int_quick_sort_andlist(list(:j),ilist(:j),down) if (i < n) call int_quick_sort_andlist(list(i:),ilist(i:),down) end if choose_sorting_algorithm ! test for small array contains elemental logical function toBeSwapped(a,b,orEqual) integer(IKIND), intent(in) :: a,b logical, intent(in) :: orEqual toBeSwapped = merge(a<b,a>b,descending) if (orEqual .and. a==b) toBeSwapped = .true. end function toBeSwapped elemental subroutine swap(a,b) integer(IKIND), intent(inout) :: a,b integer(IKIND) :: tmp tmp = a a = b b = tmp end subroutine swap elemental subroutine swaplist(a,b) integer(ISIZE), intent(inout) :: a,b integer(ISIZE) :: tmp tmp = a a = b b = tmp end subroutine swaplist end subroutine int_quick_sort_andlist end module sorting_f module sorting use, intrinsic :: iso_c_binding implicit none private public :: argsort contains !> Returns the indices that would sort an array !> !> Arguments: !> n: number of elements !> list: on entry, list of indices 1..(1)..n !> (for reverse sort, n..(-1)..1) !> on return, the indices such that keys(list) would be sorted !> keys: array to be sorted !> subroutine argsort(n,list,keys) integer, intent(in) :: n integer, intent(inout), target :: list(*) integer, intent(in) :: keys(*) interface subroutine qsort(ptr,count,size,comp) bind(c,name="qsort") import c_ptr, c_int, c_size_t, c_funptr implicit none type(c_ptr), intent(in), value :: ptr !> pointer to the array to sort integer(c_size_t), intent(in), value :: count !> number of elements in the array integer(c_size_t), intent(in), value :: size !> size of each element in the array in bytes type(c_funptr), intent(in), value :: comp !> comparison function which returns a negative integer value !> if the first argument is less than the second, a positive !> integer value if the first argument is greater than the !> second and zero if the arguments are equivalent end subroutine end interface if (n < 2) then ! list already sorted return end if call qsort(c_loc(list),int(n,c_size_t),c_sizeof(list(1)), & c_funloc(argsort_compare)) contains ! technically, the inputs should be void pointers ! but works nevertheless integer(c_int) function argsort_compare(a,b) bind(c) integer(c_int), intent(in) :: a, b argsort_compare = keys(a) - keys(b) end function end subroutine end module sorting program main use iso_c_binding, only: c_int use sorting use sorting_f implicit none integer(ISIZE), parameter :: N = 100000 real, allocatable :: x(:) integer(ISIZE), allocatable :: listf(:) integer(IKIND), allocatable :: keys(:),list(:) integer(ISIZE) :: j real :: t0,t1,t2 allocate(list(N),keys(N),x(N)) call random_number(x) keys(:) = nint(N*x) list(:) = [(j,j=1,N)] listF = list call cpu_time(t0); call argsort(int(N,c_int),list,keys) print *, keys(1:5),list(1:5) call cpu_time(t1); call argsort_f(N,listf,keys) print *, keys(1:5),list(1:5) call cpu_time(t2) ! Supposed to print [ 3, 5, 6, 7] print *, 'C time=',t1-t0 print *, 'F time=',t2-t1 end program
Become a Patron
Sponsor on GitHub
Donate via PayPal
Source on GitHub
Mailing list
Installed libraries
Wiki
Report an issue
How it works
Contact the author
CE on Mastodon
About the author
Statistics
Changelog
Version tree