Visible to Intel only — GUID: GUID-B235E210-3449-4003-A455-6E20DD56D52C
Visible to Intel only — GUID: GUID-B235E210-3449-4003-A455-6E20DD56D52C
QSORT
Portability Subroutine: Performs a quick sort on an array of rank one.
Module
USE IFPORT
CALL QSORT (array,len,isize,compar)
array |
(Input) Any type except assumed-length character. A one-dimensional array to be sorted. If the data type does not conform to one of the predefined interfaces for QSORT, you may have to create a new interface (see Note and Example below). |
len |
(Input) INTEGER(4) on IA-32 architecture; INTEGER(8) on Intel® 64 architecture. Number of elements in array. |
isize |
(Input) INTEGER(4) on IA-32 architecture; INTEGER(8) on Intel® 64 architecture. Size, in bytes, of a single element of array:
|
compar |
(Input) INTEGER(2). Name of a user-defined ordering function that determines sort order. The type declaration of compar takes the form: INTEGER(2) FUNCTION compar(arg1, arg2) where arg1 and arg2 have the same type as array (above) and are not assumed-length character. Assume-length characters should be wrapped in a derived type. After you have created an ordering scheme, implement your sorting function so that it returns the following:
Dummy argument compar must be declared as external. In place of an INTEGER kind, you can specify the constant SIZEOF_SIZE_T, defined in IFPORT.F90, for argument len or isize. Use of this constant ensures correct compilation. |
If you use QSORT with different data types, your program must have a USE IFPORT statement so that all the calls work correctly. In addition, if you wish to use QSORT with a derived type or a type that is not in the predefined interfaces, you must include an overload for the generic subroutine QSORT. Examples of how to do this are in the portability module's source file, IFPORT.F90.
Example
! program showing how to call 'QSORT' on
! a user-defined type.
!
! Define the type to be shared.
!
module share_type
type element_type
integer :: data
character(10) :: key
end type
end module
! Main program calls QSORT.
!
program main
use, intrinsic :: iso_c_binding, only: c_size_t
use IFPORT ! To get QSORT
use share_type ! To get shared type
! Define an overload of the default QSORT signature
! with a signature using the shared type.
!
interface
subroutine QSORT_element_types(array, len, isize, comp)
use, intrinsic :: iso_c_binding, only:c_size_t
use share_type
type(element_type) array(len)
integer(C_SIZE_T) len, isize
integer(2), external :: comp
!
! Hook the overload to the real thing but be careful
! to connect to the correct qsort: the Fortran one, not
! the C one!
!
! We need to call the _Fortran_ qsort, not the _C_ one, or
! there will be errors from the 1-origin vs. 0-origin indexing
! and the row-major vs. column-major ordering.
!
! The symptom is that "OrderCharCI" is called with pointer values
! which are outside the bounds of the array to be sorted.
!
!DIR$ IF DEFINED(_WIN64)
!DIR$ ATTRIBUTES ALIAS:'QSORT' :: QSORT_element_types
!DIR$ ELSE
!DIR$ ATTRIBUTES ALIAS: '_QSORT' :: QSORT_element_types
!DIR$ ENDIF
end subroutine QSORT_element_types
end interface
type(element_type) :: c(7)
integer(2), external :: OrderCharCI
integer (C_SIZE_T) :: size_of_element, size_of_array
! Fill in the array to be sorted. The data value is chosen so
! that the sorted array will have the values in numeric order.
! Thus we can check the result of the sort.
!
c(1)%key = 'aisjdop'
c(1)%data = 3
c(2)%key = '35djf2'
c(2)%data = 1
c(3)%key = 'ss:ss'
c(3)%data = 6
c(4)%key = 'MMhQQ'
c(4)%data = 4
c(5)%key = 'mmHqq'
c(5)%data = 5
c(6)%key = 'aaaa'
c(6)%data = 2
c(7)%key = '["\/'
c(7)%data = 7
size_of_array = size(c) ! 7
size_of_element = sizeof(c(1)) ! 16
write(*,*) '"C" is:'
do i = 1, 7
write(*,*) ' "', c(i)%key, '" value ', c(i)%data
end do
write(*,*) ' '
write(*,*) 'size of C is ', size_of_array, ' elements'
write(*,*) 'size of element C(1) is ', size_of_element, ' bytes'
write(*,*) 'len of key in C(1) is ', len(c(1)%key)
write(*,*) ' '
! Call the overloaded QSORT routine.
!
Call QSort_element_types(C, size_of_array, size_of_element, OrderCharCI)
write(*,*) 'Sorted "C" is '
do i = 1, 7
write(*,*) ' "', c(i)%key, '" value ', c(i)%data
end do
end program main
! Computes order of character strings using a case insensitive ordering.
!
! Return -1 if C1 before C2, 0 if C1 = C2, and 1 if C1 after C2.
!
! Called first with the pair (2,3), then (1,2), then (1,3)...when passing
! character strings of length 10.
!
! Passing "element_type" objects, it's called first with the pair (1, <invalid>),
! and the second item has a address well before the beginning of "C".
!
function OrderCharCI(c1, c2)
use share_type
implicit none
type(element_type), intent(in) :: c1 ! Character strings to be ordered.
type(element_type), intent(in) :: c2 !
! Function result:
!
integer(2) :: OrderCharCI
! Locals:
!
character(10) :: c1L !} Local copies of c1 and c2.
character(10) :: c2L !}
integer :: i ! Loop index.
write(*,*)'OrderCharCI, parameter C1 is "', c1%key, '" ', c1%data, ', len is ', len(c1%key)
write(*,*)' len_trim is ', len_trim(c1%key)
write(*,*) ' '
! SEGV on access to C2
!
write(*,*)'OrderCharCI, parameter C2 is "', c2%key, '" ', c2%data, ', len is ', len(c2%key)
write(*,*)' len_trim is ', len_trim(c2%key)
write(*,*) ' '
c1L = c1%key
c2L = c2%key
write(*,*) 'about to start do loop'
do i = 1, len_trim(C1L)
if ('a' <= C1L(i:i) .and. c1L(i:i) <= 'z') c1L(i:i) = char(ichar(c1L(i:i)) - ichar('a') + ichar('A'))
end do
do i = 1, len_trim(C2L)
if ('a' <= c2L(i:i) .and. c2L(i:i) <= 'z') c2L(i:i) = char(ichar(c2L(i:i)) - ichar('a') + ichar('A'))
end do
if (c1L == c2L) Then
OrderCharCI = 0
write(*,*) ' - equal'
else if (c1L < c2L) Then
OrderCharCI = -1
write(*,*) ' - c1 is less'
else
OrderCharCI = 1
write(*,*) ' - c1 is more'
end if
end function OrderCharCI
The following shows another example:
PROGRAM SORTQ
use, intrinsic :: iso_c_binding, only: c_size_t
use IFPORT
integer(2), external :: cmp_function
integer(2) insort(26), i
integer (C_SIZE_T) array_len, array_size
array_len = 26
array_size = 2
do i=90,65,-1
insort(i-64)=91 - i
end do
print *, "Before: "
print *,insort
CALL qsort(insort,array_len,array_size,cmp_function)
print *, 'After: '
print *, insort
END
!
integer(2) function cmp_function(a1, a2)
integer(2) a1, a2
cmp_function=a1-a2
end function