Community
cancel
Showing results for 
Search instead for 
Did you mean: 
Highlighted
Beginner
2 Views

QSORT using pointers for derived type

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
Highlighted
Beginner
2 Views

This works on both x86 and

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

 

0 Kudos
Highlighted
Black Belt
2 Views

This isn't much different

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.

--
Steve (aka "Doctor Fortran") - https://stevelionel.com/drfortran
0 Kudos
Highlighted
Beginner
2 Views

I left the ifport out by

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. 

0 Kudos
Highlighted
Beginner
2 Views

It would appear 'use kernel32

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

 

0 Kudos
Highlighted
Beginner
2 Views

I would crash all x64 until

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).

0 Kudos
Highlighted
Beginner
2 Views

I wonder if the QSORT without

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.

 

0 Kudos
Highlighted
Black Belt
2 Views

I wondered that too, but

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.

--
Steve (aka "Doctor Fortran") - https://stevelionel.com/drfortran
0 Kudos
Highlighted
Beginner
2 Views

xsortfq, using ifport, x64

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
 

0 Kudos