0

I am having trouble identifying a problem in an OpenMP parallelized Fortran code. In doing so, I created a small reproducible that mimics the derived types I am using in the code. The small reproducible shows some unexpected behavior that could point to the root of the problem, so I would like to understand what is happening. I am posting the code below:

module my_subroutines

  use, intrinsic :: iso_fortran_env
  
  implicit none

  type array_int32
    integer(kind=int32), dimension(:), allocatable :: arr
  end type array_int32

  type array_int32_ptr
    type(array_int32), pointer :: p => NULL()
  end type array_int32_ptr

contains

  subroutine print_rows(tid, row_ptr)
    
    implicit none

    integer(int32), intent(in) :: tid
    type(array_int32_ptr), dimension(2), target, intent(inout) :: row_ptr

    integer(kind=int32), pointer :: index => NULL()
    integer(kind=int32) :: i, j

    j = 1
    row_ptr(j)%p%arr(1) = 1000
    index => row_ptr(j)%p%arr(1)
    write(*,'(2(A,I0))') ' - row_ptr(1)p%arr(1) on thread ', tid, ': ', index

    j = 2
    row_ptr(j)%p%arr(1) = 1000
    index => row_ptr(j)%p%arr(1)
    write(*,'(2(A,I0))') ' - row_ptr(2)p%arr(1) on thread ', tid, ': ', index

  end subroutine print_rows

end module my_subroutines

program test
  
  use, intrinsic :: iso_fortran_env
  use my_subroutines
  use omp_lib

  implicit none
   
  type(array_int32_ptr), dimension(2) :: row_ptr
  type(array_int32), dimension(2), target :: row
  integer(kind=int32) :: i, tid

  !$omp parallel default(none) &
  !$omp private(i, tid, row, row_ptr)

  tid = omp_get_thread_num()
  
  allocate(row(1)%arr(10))
  allocate(row(2)%arr(20))

  row(1)%arr = (/ (i, i=1,size(row(1)%arr) )/)
  row(2)%arr = (/ (i, i=1,size(row(2)%arr) )/)

  row_ptr(1)%p => row(1)
  row_ptr(2)%p => row(2)

  call print_rows(tid, row_ptr)

  row_ptr(1)%p => row(2)
  row_ptr(2)%p => row(1)

  call print_rows(tid, row_ptr)

  deallocate(row(1)%arr, row(2)%arr)

  !$omp end parallel
    
end program test

and here is an example output running on 3 threads (which is not deterministic, pointing to some memory leak within the code):

 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1987284000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 0: 2121468960
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
Improve this question
1
  • 2
    You've initialized index in the print_rows subroutine, so giving it the save attribute, so making it shared. Hence the race. There's a duplicate of this somewhere .... But stackoverflow.com/questions/35347944/… might be useful Commented May 6 at 18:27

1 Answer 1

Reset to default
2

The problem is that you've initialized index in the print_rows subroutine, so giving it the save attribute, and so making it shared - hence the race condition. The simple solution, and I'm 90% sure there's a duplicate that says this but I can't find it, is just not to initialize index. However given that all you seem to want here is a shorthand for a long derived type component name, and that all pointers in Fortran are evil, maybe a better solution is to use Associate and get rid of the index pointer variable altogether. gfortran results below, ifx is similar:

ijb@ijb-Latitude-5410:~/work/stack$ gfortran --version
GNU Fortran (GCC) 14.1.0
Copyright © 2024 Free Software Foundation, Inc.
This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

ijb@ijb-Latitude-5410:~/work/stack$ cat pp.f90
module my_subroutines

  use, intrinsic :: iso_fortran_env
  
  implicit none

  type array_int32
    integer(kind=int32), dimension(:), allocatable :: arr
  end type array_int32

  type array_int32_ptr
    type(array_int32), pointer :: p => NULL()
  end type array_int32_ptr

contains

  subroutine print_rows(tid, row_ptr)
    
    implicit none

    integer(int32), intent(in) :: tid
    type(array_int32_ptr), dimension(2), target, intent(inout) :: row_ptr

!!$    integer(kind=int32), pointer :: index => Null()
    integer(kind=int32) :: i, j

    j = 1
    row_ptr(j)%p%arr(1) = 1000
!!$    index => row_ptr(j)%p%arr(1)
    Associate( index => row_ptr(j)%p%arr(1) )
      write(*,'(2(A,I0))') ' - row_ptr(1)p%arr(1) on thread ', tid, ': ', index
    End Associate

    j = 2
    row_ptr(j)%p%arr(1) = 1000
!!$    index => row_ptr(j)%p%arr(1)
    Associate( index => row_ptr(j)%p%arr(1) )
      write(*,'(2(A,I0))') ' - row_ptr(2)p%arr(1) on thread ', tid, ': ', index
    End Associate

  end subroutine print_rows

end module my_subroutines

program test
  
  use, intrinsic :: iso_fortran_env
  use my_subroutines
  use omp_lib

  implicit none
   
  type(array_int32_ptr), dimension(2) :: row_ptr
  type(array_int32), dimension(2), target :: row
  integer(kind=int32) :: i, tid

  !$omp parallel default(none) &
  !$omp private(i, tid, row, row_ptr)

  tid = omp_get_thread_num()
  
  allocate(row(1)%arr(10))
  allocate(row(2)%arr(20))

  row(1)%arr = (/ (i, i=1,size(row(1)%arr) )/)
  row(2)%arr = (/ (i, i=1,size(row(2)%arr) )/)

  row_ptr(1)%p => row(1)
  row_ptr(2)%p => row(2)

  call print_rows(tid, row_ptr)

  row_ptr(1)%p => row(2)
  row_ptr(2)%p => row(1)

  call print_rows(tid, row_ptr)

  deallocate(row(1)%arr, row(2)%arr)

  !$omp end parallel
    
end program test
ijb@ijb-Latitude-5410:~/work/stack$ gfortran -fopenmp -Wall -Wextra -fcheck=all -std=f2018 -g -O pp.f90 
pp.f90:25:28:

   25 |     integer(kind=int32) :: i, j
      |                            1
Warning: Unused variable ‘i’ declared at (1) [-Wunused-variable]
ijb@ijb-Latitude-5410:~/work/stack$ export OMP_NUM_THREADS=4
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
ijb@ijb-Latitude-5410:~/work/stack$ ./a.out 
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 0: 1000
 - row_ptr(2)p%arr(1) on thread 0: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 1: 1000
 - row_ptr(2)p%arr(1) on thread 1: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 2: 1000
 - row_ptr(2)p%arr(1) on thread 2: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
 - row_ptr(1)p%arr(1) on thread 3: 1000
 - row_ptr(2)p%arr(1) on thread 3: 1000
Improve this answer
Sign up to request clarification or add additional context in comments.

3 Comments

The evil here was much more the implied save -a big mistake of the F90 standard- rather the pointer.
Thanks for pointing this behavior out. I wasn't aware that the save attribute would be automatically inherited for variables that are initialized.
@luismsfern fortran-lang.org/learn/quickstart/gotchas/#implied-save

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.