!-------------------------------------------------------------------------------
module test

private

	type, public :: Identity
		integer :: self = 0
	contains
		procedure :: Assign__ => IDAssign
		procedure :: Close    => IDClose
		final :: IDFinal
	end type

 	public :: GenericAssignment__
 	interface assignment(=)
 		module procedure GenericAssignment__
 	end interface

	type, public, extends(Identity) :: Group
		!
	contains
		procedure :: NewGroup
	end type

contains
!-------------------------------------------------------------------------------

subroutine IDAssign(lhs,rhs)
implicit none
	class(Identity), intent(inout) :: lhs
	class(Identity), intent(in)    :: rhs
	print "('Assigning ',i0,' to ',i0)",rhs%self,lhs%self
	call lhs%Close()
	if (rhs%self /= 0) then
		lhs%self = rhs%self
		! ... increment reference count
	endif
end subroutine

subroutine IDClose(my)
implicit none
	class(Identity) :: my
	print "('Closing ',i0)",my%self
	if (my%self /= 0) then
		! ... decrement reference count
		my%self = 0
	endif
end subroutine

subroutine IDFinal(my)
implicit none
	type(Identity) :: my
	call my%Close()
end subroutine

subroutine GenericAssignment__(lhs,rhs)
implicit none
	class(Identity), intent(inout) :: lhs
	class(Identity), intent(in)    :: rhs
	call lhs%Assign__(rhs)
end subroutine

!-------------------------------------------------------------------------------

function NewGroup(my,id) result(grp)
implicit none
	class(Group) :: my
	integer, intent(in) :: id
	type(Group) :: grp

	! ... allocate group
	! ... set reference count to 1
	
	grp%self = id

end function

end module

!-------------------------------------------------------------------------------
program main

call run()

contains

subroutine run()
use test
implicit none

	type(Group) :: grp1, grp2
	integer :: idx

	grp1%self = 42

	do idx = 1, 5
		! Generic Assignment is not used here !
		grp2 = grp1%NewGroup(idx)
	enddo

end subroutine

end program
