- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
I am trying to use merge_sort function that is contained in module-1 within module-2. No matter where I place the USE module-1 statement within module-2, I get compiler errors. Either error #6285: There is no matching specific subroutine for this generic subroutine call. Or catastrophic error: **Internal compiler error: segmentation violation signal raised**. Obviously I am missing something in my understanding of modules.
The basic set up is that module-1 is a merge sort module that sorts int64 arrays or arrays of objects of class face. The second module is the face class and in its constructor I would like to call the int64 merge sort.
Here is a stripped down version of the merge sort module and the face module. Error #6285 is thrown by the compiler when I place "use mergesort_class" at the top of module face_class; i.e. between lines 01 and 02. The catastropic error is thrown by the compiler when instead I place the use mergesort_class at the top of function make_face; i.e. between lines 23 and 24. See below the code snippets for the actual error messages.
I am relatively new to trying to use modules/classes in Fortran, so I am a bit shaky on the internal workings, despite lots of reading. Any and all help will be greatly appreciated.
-sanjay
module mergesort_class ! Source file mergesort_class
implicit none
private
public :: mergesort
interface mergesort
module procedure ms_int64, ms_face
end interface
contains
subroutine ms_int64(array,n,idx)
implicit none
integer :: n
integer :: idx(*)
integer (kind=8) :: array(*)
! relevant code to merge int64
end subroutine ms_int64
subroutine mergea_int64(array,l,m,r,idx)
implicit none
integer :: l,m,r
integer :: idx(*)
integer (kind=8) :: array(*)
! relevant code to merge int64
end subroutine mergea_int64
subroutine ms_face(array,n,idx)
use face_class
implicit none
integer :: n
integer :: idx(*)
type(face) :: array(*)
! relevant code to merge face objects
end subroutine ms_face
subroutine mergea_face(array,l,m,r,idx)
use face_class
implicit none
integer :: l,m,r
integer :: idx(*)
type(face) :: array(*)
! relevant code to merge face objects
end subroutine mergea_face
end module mergesort_class
module face_class ! Source file face_class.f
implicit none
private
public :: face
! Type def for face
type face
integer (kind=8) :: hi,lo
contains
procedure :: face_equal
procedure :: face_le
generic, public :: operator (.eq.) => face_equal
generic, public :: operator (.le.) => face_le
end type face
interface face
module procedure make_face
end interface face
contains
! Constructor
type(face) function make_face(a,b,c,d)
implicit none
integer, intent(in) :: a,b,c
integer, optional, intent(in) :: d
integer (kind=8) :: n(4),m(4)
! relevant code to set up n( ) and m( )
call mergesort(n,4,m) ! Can not get this call to work
end function make_face
! overloaded .eq.
logical function face_equal(a,b)
implicit none
class(face), intent(in) :: a,b
! relevant code
end function face_equal
! overloaded .le.
logical function face_le(a,b)
implicit none
class(face), intent(in) :: a,b
! relevant code
end function face_le
end module face_class
ifort -c -O2 -Warn all -g -J/Users/sg/Feap/ver85/modules -I/Users/sg/Feap/ver85/include -I/Users/sg/Feap/ver85/modules -I/Users/sg/Feap/ver85/include/integer8 -I/sw/include face_class.f -o face_class.o
face_class.f(57): error #6285: There is no matching specific subroutine for this generic subroutine call. [MERGESORT]
call mergesort(n,4,m)
---------------^
compilation aborted for face_class.f (code 1)
make: *** [face_class.o] Error 1
ifort -c -O2 -Warn all -g -J/Users/sg/Feap/ver85/modules -I/Users/sg/Feap/ver85/include -I/Users/sg/Feap/ver85/modules -I/Users/sg/Feap/ver85/include/integer8 -I/sw/include face_class.f -o face_class.o
face_class.f: catastrophic error: **Internal compiler error: segmentation violation signal raised** Please report this error along with the circumstances in which it occurred in a Software Problem Report. Note: File and line given may not be explicit cause of this error.
compilation aborted for face_class.f (code 1)
make: *** [face_class.o] Error 1
Link Copied
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Sanjay,
You seem to have a circular dependency: your mergesort_class module tries to use face_class while face_class needs mergesort.
You need to look into avoiding such a dependency, others may have better suggestions for you, but an immediate option that comes to my mind is for you to define an abstract derived type, say abstract_face, that has deferred procedures (virtual functions) for the required comparer operations (<, >, ==, etc.) all of which is defined in a separate new module. Then have mergesort module and the subroutines in it such as merge_face 'work' with the abstract type via class(abstract_face) argument instead of type(face), followed by the face type in face_class module to be a concrete implementation of this new abstract_face type. This way, both your mergesort and face module depend on this new module rather than each other, thus avoiding the circular dependency.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Be certain to clean .mod and .o files between compilation attempts. That helps avoid creating circular module references with the aid of: error #7002: Error in opening the compiled module file.
The internal error should not happen whether the code is absent of circular references or not but I cannot reproduce it with our latest 17.0 update 1 compiler so that may have been addressed already. What ifort version (ifort -V) are you using?
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Kevin,
I'm careful to clean up since I have seen that problem before. My compiler version is
Intel(R) Fortran Intel(R) 64 Compiler XE for applications running on Intel(R) 64, Version 14.0.3.166 Build 20140415
Copyright (C) 1985-2014 Intel Corporation. All rights reserved.
so it is a bit older.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
@FortranFan
Thanks for the suggestion on using an abstract class with deferred procedures. I have seen that described in a few places and will study up on it. Notwithstanding, if you have a suggested place for me to look up how to do this effectively that will be great. Or if you can sketch something out for me and post it, that will also be great.
-sanjay
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Thank you Sanjay. I still cannot reproduce the error with the earlier 14.0 compiler so I'm just not replicating your steps. It is not important to focus on the error since from your description it requires the disallowed circular reference. It should not be a factor after you restructure your code. If we can recreate it then we will ensure it gets fixed.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
subroutine ms_int64 has
integer :: idx(*)
for the 3rd argument
call mergesort(n,4,m) ! Can not get this call to work
is passing m as an array of integer(kind=8) as 3rd argument.
IOW type mis-match
Jim Dempsey
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
@Jim
Good catch. Thanks, though that is independent of the main issue affecting me.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
@Kevin
Here are copies of the complete routines so you can reproduce the error. I get the "catastrophic error" with "ifort mergesort_class.f face_class.f". Notwithstanding, I have found some references on abstract classes and will try to implement them tonight.
module mergesort_class
implicit none
private
public :: mergesort
interface mergesort
module procedure ms_int64, ms_face
end interface
contains
subroutine ms_int64(array,n,idx)
implicit none
integer :: n,currsize,l,r,mid
integer :: idx(*)
integer (kind=8) :: array(*)
currsize = 1
do while (currsize .le. n)
l = 1
do while (l .le. n)
mid = min(l + currsize - 1,n)
r = min(l+2*currsize-1,n)
! Merge
call mergea_int64(array,l,mid,r,idx)
l = l + 2*currsize
end do
currsize = 2*currsize
end do
end subroutine ms_int64
subroutine mergea_int64(array,l,m,r,idx)
implicit none
integer :: l,m,r,i,j,k,n1,n2
integer :: idx(*)
integer :: lidx(m-l+1),ridx(r-m)
integer (kind=8) :: array(*)
integer (kind=8) :: larr(m-l+1),rarr(r-m)
n1 = m-l+1
n2 = r-m
larr(:) = array(l:m)
rarr(:) = array(m+1:r)
lidx(:) = idx(l:m)
ridx(:) = idx(m+1:r)
i = 1
j = 1
k = l
do while (i .le. n1 .and. j .le. n2)
if (larr(i) .le. rarr(j)) then
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
else
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
end if
k = k + 1
end do
do while (i .le. n1)
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
k = k + 1
end do
do while (j .le. n2)
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
k = k + 1
end do
end subroutine mergea_int64
subroutine ms_face(array,n,idx)
use face_class
implicit none
integer :: n,currsize,l,r,mid
integer :: idx(*)
type(face) :: array(*)
currsize = 1
do while (currsize .le. n)
l = 1
do while (l .le. n)
mid = min(l + currsize - 1,n)
r = min(l+2*currsize-1,n)
! Merge
call mergea_face(array,l,mid,r,idx)
l = l + 2*currsize
end do
currsize = 2*currsize
end do
end subroutine ms_face
subroutine mergea_face(array,l,m,r,idx)
use face_class
implicit none
integer :: l,m,r,i,j,k,n1,n2
integer :: idx(*)
integer :: lidx(m-l+1),ridx(r-m)
type(face) :: array(*)
type(face) :: larr(m-l+1),rarr(r-m)
n1 = m-l+1
n2 = r-m
larr(:) = array(l:m)
rarr(:) = array(m+1:r)
lidx(:) = idx(l:m)
ridx(:) = idx(m+1:r)
i = 1
j = 1
k = l
do while (i .le. n1 .and. j .le. n2)
if (larr(i) .le. rarr(j)) then
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
else
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
end if
k = k + 1
end do
do while (i .le. n1)
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
k = k + 1
end do
do while (j .le. n2)
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
k = k + 1
end do
end subroutine mergea_face
end module mergesort_class
module face_class
implicit none
private
public :: face
! Type def for the stack data
type face
integer (kind=8) :: hi,lo
contains
procedure :: face_equal
procedure :: face_le
generic, public :: operator (.eq.) => face_equal
generic, public :: operator (.le.) => face_le
end type face
interface face
module procedure make_face
end interface face
contains
! overloaded .eq.
logical function face_equal(a,b)
implicit none
class(face), intent(in) :: a,b
face_equal = .false.
if (a%lo.eq.b%lo .and. a%hi.eq.b%hi) face_equal=.true.
end function face_equal
! overloaded .le.
logical function face_le(a,b)
implicit none
class(face), intent(in) :: a,b
face_le = .false.
if ( (a%lo.le.b%lo .and. a%hi.eq.b%hi)
& .or. (a%hi.lt.b%hi) ) face_le=.true.
end function face_le
! Constructor
type(face) function make_face(a,b,c,d)
use mergesort_class
implicit none
integer, intent(in) :: a,b,c
integer, optional, intent(in) :: d
integer :: m(4)
integer (kind=8) :: n(4)
n(1) = int8(a)
n(2) = int8(b)
n(3) = int8(c)
if (present(d)) then
n(4) = int8(d)
else
n(4)= int8(0)
end if
call mergesort(n,4,m)
call mvbits(n(4),0,32,make_face%lo,0)
call mvbits(n(3),0,32,make_face%lo,32)
call mvbits(n(2),0,32,make_face%hi,0)
call mvbits(n(1),0,32,make_face%hi,32)
end function make_face
end module face_class
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
sanjayg0 wrote:
@FortranFan
Thanks for the suggestion on using an abstract class with deferred procedures. I have seen that described in a few places and will study up on it. Notwithstanding, if you have a suggested place for me to look up how to do this effectively that will be great. Or if you can sketch something out for me and post it, that will also be great.
-sanjay
See this Dr Fortran blog: https://software.intel.com/en-us/blogs/2013/12/30/doctor-fortran-in-its-a-modern-fortran-world The book references can guide you in implementing your code.
Re: "if you can sketch something out for me and post it," note I'm assuming you have some mergesort procedure (c.f. Numerical Recipes by Press et al.) that works on arrays of primitive types such as integers which you want to extend for use with your own derived types such as 'face'. Given this premise, my suggestion will be to implement an abstract base type that includes the necessary comparison operators such as <= required by your sort procedure. Then your face type (and any other derived type whose arrays need to be sort based on the comparison criterion) can extend from this base type. Here's the example code which compiles ok with Intel Fortran compiler 17, update1:
module mykinds_m use, intrinsic :: iso_fortran_env, only : I4 => int32, I8 => int64 implicit none private public :: I4, I8 end module mykinds_m
module base_comparer_m
use mykinds_m, only : I4, I8
implicit none
private
type, abstract, public :: base_comparer_t
contains
private
procedure(IIsLessThanOrEqualTo), pass(this), deferred :: IsLessThanOrEqualTo
generic, public :: operator(<=) => IsLessThanOrEqualTo
end type base_comparer_t
abstract interface
elemental function IIsLessThanOrEqualTo( this, rhs ) result( val )
import :: base_comparer_t
!.. Argument list
class(base_comparer_t), intent(in) :: this
class(base_comparer_t), intent(in) :: rhs
!.. Function result
logical :: val
end function IIsLessThanOrEqualTo
end interface
end module base_comparer_m
module mergesort_m
use mykinds_m, only : I4, I8
use base_comparer_m, only : base_comparer_t
implicit none
private
public :: mergesort
interface mergesort
module procedure mergesort_I8, mergesort_base_comparer_t
end interface
contains
pure subroutine mergesort_I8(array,n,idx)
!.. Argument list
integer(kind=I8), intent(inout) :: array(:)
integer(kind=I4), intent(in) :: n
integer(kind=I8), intent(in) :: idx(:)
! place relevant code in an include file, same for all types
!include 'mergesort.f90'
end subroutine mergesort_I8
pure subroutine merge_I8(array,l,m,r,idx)
!.. Argument list
integer(kind=I8), intent(inout) :: array(:)
integer(kind=I4), intent(in) :: l
integer(kind=I4), intent(in) :: m
integer(kind=I4), intent(in) :: r
integer(kind=I8), intent(in) :: idx(:)
! place relevant code in an include file, same for all types
!include 'merge.f90'
end subroutine merge_I8
pure subroutine mergesort_base_comparer_t(array,n,idx)
!.. Argument list
class(base_comparer_t), intent(inout) :: array(:)
integer(kind=I4), intent(in) :: n
integer(kind=I8), intent(in) :: idx(:)
! place relevant code in an include file
!include 'mergesort.f90'
end subroutine mergesort_base_comparer_t
pure subroutine merge_base_comparer_t(array,l,m,r,idx)
!.. Argument list
class(base_comparer_t), intent(inout) :: array(:)
integer(kind=I4), intent(in) :: l
integer(kind=I4), intent(in) :: m
integer(kind=I4), intent(in) :: r
integer(kind=I8), intent(in) :: idx(:)
! place relevant code in an include file, same for all types
!include 'merge.f90'
end subroutine merge_base_comparer_t
end module mergesort_m
module face_m
use mykinds_m, only : I4, I8
use base_comparer_m, only : base_comparer_t
use mergesort_m, only : mergesort
implicit none
private
public :: face_t
! Type definition for face_t
type, extends(base_comparer_t) :: face_t
integer(kind=I8) :: hi,lo
contains
private
procedure :: IsEqual_Face_t
procedure :: IsLessThanOrEqualTo => IsLessThanOrEqualTo_Face_t
generic, public :: operator(==) => IsEqual_Face_t
end type face_t
interface face_t
module procedure make_face_t
end interface face_t
contains
! Constructor
function make_face_t(a,b,c,d) result( new_face )
!.. Argument list
integer, intent(in) :: a
integer, intent(in) :: b
integer, intent(in) :: c
integer, optional, intent(in) :: d
!.. Function result
type(face_t) :: new_face
!.. Local variables
integer(kind=I8) :: n(4)
integer(kind=I8) :: m(4)
! relevant code to set up n( ) and m( )
call mergesort(n, size(n), m)
end function make_face_t
! overloaded == operator
elemental function IsEqual_Face_t(a, b) result( val )
!.. Argument list
class(face_t), intent(in) :: a
class(face_t), intent(in) :: b
!.. Function result
logical :: val
val = .false.
! relevant code
return
end function IsEqual_Face_t
! overloaded <= operator
elemental function IsLessThanOrEqualTo_Face_t(this, rhs) result( val )
!.. Argument list
class(face_t), intent(in) :: this
class(base_comparer_t), intent(in) :: rhs
!.. Function result
logical :: val
val = .false.
select type ( rhs )
type is ( face_t )
! relevant code
end select
return
end function IsLessThanOrEqualTo_Face_t
end module face_m
In the above code, a few slyle-related aspects can be elided from the references alluded to in the Dr Fortram blog.
Hope this helps,
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
@FortranFan
Thanks this has gotten me a lot closer to getting things to work. Where I am stuck is in programming the merge
pure subroutine merge_base_comparer_t(array,l,m,r,idx)
!.. Argument list
class(base_comparer_t), intent(inout) :: array(:)
In the code which follows in my merge, I need two work arrays of larr(m-l+1) and rarr(r-m) which match the type of array(:), so that I can execute statements like larr(:)=array(l:m) and array(k) = larr(i) etc. I am struggling to create larr( ) and rarr( ) of the correct length with the correct type. The compiler clearly does not want them to be polymorphic.
error #8304: In an intrinsic assignment statement, variable shall not be polymorphic.
Also, I am now thinking that I may have to also provide a definition for assignment ( = )?
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
sanjayg0 wrote:
.. I am struggling to create larr( ) and rarr( ) of the correct length with the correct type. The compiler clearly does not want them to be polymorphic.
error #8304: In an intrinsic assignment statement, variable shall not be polymorphic.
Also, I am now thinking that I may have to also provide a definition for assignment ( = )?
Yes, looking at your 'complete' code now in Message #9 and since polymorphic intrinsic assignment is not yet supported by Intel Fortran, you can work around by including a defined assignment for your types. Also, looking at your code, you can consider making larr and rarr to be allocatable arrays instead of automatic. I think this will be required to handle the polymorphic types. But also the use of allocatable 'work' arrays may be better if the sizes of the arrays to be sorted become large relative to your compute environment.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Thank you for the complete routines. Even with those I cannot induce the internal error. Compilation fails with the earlier mentioned error #7002 because of the circular module dependency. We can keep poking at to see if we can induce it. Thanks again.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Kevin, FortranFan, and Jim,
Thanks for all the help. I now have a working abstract class to get around the circular dependency issue. Attached and Below (not sure which is easier for people) are the complete routines with a crude testing program. They need a bit of cleaning up (need to employ FortranFan's include idea and delete some unused variables) but I thought they may be useful for others as is. To build issue 'ifort face_abs_class.f mergesort_class.f face_class.f face_merge_test.f'.
The only really annoying issue I have not been able to figure out yet is how to allocate and initialize my work arrays in the merging for my derived type; see the subroutine mergea_face( ) (lines 122-131) where I find that allocate with the source= tag does not properly initialize my derived type variables (even though it works fine for intrinsic types, see lines 049-051 which work fine for integer*8 variables). To work around it, I just loop the array and manual initialize it -- kind of annoying but it works, and it is after all my first try at abstract classes. Perhaps someone knows what the issue is? Perhaps it is related to how I implemented the overloaded assignment (=) operator, which looks decidedly scalar to me (though I do know it works just fine when the type is not polymorphic, see the program face_merge_test line 56)?
-sanjay
program face_merge_test
use face_class
use mergesort_class
implicit none
logical :: testcheck
integer :: i,j
integer :: idx(10)
integer (kind=8) :: na,nb,nc,nd
integer (kind=8) :: listint(10)
type(face) :: faces(10)
! Test on intrinsic type int64
do i = 1,5
na = i
nb = 5-i+20
listint(i) = int8(na)
call mvbits(nb,0,32,listint(i),32)
end do
listint(6:10)=listint(1:5)
! Write starting data
write(*,*) 'Initial data int64'
do i = 1,10
idx(i) = i
write(*,'(i3,2x,i20)') idx(i),listint(i)
end do
! Sort
call mergesort(listint,10,idx)
! Write final data
write(*,*) 'Sorted data int64'
do i = 1,10
write(*,'(i3,2x,i20)') idx(i),listint(i)
end do
! Test ordering
testcheck = .true.
do i = 1,9
if ( .not.(listint(i).le.listint(i+1)) ) testcheck = .false.
end do
write(*,*) 'The Ordering for INT64 Checks',testcheck
! Test on defined type face
do i = 1,5
faces(i) = face(i,i+5,6-i,20-2*i)
end do
faces(6:10) = faces(1:5)
! Write starting data
write(*,*) 'Initial data face'
do i = 1,10
idx(i) = i
write(*,'(i3,3x)',advance='no') idx(i)
call faces(i)%face_write()
end do
! Sort
call mergesort(faces,10,idx)
! Write final data
write(*,*) 'Sorted data face'
do i = 1,10
write(*,'(i3,3x)',advance='no') idx(i)
call faces(i)%face_write()
end do
! Test ordering
testcheck = .true.
do i = 1,9
if ( .not.(faces(i).le.faces(i+1)) ) testcheck = .false.
end do
write(*,*) 'The Ordering for FACE Checks',testcheck
end program face_merge_test
module face_abs_class
implicit none
private
public :: face_abs
type, abstract :: face_abs
contains
private
procedure (face_write_abs), deferred :: face_write
procedure (face_equal_abs), deferred :: face_equal
procedure (face_le_abs), deferred :: face_le
procedure (face_assign_abs), deferred :: face_assign
generic, public :: operator(.eq.) => face_equal
generic, public :: operator(.le.) => face_le
generic, public :: assignment(=) => face_assign
end type face_abs
abstract interface
logical function face_equal_abs(a,b)
import :: face_abs
class(face_abs), intent(in) :: a,b
end function face_equal_abs
logical function face_le_abs(a,b)
import :: face_abs
class(face_abs), intent(in) :: a,b
end function face_le_abs
subroutine face_assign_abs(a,b)
import :: face_abs
class(face_abs), intent(in) :: b
class(face_abs), intent(out) :: a
end subroutine face_assign_abs
subroutine face_write_abs(a)
import :: face_abs
class(face_abs), intent(in) :: a
end subroutine face_write_abs
end interface
end module face_abs_class
module face_class
use face_abs_class
implicit none
private
public :: face
! Type def for the stack data
type, extends(face_abs) :: face
private
integer (kind=8) :: hi,lo
contains
private
procedure :: face_equal
procedure :: face_le
procedure :: face_assign
procedure, public :: face_write
end type face
interface face
module procedure make_face
end interface face
contains
! overloaded .eq.
logical function face_equal(a,b)
implicit none
class(face), intent(in) :: a
class(face_abs), intent(in) :: b
face_equal = .false.
select type (b)
type is (face)
if (a%lo.eq.b%lo .and. a%hi.eq.b%hi)
& face_equal=.true.
end select
end function face_equal
! overloaded .le.
logical function face_le(a,b)
implicit none
class(face), intent(in) :: a
class(face_abs), intent(in) :: b
face_le = .false.
select type (b)
type is (face)
if ( (a%lo.le.b%lo .and. a%hi.eq.b%hi)
& .or. (a%hi.lt.b%hi) ) face_le=.true.
end select
end function face_le
! overloaded =
subroutine face_assign(a,b)
implicit none
class(face), intent(out) :: a
class(face_abs), intent(in) :: b
select type (b)
type is (face)
a%lo = b%lo
a%hi = b%hi
end select
end subroutine face_assign
! output
subroutine face_write(a)
implicit none
class(face), intent(in) :: a
write(*,*) a%hi,a%lo
end subroutine face_write
! Constructor
type(face) function make_face(a,b,c,d)
use mergesort_class
implicit none
integer, intent(in) :: a,b,c
integer, optional, intent(in) :: d
integer :: m(4)
integer (kind=8) :: n(4)
n(1) = int8(a)
n(2) = int8(b)
n(3) = int8(c)
if (present(d)) then
n(4) = int8(d)
else
n(4)= int8(0)
end if
call mergesort(n,4,m)
call mvbits(n(4),0,32,make_face%lo,0)
call mvbits(n(3),0,32,make_face%lo,32)
call mvbits(n(2),0,32,make_face%hi,0)
call mvbits(n(1),0,32,make_face%hi,32)
end function make_face
end module face_class
module mergesort_class
use face_abs_class, only : face_abs
implicit none
private
public :: mergesort
interface mergesort
module procedure ms_int64, ms_face
end interface
contains
subroutine ms_int64(array,n,idx)
implicit none
integer :: n,currsize,l,r,mid
integer :: idx(*)
integer (kind=8) :: array(*)
currsize = 1
do while (currsize .le. n)
l = 1
do while (l .le. n)
mid = min(l + currsize - 1,n)
r = min(l+2*currsize-1,n)
! Merge
call mergea_int64(array,l,mid,r,idx)
l = l + 2*currsize
end do
currsize = 2*currsize
end do
end subroutine ms_int64
subroutine mergea_int64(array,l,m,r,idx)
implicit none
integer :: l,m,r,i,j,k,n1,n2
integer :: idx(*)
integer :: lidx(m-l+1),ridx(r-m)
integer (kind=8) :: array(*)
integer (kind=8), dimension(:), allocatable :: larr, rarr
n1 = m-l+1
n2 = r-m
! Allocate and Fill Work Arrays
allocate(larr(1:n1),source=array(l:m))
allocate(rarr(1:n2),source=array(m+1:r))
lidx(:) = idx(l:m)
ridx(:) = idx(m+1:r)
i = 1
j = 1
k = l
do while (i .le. n1 .and. j .le. n2)
if (larr(i) .le. rarr(j)) then
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
else
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
end if
k = k + 1
end do
do while (i .le. n1)
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
k = k + 1
end do
do while (j .le. n2)
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
k = k + 1
end do
end subroutine mergea_int64
subroutine ms_face(array,n,idx)
implicit none
integer :: i
integer :: n,currsize,l,r,mid
integer :: idx(*)
class(face_abs) :: array(*)
currsize = 1
do while (currsize .le. n)
l = 1
do while (l .le. n)
mid = min(l + currsize - 1,n)
r = min(l+2*currsize-1,n)
! Merge
call mergea_face(array,l,mid,r,idx)
l = l + 2*currsize
end do
currsize = 2*currsize
end do
end subroutine ms_face
subroutine mergea_face(array,l,m,r,idx)
implicit none
integer :: l,m,r,i,j,k,n1,n2
integer :: idx(*)
integer :: lidx(m-l+1),ridx(r-m)
class(face_abs) :: array(*)
class(face_abs), dimension(:), allocatable :: larr, rarr
n1 = m-l+1
n2 = r-m
! Allocate and Fill Work Arrays
allocate(larr(1:n1),source=array(l:m))
allocate(rarr(1:n2),source=array(m+1:r))
! Manually Fill Work Arrays to correct 'source' problem
do i = 1,n1
larr(i) = array(l+i-1)
end do
do i = 1,n2
rarr(i) = array(m+i)
end do
lidx(:) = idx(l:m)
ridx(:) = idx(m+1:r)
i = 1
j = 1
k = l
do while (i .le. n1 .and. j .le. n2)
if (larr(i) .le. rarr(j)) then
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
else
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
end if
k = k + 1
end do
do while (i .le. n1)
array(k) = larr(i)
idx(k) = lidx(i)
i = i + 1
k = k + 1
end do
do while (j .le. n2)
array(k) = rarr(j)
idx(k) = ridx(j)
j = j + 1
k = k + 1
end do
end subroutine mergea_face
end module mergesort_class
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report Inappropriate Content
Your program is, potentially, doing lots of unnecessary merges.
See https://rosettacode.org/wiki/Sorting_algorithms/Merge_sort#Fortran . The code given there is simple, yet efficient, although it only sorts integers. It is further recommended that you implement a switch-over to insertion sort when the recursion has reached such a depth that the array section being sorted is less than about 20, instead of using mergesort all the way.
- Subscribe to RSS Feed
- Mark Topic as New
- Mark Topic as Read
- Float this Topic for Current User
- Bookmark
- Subscribe
- Printer Friendly Page