- 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