Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.

use module within another module

sanjayg0
Novice
1,482 Views

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

 

 

0 Kudos
14 Replies
FortranFan
Honored Contributor II
1,482 Views

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.

0 Kudos
Kevin_D_Intel
Employee
1,482 Views

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?

0 Kudos
sanjayg0
Novice
1,482 Views

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.

0 Kudos
sanjayg0
Novice
1,482 Views

@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
 

0 Kudos
Kevin_D_Intel
Employee
1,482 Views

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.

0 Kudos
jimdempseyatthecove
Honored Contributor III
1,482 Views

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

0 Kudos
sanjayg0
Novice
1,482 Views

@Jim

Good catch. Thanks, though that is independent of the main issue affecting me.

0 Kudos
sanjayg0
Novice
1,482 Views

@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

 

0 Kudos
FortranFan
Honored Contributor II
1,482 Views

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,

0 Kudos
sanjayg0
Novice
1,482 Views

@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 ( = )?

0 Kudos
FortranFan
Honored Contributor II
1,482 Views

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.

0 Kudos
Kevin_D_Intel
Employee
1,482 Views

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. 

0 Kudos
sanjayg0
Novice
1,482 Views

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

 

0 Kudos
mecej4
Honored Contributor III
1,482 Views

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.

0 Kudos
Reply