libgomp/testsuite/libgomp.fortran/udr14.f90

   1 ! { dg-do run }
   2
   3   type dt
   4     integer :: g
   5     integer, allocatable :: h(:)
   6   end type
   7 !$omp declare reduction (baz : dt : bar (omp_out, omp_in)) &
   8 !$omp & initializer (foo (omp_priv, omp_orig))
   9   integer :: r
  10   type (dt), allocatable :: a(:)
  11   allocate (a(7:8))
  12   a(:)%g = 0
  13   a(7)%h = (/ 0, 0, 0 /)
  14   r = 0
  15 !$omp parallel reduction(+:r) reduction (baz:a)
  16   if (.not.allocated (a)) call abort
  17   if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort
  18   if (.not.allocated (a(7)%h)) call abort
  19   if (allocated (a(8)%h)) call abort
  20   if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort
  21   a(:)%g = a(:)%g + 2
  22   a(7)%h = a(7)%h + 3
  23   r = r + 1
  24 !$omp end parallel
  25   if (.not.allocated (a)) call abort
  26   if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort
  27   if (.not.allocated (a(7)%h)) call abort
  28   if (allocated (a(8)%h)) call abort
  29   if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort
  30   if (any (a(:)%g /= 2 * r) .or. any (a(7)%h(:) /= 3 * r)) call abort
  31 contains
  32   subroutine foo (x, y)
  33     type (dt), allocatable :: x(:), y(:)
  34     if (allocated (x) .neqv. allocated (y)) call abort
  35     if (lbound (x, 1) /= lbound (y, 1)) call abort
  36     if (ubound (x, 1) /= ubound (y, 1)) call abort
  37     if (allocated (x(7)%h) .neqv. allocated (y(7)%h)) call abort
  38     if (allocated (x(8)%h) .neqv. allocated (y(8)%h)) call abort
  39     if (lbound (x(7)%h, 1) /= lbound (y(7)%h, 1)) call abort
  40     if (ubound (x(7)%h, 1) /= ubound (y(7)%h, 1)) call abort
  41     x(7)%g = 0
  42     x(7)%h = 0
  43     x(8)%g = 0
  44   end subroutine
  45   subroutine bar (x, y)
  46     type (dt), allocatable :: x(:), y(:)
  47     x(:)%g = x(:)%g + y(:)%g
  48     x(7)%h(:) = x(7)%h(:) + y(7)%h(:)
  49   end subroutine
  50 end