module testmode
  implicit none

  type :: simple
    integer :: ind
    character(12) :: myname
  contains
    final :: destructor1, destructor2
  end type simple

  type, extends(simple) :: complicated
    real :: rind
  contains
    final :: destructor3, destructor4
  end type complicated

  integer :: check_scalar
  integer :: check_array(4)
  real :: check_real
  real :: check_rarray(4)
  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    check_scalar = self%ind
    check_array = 0
    final_count = final_count + 1
    print '(3A, i4)', " finalize simple - ", trim (self%myname), "%ind = ", self%ind
  end subroutine destructor1

  subroutine destructor2(self)
    type(simple), intent(inout) :: self(:)
    check_scalar = 0
    check_array(1:size(self, 1)) = self%ind
    final_count = final_count + 1
    print '(3A, 3i4)', " finalize simple(:) - ", trim (self(1)%myname),"%ind= ", self%ind
  end subroutine destructor2

  subroutine destructor3(self)
    type(complicated), intent(inout) :: self
    check_real = self%rind
    check_array = 0.0
    final_count = final_count + 1
    print '(3A, i4, f6.2)', " finalize complicated - ", trim (self%myname)," = ",&
                            self%ind, self%rind
  end subroutine destructor3

  subroutine destructor4(self)
    type(complicated), intent(inout) :: self(:)
    check_real = 0.0
    check_rarray(1:size(self, 1)) = self%rind
    final_count = final_count + 1
    if (size(self, 1) == 2) then
      print '(3A, 2i4, 2f6.2)', " finalize complicated(2) - ", trim (self(1)%myname),&
                                " = ", self%ind, self%rind
    else if (size(self, 1) == 3) then
      print '(3A, 3i4, 3f6.2)', " finalize complicated(3) - ", trim (self(1)%myname),&
                                " = ", self%ind, self%rind
    else
      print *, " finalize complicated(:) - ", trim (self(1)%myname)," = ", self%ind, self%rind
    endif
  end subroutine destructor4

  function constructor1(ind ,myname) result(res)
    type(simple), allocatable :: res
    integer, intent(in) :: ind
    character(*) :: myname
    allocate (res, source = simple (ind, myname))
  end function constructor1

  function constructor2(ind, myname, rind) result(res)
    class(simple), allocatable :: res(:)
    integer, intent(in) :: ind(:)
    real, intent(in), optional :: rind(:)
    type(complicated), allocatable :: src(:)
    character(*) :: myname
    integer :: sz
    integer :: i
    if (present (rind)) then
      sz = min (size (ind, 1), size (rind, 1))
      src  = [(complicated (ind(i), myname, rind(i)), i = 1, sz)]
      allocate (res, source = src)
    else
      sz = size (ind, 1)
      allocate (res, source = [(simple (ind(i), myname), i = 1, sz)])
    end if
  end function constructor2

  subroutine test (cnt, scalar, array, off, rind, rarray)
    integer :: cnt
    integer :: scalar
    integer :: array(:)
    integer :: off
    real, optional :: rind
    real, optional :: rarray(:)
    if (final_count .ne. cnt)  print *, 1 + off, final_count, cnt
    if (check_scalar .ne. scalar) print *, 2 + off, check_scalar, scalar
    if (any (check_array(1:size (array, 1)) .ne. array)) print *,  3 + off, &
                                       check_array(1:size (array, 1)), "|", array
    if (present (rind)) then
      if (check_real .ne. rind)  print *,  4+off, check_real, rind
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) print *,  5 + off, &
                                       check_rarray(1:size (rarray, 1)), "|", rarray
    end if
  end subroutine test

end module testmode

program test_final
   use testmode
   implicit none
   type(simple), parameter   :: ThyType   = simple(21, "ThyType")
   type(simple)              :: ThyType2  = simple(22, "ThyType2")
   type(simple), allocatable :: MyType, MyType2
   type(simple), allocatable :: MyTypeArray(:)
   type(complicated), allocatable :: ThyTypeArray(:)

   print '(a,i4)', " At start of program: final_count = ", final_count

!*******************************************************************
! Patch now corrected not to finalize when 'var' is not allocated.
! Mytype not allocated and so no finalization => final_count = 0
!*******************************************************************
   print *, "*******************************************************************"
   print *, ""
   print *, "1st assignment: No finalization because MyType unallocated."
   MyType = ThyType
   print '(a,i4,a)', " After 1st assignment(var not allocated): final_count = ", final_count, "(0)"
   print *, "*******************************************************************"
   print *, ""
!*******************************************************************
! Mytype2 is allocated and so finalization should occur => final_count = 1
!*******************************************************************
   print *, "2nd assignment: MyType(=simple(1,MyType) finalized before assignment"
   final_count = 0
   allocate (Mytype2, source = simple (1, "Mytype2"))
   MyType2 = ThyType2
   print '(a,i4,a)', " After 2nd assignment(var allocated): final_count = ", final_count, "(1)"
   print *, "*******************************************************************"
   print *, ""

!*******************************************************************
! This should result in a final call with self = [simple(42),simple(43)].
! NAG outputs self = [simple(21),simple(22)] and a double increment of
! the final count, which PRT does not understand.
! In PRT's opinion => final_count = 1
!*******************************************************************
   print *, "3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment"
   print *, ""
   final_count = 0
   allocate(MyTypeArray, source = [simple (42, "MyTypeArray"), simple(43, "MyTypeArray")])
   MyTypeArray = [ThyType, ThyType2]
   print '(a,i4,a)', " After 3rd assignment(array var allocated): final_count = ", final_count, "(1)"
   print *, "*******************************************************************"
   print *, ""

!*******************************************************************
! Check that rhs function expressions finalize correctly.
! 'var' is finalized on deallocation and then again on assignment. The
! function result of 'constructor1' is finalized after the assignment.
! (Note NAG only generates two final calls and check_scalar = 11.)
! In PRT's opinion => final_count = 3
!*******************************************************************
   print *, "Deallocation generates final call with self = simple (21, ThyType)"
   print *, "4th assignment: MyTypeArray finalized before assignment"
   print *, "Mtype finalized before assignment with self = simple (11, MyType)"
   print *, "Function result finalized after assignment with self = simple (99, MyType)"
   print *, ""
   final_count = 0
   deallocate (MyType)
   allocate (MyType, source = simple (11, "MyType"))
   MyType = constructor1 (99, "MyType")
   print '(a,i4,a)', " After 4th assignment(array var allocated) :final_count = ", final_count, "(3)"
   print *, "*******************************************************************"
   print *, ""

!*******************************************************************
! Check that rhs array function expressions finalize correctly.
! 'var' is on assignment. The function result of 'constructor3' is
! finalized after the assignment. Both finalizations result in a
! finalization of the extended type and then the parent. In addition,
! the assignment in constructor3 causes a finalization of 'res'.
! Therefore => final_count = 6
! (Note ifort generates ten final calls because of the scalar final
! calls of the parent components, rather than array calls.)
!*******************************************************************
   print *, "5th assignment: MyTypeArray finalized before assignment"
   print *, "1] First finalization is of 'res' in constructor3 with:"
   print *, "Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]"
   print *, "2] ThyTypeArray is finalized before assignment and after evaluation of constructor3"
   print *, "Self = [3 times complicated (-1, ThyTypeArra1,0.0)]"
   print *, "3] Function result finalized after assignment with"
   print *, "Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]"
   print *, ""
   final_count = 0
   allocate (ThyTypeArray(3), source = complicated (-1,"ThyTypeArra1",0.0))
   ThyTypeArray = constructor3 ("ThyTypeArra2")
   print '(a,i4,a)', " After 5th assignment(array var allocated):", final_count, "(6)"
   print *, ""
   print *, "*******************************************************************"
   print *, "Deallocate ThyTypeArray."
   deallocate (ThyTypeArray)
   print *, ""
   print *, "*******************************************************************"

!*******************************************************************
! 6th Assignment has the allocatable version of the function. This should
! give the same result as the previous one.
!*******************************************************************
   print *, "6th assignment: A repeat of the previous with an allocatable function result."
   print *, "This should give the same result as the 5th assignment."
   print *, ""
   final_count = 0
   allocate (ThyTypeArray(3), source = complicated (-1,"ThyTypeArra1",0.0))
   ThyTypeArray = constructor4 ("ThyTypeArra2")
   print '(a,i4,a)', " After 6th assignment(array var allocated):", final_count, "(6)"
   print *, ""
   print *, "*******************************************************************"

!*******************************************************************
! Everybody agrees (PRT thinks) about deallocation, except where arrays
! of extended types are concerned (Intel)
!*******************************************************************
   final_count = 0
   print *, "Deallocations at end"
   print *, ""
   deallocate(Mytype)
   print *, "After 1st deallocation:", final_count
   deallocate(Mytype2)
   print *, "After 2nd deallocation:", final_count
   deallocate(MytypeArray)
   print *, "After 3rd deallocation:", final_count

contains
   function constructor3 (myname) result(res)
      type(complicated) :: res(2)
      character(12) :: myname
      print *, "constructor3: final_count = ", final_count
      res%myname = "constructor3"
      res = [complicated(1, myname, 2.0),complicated(3, myname, 4.0)]
   end function

   function constructor4 (myname) result(res)
      type(complicated), allocatable :: res(:)
      character(12) :: myname
      print *, "constructor4: final_count = ", final_count
      allocate (res(2), source = complicated (1, "constructor3", 1.0))
      res%myname = "constructor4"
      res = [complicated(1, myname, 2.0),complicated(3, myname, 4.0)]
   end function

end program test_final