通用排序模块

weixing1531

以下代码基于作者Arjen Markus2012年所著书《Modern Fortran in Practice》
书中源代码下载地址：http://flibs.sourceforge.net/examples_modern_fortran.html

本人简化了代码，将排序方法由选择排序法修改为快速排序法、堆排序法，增加了交换数据子程序。

首先，定义了在模块sortable_types中定义抽象类型sortable
该抽象类有3个抽象方法：
(1)islower 用于比较大小  小于号重载
(2)assign_data 用于赋值   赋值号重载
(3)print 用于打印
模块中只包含3个抽象方法的抽象接口，没有具体实现代码（由子类实现）
模块还定义了4个模块方法：
(1)sort_quick 用快速排序法对数组排序
(2)sort_heap 用堆排序法对数组排序
(3)print_array 打印数组各元素
(4)swap 交换数据子程序  重载后形参可以为整数或派生类型

源代码如下：

[Fortran] 纯文本查看 复制代码

module sortable_types
    implicit none
    private
    public::sortable !父类名称公有
    public::sort_quick,sort_heap,print_array !模块方法公有

    type, abstract :: sortable !抽象类
        ! No particular data
    contains !成员方法默认为公有
        procedure(islower), deferred :: islower !延迟绑定 小于函数
        procedure(assignx), deferred :: assign_data !延迟绑定 赋值子程序
        procedure(print_item), deferred :: print !延迟绑定
        generic :: operator(<)       => islower !重载小于号
        generic :: assignment(=)     => assign_data !重载赋值号
    end type

    abstract interface !抽象接口
        logical function islower( this, item )
            import sortable
            class(sortable), intent(in) :: this, item
        end function islower
        subroutine assignx( this, item )
            import sortable
            class(sortable), intent(inout) :: this !实例变量
            class(sortable), intent(in)    :: item
        end subroutine assignx
        subroutine print_item( this )
            import sortable
            class(sortable), intent(in) :: this !实例变量
        end subroutine print_item
    end interface

    interface swap !数据交换子程序通用接口 私有
        procedure :: swap_int !交换整数
        procedure :: swap_type !交换派生类型
    end interface
contains
subroutine swap_int(a,b) !交换整数
    integer,intent(inout)::a,b
    integer::temp

    temp=b
    b=a
    a=temp
end subroutine swap_int

subroutine swap_type(a,b) !交换派生类型
    class(sortable),intent(inout)::a,b
    class(sortable), allocatable :: temp !临时变量

    allocate( temp, source = b ) !临时变量赋值 sourced allocation
    b=a !赋值号已重载
    a=temp !赋值号已重载
    deallocate(temp)
end subroutine swap_type
!快速排序法 默认升序
subroutine sort_quick( arr, id ) !模块方法
    class(sortable), dimension(:), intent(inout) :: arr
    integer, dimension(:), intent(out), allocatable, optional :: id !排序前对应的索引值
    !最小值对应排序前下标为id(1) 最大值对应排序前下标为id(size(id))
    integer, parameter :: NN=15, NSTACK=50
    class(sortable), allocatable :: a !临时变量
    integer :: i,j,k,jstack,l,r
    integer, dimension(NSTACK) :: istack
    integer,pointer :: b => null() !临时变量

    allocate( a, source = arr(1) ) !sourced allocation

    if ( present(id) ) then
      allocate(b) !分配内存
      b=0 !初值
      id = [(i, i=1, size(arr))] !初值即排序前下标
    end if

    jstack=0
    l=1
    r=size(arr)

    do
      if (r-l < NN) then
        do j=l+1,r
          a=arr(j)
          if ( present(id) ) b=id(j) !新增
          do i=j-1,l,-1
            if (arr(i) < a) exit
            arr(i+1)=arr(i)
            if ( present(id) ) id(i+1)=id(i) !新增
          end do
          arr(i+1)=a
          if ( present(id) ) id(i+1)=b !新增
        end do
        if (jstack == 0) return
        r=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+r)/2
        call swap(arr(k),arr(l+1))
        if ( present(id) ) call swap(id(k),id(l+1)) !交换元素索引值

        if(arr(r)<arr(l))then !小于号已重载
          call swap(arr(l),arr(r))
          if ( present(id) ) call swap(id(l),id(r)) !交换元素索引值
        end if

        if(arr(r)<arr(l+1))then !小于号已重载
          call swap(arr(l+1),arr(r))
          if ( present(id) ) call swap(id(l+1),id(r)) !交换元素索引值
        end if

        if(arr(l+1)<arr(l))then !小于号已重载
          call swap(arr(l),arr(l+1))
          if ( present(id) ) call swap(id(l),id(l+1)) !交换元素索引值
        end if
        i=l+1
        j=r
        a=arr(l+1)
        if ( present(id) ) b=id(l+1) !新增
        do
          do
            i=i+1
            if (a < arr(i)) exit !小于号已重载
          end do
          do
            j=j-1
            if (arr(j) < a) exit !小于号已重载
          end do
          if (j < i) exit
          call swap(arr(i),arr(j))
          if ( present(id) ) call swap(id(i),id(j)) !交换元素索引值
        end do
        arr(l+1)=arr(j)
        if ( present(id) ) id(l+1)=id(j) !新增
        arr(j)=a
        if ( present(id) ) id(j)=b !新增
        jstack=jstack+2
        if (jstack > NSTACK) then
          write(*,*)'sort: NSTACK too small'
          stop
        end if
        if (r-i+1 >= j-l) then
          istack(jstack)=r
          istack(jstack-1)=i
          r=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        end if
      end if
    end do

    if ( present(id) ) deallocate(b) !释放内存
    deallocate(a) !释放内存
end subroutine sort_quick
!堆排序法 默认升序
subroutine sort_heap(arr,id)
    class(sortable), dimension(:), intent(inout) :: arr
    integer, dimension(:), intent(out), allocatable, optional :: id !排序前对应的索引值
    !最小值对应排序前下标为id(1) 最大值对应排序前下标为id(size(id))
    integer :: i,n

    if ( present(id) ) then
      id = [(i, i=1, size(arr))] !初值即排序前下标
    end if
    !以下为堆排序法
    n=size(arr)

    do i=n/2,1,-1
      call sift_down(i,n)
    end do

    do i=n,2,-1
      call swap(arr(1),arr(i))
      if ( present(id) ) call swap(id(1),id(i)) !交换元素索引值
      call sift_down(1,i-1)
    end do
contains
!内部子程序
subroutine sift_down(l,r)
    integer, intent(in) :: l,r
    integer :: j,jold
    class(sortable), allocatable :: a !临时变量
    integer,pointer :: b => null() !临时变量

    if ( present(id) ) then
      allocate(b) !分配内存
      b=0 !初值
    end if

    allocate( a, source = arr(l) ) !修改 sourced allocation
    if ( present(id) ) b=id(l) !新增
    jold=l
    j=l+l
    do
      if (j > r) exit
      if (j < r) then
        if (arr(j) < arr(j+1)) then !小于号已重载
          j=j+1
        end if
      end if
      if (arr(j) < a) exit !修改 小于号已重载
      arr(jold)=arr(j)
      if ( present(id) ) id(jold)=id(j) !新增
      jold=j
      j=j+j
    end do
    arr(jold)=a
    if ( present(id) ) then
        id(jold)=b !新增
        deallocate(b) !释放内存
    end if
    deallocate(a) !释放内存
end subroutine sift_down
end subroutine sort_heap

subroutine print_array( array ) !模块方法
    class(sortable), dimension(:) :: array
    integer :: i

    do i = 1,size(array)
        call array(i)%print() !打印每个元素
    enddo
end subroutine print_array
end module sortable_types

weixing1531

然后，在模块addresses中定义了子类address_type
根据具体情况编写了成员变量，并对父类的3个抽象方法进行了重写
同时还编写了子类的构造函数

源代码如下：

[Fortran] 纯文本查看 复制代码

module addresses
    use sortable_types
    implicit none
    private
    public::address_type !子类名称和构造函数公有
    public::sort_quick,sort_heap,print_array !继承父类模块方法
    !继承关系：父类sortable_types=>子类address_type
    !对应模块方法：sort+print_array      无
    type, extends(sortable) :: address_type
        private
        character(len=:), allocatable :: name
        character(len=:), allocatable :: city
    contains !成员方法默认为公有
        procedure :: assign_data => assign_address
        procedure :: islower     => islower_address
        procedure :: print       => print_address
    end type address_type

    interface address_type !构造函数 通用名称与子类名相同
        procedure :: address_type_constructor
    end interface
contains
!构造函数
type(address_type) function address_type_constructor(s1,s2)
    character(len=*),intent(in) :: s1,s2

    address_type_constructor%name = s1
    address_type_constructor%city = s2
end function

subroutine assign_address( this, item ) !父类抽象接口具体实现
    class(address_type), intent(inout) :: this !子类实例变量
    class(sortable), intent(in)        :: item !父类变量
    ! 父类访问子类的变量或方法必须用select type
    select type (item)
        type is (address_type) !子类操作
            this%name = item%name
            this%city = item%city
    end select
end subroutine assign_address

logical function islower_address( this, item ) !父类抽象接口具体实现
    class(address_type), intent(in) :: this !子类实例变量
    class(sortable),     intent(in) :: item !父类变量
    ! 父类访问子类的变量或方法必须用select type
    select type (item)
        type is (address_type) !子类操作
            if ( this%name /= item%name ) then
                islower_address = llt(this%name , item%name) !函数llt不依赖系统字符集
            else !名字相同则比较城市
                islower_address = llt(this%city , item%city) !符号<依赖系统字符集
            endif
    end select
end function islower_address

subroutine print_address( this ) !父类抽象接口具体实现
    class(address_type), intent(in) :: this !实例变量

    write(*,'(a,t15,a)') this%name, this%city
end subroutine print_address
end module addresses

weixing1531

最后为主程序

源代码如下：

[Fortran] 纯文本查看 复制代码

program test_addresses
    use addresses
    implicit none

    type(address_type), dimension(6) :: address,temp
    integer, dimension(:), allocatable :: id !排序前数组对应下标

    address = [ address_type( "John", "London" ),   &
                address_type( "Jan", "Amsterdam" ), &
                address_type( "Jan", "Warsaw" ),    &
                address_type( "Jean", "Paris" ),    &
                address_type( "Giovanni", "Rome" ), &
                address_type( "Juan", "Madrid" )    ]
    call sort_quick( address, id ) !快速排序法
    call print_array( address ) !升序
    write(*,*)id !排序前对应的索引值
    temp=address(size(address):1:-1) !降序
    call print_array( temp )
    write(*,*)
    call sort_heap( temp, id ) !堆排序法
    call print_array( temp ) !升序
    write(*,*)id !排序前对应的索引值
    call temp(1)%print()
end program test_addresses