Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.
Announcements
Welcome to the Intel Community. If you get an answer you like, please mark it as an Accepted Solution to help others. Thank you!

QSORT using pointers for derived type

MWind2
New Contributor I
99 Views

When I read the QSORT doc I wondered if there were a way to do a derived type qsort. Anyway, how crazy is this:

!x86 not x64

!  xsortf.f90 
!
!  FUNCTIONS:
!  xsortf - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: xsortf
!
!  PURPOSE:  Entry point for the console application.
!
!****************************************************************************



module mrecf
use kernel32
use iso_c_binding
    implicit none
     integer, save, volatile   :: lv
    type recf
      integer :: i
      double precision :: d
      integer :: t 
      integer :: v
    end type recf
    contains
    subroutine Zrecf(this)
    ! recf constructor
       type (recf), intent (out) :: this
       this%i = -1
       this%d = 0.0
       this%t = -1
       this%v = interlockedexchangeadd(LOC(lv),1)
    end subroutine  Zrecf
    function comp_recf(i0,i1) result(i2comp)
    integer*2 :: i2comp
    TYPE(recf), pointer, intent(in) :: i0
    TYPE(recf), pointer, intent(in) :: i1
    !Negative if arg1 should precede arg2
    !Zero if arg1 is equivalent to arg2
    !Positive if arg1 should follow arg2
    if (i0%i < i1%i) then
        i2comp=-1 
    elseif (i0%i == i1%i) then
		if (i0%t < i1%t) then 
            i2comp=-1
        else if (i0%t == i1%t) then
			if (i0%v < i1%v) then
                i2comp=-1
            ! not ever equal
            elseif (i0%v > i1%v)then
                i2comp=1
            else
                i2comp=0 
            endif
        else
            i2comp=1
        endif
    else
        i2comp=1
   endif
    !
    
    end function  comp_recf
end module mrecf
    
    
    program xsortf
use mrecf

    implicit none 
   
    ! Variables
    integer, parameter :: nrecs = 256
    integer, parameter :: nirecs = 8
    integer, parameter :: ntrecs = 512
    double precision, parameter :: dmax = 1000.0
    type(recf), dimension(:), pointer :: arecf
    integer*4, dimension(:), pointer :: airecf_sort
    type(recf), dimension(:), pointer :: arecf_sort
    real, dimension(:), pointer :: arrecf 
    integer :: ix
    type(recf) ::t
    pointer (p,t)
    
    !integer 
    ! Body of xsortf
    allocate(arecf(nrecs))
     allocate(airecf_sort(nrecs))
    allocate(arecf_sort(nrecs))
    allocate(arrecf(nrecs))
    
    do ix=1,nrecs
        call zrecf(arecf(ix))
        call random_number(arrecf(ix))
        arecf(ix)%i = int(real(nirecs)*arrecf(ix))
        call random_number(arrecf(ix))
        arecf(ix)%d = dmax*arrecf(ix)
        call random_number(arrecf(ix))
        arecf(ix)%t = int(real(ntrecs)*arrecf(ix))
    end do
    do ix=1,nrecs
        print *, arecf(ix)%i, arecf(ix)%d, arecf(ix)%t, arecf(ix)%v
    end do
    do ix=1,nrecs
         airecf_sort(ix)=LOC(arecf(ix))
    end do
    call qsort(airecf_sort, nrecs, 4, comp_recf)
    do ix=1,nrecs
        p=airecf_sort(ix)
        arecf_sort(ix)= t
    end do
    print *,'Sorted:'
    do ix=1,nrecs
        print *,arecf_sort(ix)%i, arecf_sort(ix)%d, arecf_sort(ix)%t, arecf_sort(ix)%v
    end do
    end program xsortf

 

0 Kudos
8 Replies
MWind2
New Contributor I
99 Views

This works on both x86 and x64:

!****************************************************************************
!
!  PROGRAM: xsortf
!
!  PURPOSE:  Entry point for the console application.
!
!****************************************************************************
module mrecf
use kernel32
use iso_c_binding
    implicit none
     integer, save, volatile   :: lv
    type recf
      integer :: i
      double precision :: d
      integer :: t 
      integer :: v
    end type recf
    contains
    subroutine Zrecf(this)
    ! recf constructor
       type (recf), intent (out) :: this
       this%i = -1
       this%d = 0.0
       this%t = -1
       this%v = interlockedexchangeadd(LOC(lv),1)
    end subroutine  Zrecf
    function comp_recf(i0,i1) result(i2comp)
    integer*2 :: i2comp
    TYPE(recf), pointer, intent(in) :: i0
    TYPE(recf), pointer, intent(in) :: i1
    integer(pointer_len) :: precf0
    integer(pointer_len) :: precf1
    !Negative if arg1 should precede arg2
    !Zero if arg1 is equivalent to arg2
    !Positive if arg1 should follow arg2
    precf0=loc(i0)
    precf1=loc(i1)
    if (i0%i < i1%i) then
        i2comp=-1 
    elseif (i0%i == i1%i) then
		if (i0%t < i1%t) then 
            i2comp=-1
        else if (i0%t == i1%t) then
			if (i0%v < i1%v) then
                i2comp=-1
            ! not ever equal
            elseif (i0%v > i1%v)then
                i2comp=1
            else
                i2comp=0 
            endif
        else
            i2comp=1
        endif
    else
        i2comp=1
   endif
    !
    
    end function  comp_recf
end module mrecf
    
    
    program xsortf
use mrecf

    implicit none 
   
    ! Variables
    integer, parameter :: nrecs = 256
    integer, parameter :: nirecs = 8
    integer, parameter :: ntrecs = 512
    double precision, parameter :: dmax = 1000.0
    integer(pointer_len), parameter :: ipl_len = pointer_len
    integer(pointer_len), parameter :: ipl_sz = nrecs
    integer :: iplen = 0
    type(recf), dimension(:), pointer :: arecf
    integer(pointer_len), dimension(:), pointer :: airecf_sort
    !integer, dimension(:), pointer :: airecf_sort
    type(recf), dimension(:), pointer :: arecf_sort
    real, dimension(:), pointer :: arrecf 
    integer :: ix
    type(recf) ::t
    pointer (p,t)
    
    !integer 
    ! Body of xsortf
    allocate(arecf(nrecs))
    allocate(airecf_sort(nrecs))
    allocate(arecf_sort(nrecs))
    allocate(arrecf(nrecs))
    
    do ix=1,nrecs
        call zrecf(arecf(ix))
        call random_number(arrecf(ix))
        arecf(ix)%i = int(real(nirecs)*arrecf(ix))
        call random_number(arrecf(ix))
        arecf(ix)%d = dmax*arrecf(ix)
        call random_number(arrecf(ix))
        arecf(ix)%t = int(real(ntrecs)*arrecf(ix))
    end do
    do ix=1,nrecs
        print *, arecf(ix)%i, arecf(ix)%d, arecf(ix)%t, arecf(ix)%v
    end do
    do ix=1,nrecs
         airecf_sort(ix)=LOC(arecf(ix))
    end do
    iplen=pointer_len
    !call qsort(airecf_sort, nrecs, pointer_len, comp_recf)
    call qsort(airecf_sort, ipl_sz, ipl_len, comp_recf)
    do ix=1,nrecs
        p=airecf_sort(ix)
        arecf_sort(ix)= t
    end do
    print *,'Sorted:'
    do ix=1,nrecs
        print *,arecf_sort(ix)%i, arecf_sort(ix)%d, arecf_sort(ix)%t, arecf_sort(ix)%v
    end do
    end program xsortf

 

Steve_Lionel
Black Belt Retired Employee
99 Views

This isn't much different from the example in the ifort documentation on QSORT, though I was initially puzzled in that the documentation has you create an alternate interface whose external procedure is _qsort (this example hasn't been updated for x64!) You're not using module IFPORT so you get a symbol named QSORT which happens to be defined in libifport.lib. The documentation warns against unintentionally linking to the C library's qsort (I haven't looked to see what its external name is) as the interface is different.

MWind2
New Contributor I
99 Views

I left the ifport out by mistake and went after making a multi- key sort which I thought the fortran qsort would not do. Can it use different members of a derived type to sort? Also, I have not yet found docs on the qsort I used. 

if the last print statement is changed to 

print * ,arecf_sort(ix)%i, arecf_sort(ix)%t, arecf_sort(ix)%v, arecf_sort(ix)%d

the sort is easier to see. 

MWind2
New Contributor I
99 Views

It would appear 'use kernel32' caused problem. First error with ifport was pointer_len multiple definition. Below is code without kernel32:

module mrecfq
use ifport
!use kernel32
use iso_c_binding
    implicit none
     integer, save, volatile   :: lv
    type recf
      integer :: i
      double precision :: d
      integer :: t 
      integer :: v
    end type recf
    contains
    subroutine Zrecf(this)
    ! recf constructor
       type (recf), intent (out) :: this
       this%i = -1
       this%d = 0.0
       this%t = -1
       !this%v = interlockedexchangeadd(LOC(lv),1)
       this%v = lv
       lv=lv+1
    end subroutine  Zrecf
    function comp_recf(i0,i1) result(i2comp)
    integer*2 :: i2comp
    TYPE(recf), pointer, intent(in) :: i0
    TYPE(recf), pointer, intent(in) :: i1
    integer(pointer_len) :: precf0
    integer(pointer_len) :: precf1
    !Negative if arg1 should precede arg2
    !Zero if arg1 is equivalent to arg2
    !Positive if arg1 should follow arg2
    precf0=loc(i0)
    precf1=loc(i1)
    if (i0%i < i1%i) then
        i2comp=-1 
    elseif (i0%i == i1%i) then
		if (i0%t < i1%t) then 
            i2comp=-1
        else if (i0%t == i1%t) then
			if (i0%v < i1%v) then
                i2comp=-1
            ! not ever equal
            elseif (i0%v > i1%v)then
                i2comp=1
            else
                i2comp=0 
            endif
        else
            i2comp=1
        endif
    else
        i2comp=1
   endif
    !
    
    end function  comp_recf
end module mrecfq
    
    
    program xsortfq
use mrecfq

    implicit none 
   
    ! Variables
    integer, parameter :: nrecs = 256
    integer, parameter :: nirecs = 8
    integer, parameter :: ntrecs = 512
    double precision, parameter :: dmax = 1000.0
    integer(pointer_len), parameter :: ipl_len = pointer_len
    integer(pointer_len), parameter :: ipl_sz = nrecs
    integer :: iplen = 0
    type(recf), dimension(:), pointer :: arecf
    integer(pointer_len), dimension(:), pointer :: airecf_sort
    !integer, dimension(:), pointer :: airecf_sort
    type(recf), dimension(:), pointer :: arecf_sort
    real, dimension(:), pointer :: arrecf 
    integer :: ix
    type(recf) ::t
    pointer (p,t)
    
    !integer 
    ! Body of xsortf
    allocate(arecf(nrecs))
    allocate(airecf_sort(nrecs))
    allocate(arecf_sort(nrecs))
    allocate(arrecf(nrecs))
    
    do ix=1,nrecs
        call zrecf(arecf(ix))
        call random_number(arrecf(ix))
        arecf(ix)%i = int(real(nirecs)*arrecf(ix))
        call random_number(arrecf(ix))
        arecf(ix)%d = dmax*arrecf(ix)
        call random_number(arrecf(ix))
        arecf(ix)%t = int(real(ntrecs)*arrecf(ix))
    end do
    do ix=1,nrecs
        print *, arecf(ix)%t, arecf(ix)%i, arecf(ix)%d,  arecf(ix)%v
    end do
    do ix=1,nrecs
         airecf_sort(ix)=LOC(arecf(ix))
    end do
    iplen=pointer_len
    !call qsort(airecf_sort, nrecs, pointer_len, comp_recf)
    call qsort(airecf_sort, ipl_sz, ipl_len, comp_recf)
    do ix=1,nrecs
        p=airecf_sort(ix)
        arecf_sort(ix)= t
    end do
    print *,'Sorted:'
    do ix=1,nrecs
        print * ,arecf_sort(ix)%i, arecf_sort(ix)%t, arecf_sort(ix)%v, arecf_sort(ix)%d  
    end do
    end program xsortfq

 

MWind2
New Contributor I
99 Views

I would crash all x64 until qsort was called with integer('pointer_len) variables explicitly declared for len and isize in QSORT (array,len,isize,compar).

MWind2
New Contributor I
99 Views

I wonder if the QSORT without ifport is the c crt:

https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/qsort?view=vs-2019

but intel c/c++ version?

It looks like the fortran one as c.

 

Steve_Lionel
Black Belt Retired Employee
99 Views

I wondered that too, but QSORT in uppercase, which is what you get (unless you compiled with options you didn't show) is resolved from the IFPORT library. IFPORT declares a generic QSORT with entries for various intrinsic data types. Yes, you need to use 64-bit length and size on x64.

MWind2
New Contributor I
99 Views

xsortf, using kernel32(no ifport), x86
 _QSORT                     0040524a f   libifportmd:libifportMD.dll
xsortf, using kernel32(no ifport), x64
__imp_QSORT                000000014000b248     libifportmd:libifportMD.dll

xsortfq, using ifport, x86
_QSORT                     00405244 f   libifportmd:libifportMD.dll
xsortfq, using ifport, x64
 __imp_QSORT                000000014000a1b0     libifportmd:libifportMD.dll
 

Reply