[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
[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
[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