Issue in the code with polymorphic derived types and OpenMP

vmironov · ‎09-28-2022

I've run into a double allocation issue when using polymorphic derived type.

The problem is observed on Linux in both IFX (2022.1.0 20220316) and IFORT (2021.6.0 20220226) compilers and only if compiled with OpenMP. The problem is not observed in GFortran.

OS: Centos 8 Stream 4.18.0-394.el8.x86_64

$ ifort -O0 -g testifort.f90  ; echo 1 | ./a.out
 enter i:
 2 branch
 allocated(d1)= F
 ubound(d1)=           0

$ ifort -O0 -g testifort.f90 -qopenmp ; echo 1 | ./a.out
 enter i:
 2 branch
 allocated(d1)= F
 ubound(d1)=           0
forrtl: severe (151): allocatable array is already allocated
Image              PC                Routine            Line        Source
a.out              000000000042F13F  Unknown               Unknown  Unknown
a.out              0000000000403828  Unknown               Unknown  Unknown
a.out              0000000000403A45  Unknown               Unknown  Unknown
a.out              0000000000403AB4  Unknown               Unknown  Unknown
a.out              0000000000404983  Unknown               Unknown  Unknown
a.out              00000000004030E2  Unknown               Unknown  Unknown
libc-2.28.so       000014A71DD69D85  __libc_start_main     Unknown  Unknown
a.out              0000000000402FEE  Unknown               Unknown  Unknown

$ ifx -O0 -g testifort.f90  ; echo 1 | ./a.out
 enter i:
 2 branch
 allocated(d1)= F
 ubound(d1)=           0

$ ifx -O0 -g testifort.f90 -qopenmp ; echo 1 | ./a.out
 enter i:
 2 branch
 allocated(d1)= F
 ubound(d1)=           1
forrtl: severe (151): allocatable array is already allocated
Image              PC                Routine            Line        Source
a.out              00000000004306DE  Unknown               Unknown  Unknown
a.out              0000000000404677  Unknown               Unknown  Unknown
a.out              0000000000404861  Unknown               Unknown  Unknown
a.out              00000000004048DB  Unknown               Unknown  Unknown
a.out              00000000004057B6  Unknown               Unknown  Unknown
a.out              0000000000404122  Unknown               Unknown  Unknown
libc-2.28.so       000014E23DD75D85  __libc_start_main     Unknown  Unknown
a.out              000000000040402E  Unknown               Unknown  Unknown

The problem does not appear if polymorphic object is explicitly allocated (uncomment lines 147 and 151). Also, the polymorphic types should be complex enough to reproduce the error. If the structure of child_t becomes simpler, the error may disappear for child_1/child_2 in IFX or IFORT, or become random.

module m

  implicit none
  integer, parameter :: dp = 8

!###############################################################################

  type, abstract :: base_t
  contains
    procedure(base_start), deferred, pass :: start
  end type

!###############################################################################

  type, abstract, extends(base_t) :: child_t
    real(kind=dp) :: s1 = 1.0d0
    real(kind=dp) :: s2 = 2.0d0
    real(kind=dp) :: s3 = 3.0d0
    real(kind=dp) :: s4 = 4.0d0
    integer :: n1 = 0
    integer :: n2 = 1
    integer :: n3 = 2
    integer :: n4 = 2
    integer :: nthreads = 1
    real(kind=dp), pointer :: f1(:) => null()
    real(kind=dp), allocatable :: f2(:,:)
    real(kind=dp), allocatable :: f3(:,:,:)
    real(kind=dp), allocatable :: d1(:)
    real(kind=dp), pointer :: d2(:,:) => null()
  contains
    procedure :: start => child_t_start
    procedure :: child_t_start
  end type

  type, extends(child_t) :: child_1_t
  contains
    procedure :: start => child_1_t_start
  end type

  type, extends(child_t) :: child_2_t
  contains
    procedure :: start => child_2_t_start
  end type

!###############################################################################

  abstract interface

    subroutine base_start(this, ldim, nthreads)
      import :: base_t
      implicit none
      class(base_t), target, intent(inout) :: this
      integer, intent(in) :: ldim
      integer, intent(in) :: nthreads
    end subroutine

  end interface

!###############################################################################

contains

  subroutine child_t_start(this, ldim, nthreads)
    implicit none
    class(child_t), target, intent(inout) :: this
    integer, intent(in) :: ldim
    integer, intent(in) :: nthreads
    integer :: nsh

    this%nthreads = nthreads

    nsh = ldim

    print *, 'allocated(d1)=', allocated(this%d1)
    print *, 'ubound(d1)=', ubound(this%d1)

    if (allocated(this%d1)) then
        deallocate(this%d1)
    end if

    allocate(this%d1(nsh*(nsh+1)/2), source=0.0d0)

  end subroutine

!###############################################################################

  subroutine child_1_t_start(this, ldim, nthreads)
    implicit none
    class(child_1_t), target, intent(inout) :: this
    integer, intent(in) :: ldim
    integer, intent(in) :: nthreads

    this%n2 = ldim
    this%n3 = 1

    call this%child_t_start(ldim, nthreads)

  end subroutine

!###############################################################################

  subroutine child_2_t_start(this, ldim, nthreads)
    implicit none
    class(child_2_t), target, intent(inout) :: this
    integer, intent(in) :: ldim
    integer, intent(in) :: nthreads

    this%n2 = ldim
    this%n3 = 2

    call this%child_t_start(ldim, nthreads)

  end subroutine


!###############################################################################

  subroutine test_sub(dat)

    class(base_t), intent(inout) :: dat
    integer :: nthreads
    integer :: ldim

    ldim = 10
    nthreads = 1

    call dat%start(ldim,nthreads)

  end subroutine
end module

program test
  use m
  implicit none
  class(child_t), allocatable :: dat
  real(kind=dp), allocatable, target :: two_d_array(:,:)
  integer :: i

  allocate(two_d_array(100,1), source=100.0d0)

  print *, 'enter i:'
  read(*,*) i

  select case (i)
  case (0)
      write(*,*) '1 branch'
!      allocate(child_1_t :: dat)
      dat = child_1_t(n1=5, n3=1, d2=two_d_array)
  case default
      write(*,*) '2 branch'
!      allocate(child_2_t :: dat)
      dat = child_2_t(n2=10, n3=2, d2=two_d_array)
  end select

  call test_sub(dat)

end program

Update:

I've checked it with more recent compilers, the problem is still observed.

$ ifort --version
ifort (IFORT) 2021.7.0 20220726
Copyright (C) 1985-2022 Intel Corporation. All rights reserved.

$ ifx --version
ifx (IFORT) 2022.2.0 20220730
Copyright (C) 1985-2022 Intel Corporation. All rights reserved.

Ron_Green · ‎09-28-2022

definitely a bug. thank you for sending this to us.

Devorah_H_Intel · ‎10-19-2022

This issue is fixed in the upcoming release of ifx 2023.0

ifx -O0 -g testifort.f90 -qopenmp ; echo 1 | ./a.out
 enter i:
 2 branch
 allocated(d1)= F
 ubound(d1)=           0
 $ ifx -v
ifx version 2023.0.0

JohnNichols · ‎10-20-2022

polymorphic == I saw this word this morning and was amazed it is not on the banned list. It sounds vaguely dangerous.

When is the 2023.0.0 dropped so I can mark the date on my calendar and not have anything else on the date. highly excited. I mean I cracked another diet Dr Pepper.

Ron_Green · ‎10-20-2022

I try not to commit to any dates. These oneAPI kits have so many products in them. And any 1 can cause a delay. So add in 12 or so components and .... well we know statistics.

BUT I can say this - for oneAPI 2021 and 2022 the initial launches TARGETED 2nd week in December. For 2023 release, SO FAR, we would like to follow this precedence. There will be announcements for the 2023 release that will have target date.