gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90

module main
  use iso_c_binding, only: c_funptr
  implicit none
  contains
  
  subroutine f1 ()
    integer :: a, b, arr(10)
    real :: x
    complex :: c
    character :: ch
    logical :: bool
    type :: struct
      integer :: a
      real :: b
    end type
    type(struct) :: s
    type(c_funptr) :: p
    
    interface
    subroutine f0 (a, c, bool, s)
      import :: struct
      integer, intent(in) :: a
      complex, intent(out) :: c
      logical, intent(inout) :: bool
      type(struct) :: s
    end subroutine
    integer function f2 (arr, x, ch, b)
      integer, intent(inout) :: arr(:)
      real, intent(in) :: x
      character, intent(out) :: ch
      real :: b
    end function
    end interface
    procedure(f0), pointer:: fp => NULL()

    !$omp dispatch              !{ dg-error "'OMP DISPATCH' directive at .1. must be followed by a procedure call with optional assignment" }
50    b = f2(arr, x, ch, s%b) + a
    !$omp dispatch              !{ dg-error "'OMP DISPATCH' directive at .1. must be followed by a procedure call with optional assignment" }
      a = b
    !$omp dispatch              !{ dg-error "'OMP DISPATCH' directive at .1. must be followed by a procedure call with optional assignment" }
      b = Not (2)
    !$omp dispatch
    !$omp threadprivate(a)	!{ dg-error "'OMP DISPATCH' directive must be followed by a procedure call with optional assignment at .1." } 
      a = f2(arr, x, ch, s%b)
    !$omp dispatch
      print *, 'This is not allowed here.'  !{ dg-error "'OMP DISPATCH' directive must be followed by a procedure call with optional assignment at .1." } 
    !$omp dispatch
      goto 50                   !{ dg-error "'OMP DISPATCH' directive must be followed by a procedure call with optional assignment at .1." } 
    !$omp dispatch              !{ dg-error "'OMP DISPATCH' directive at .1. cannot be followed by a procedure pointer" }
      call fp(a, c, bool, s)
      
    !$omp dispatch nocontext(s) !{ dg-error "NOCONTEXT clause at .1. requires a scalar LOGICAL expression" } 
      call f0(a, c, bool, s)
    !$omp dispatch nocontext(a, b) !{ dg-error "Invalid expression after 'nocontext.' at .1." } 
      call f0(a, c, bool, s)
    !$omp dispatch nocontext(a) nocontext(b) !{ dg-error "Duplicated 'nocontext' clause at .1." } 
      call f0(a, c, bool, s)
    !$omp dispatch novariants(s) !{ dg-error "NOVARIANTS clause at .1. requires a scalar LOGICAL expression" } 
      call f0(a, c, bool, s)
    !$omp dispatch novariants(a, b) !{ dg-error "Invalid expression after 'novariants.' at .1." } 
      call f0(a, c, bool, s)
    !$omp dispatch novariants(a) novariants(b) !{ dg-error "Duplicated 'novariants' clause at .1." } 
      call f0(a, c, bool, s)
    !$omp dispatch nowait nowait !{ dg-error "Duplicated 'nowait' clause at .1." } 
      call f0(a, c, bool, s)
    !$omp dispatch device(x) !{ dg-error "DEVICE clause at .1. requires a scalar INTEGER expression" } 
      call f0(a, c, bool, s)
    !$omp dispatch device(arr) !{ dg-error "DEVICE clause at .1. requires a scalar INTEGER expression" } 
      call f0(a, c, bool, s)
    !$omp dispatch is_device_ptr(x) !{ dg-error "List item 'x' in IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." } 
      call f0(a, c, bool, s)
    !$omp dispatch is_device_ptr(arr) !{ dg-error "List item 'arr' in IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." } 
      call f0(a, c, bool, s)
    !$omp dispatch is_device_ptr(p) !{ dg-error "List item 'p' in IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." } 
      call f0(a, c, bool, s)
    !$omp dispatch depend(inout: f0) !{ dg-error "Object 'f0' is not a variable at .1." } 
      call f0(a, c, bool, s)
  end subroutine
end module