libgomp/testsuite/libgomp.fortran/character2.f90

   1 ! { dg-do run }
   2 !$ use omp_lib
   3
   4   character (len = 8) :: h
   5   character (len = 9) :: i
   6   h = '01234567'
   7   i = 'ABCDEFGHI'
   8   call test (h, i, 9)
   9 contains
  10   subroutine test (p, q, n)
  11     character (len = *) :: p
  12     character (len = n) :: q
  13     character (len = n) :: r
  14     character (len = n) :: t
  15     character (len = n) :: u
  16     integer, dimension (n + 4) :: s
  17     logical :: l
  18     integer :: m
  19     r = ''
  20     if (n .gt. 8) r = 'jklmnopqr'
  21     do m = 1, n + 4
  22       s(m) = m
  23     end do
  24     u = 'abc'
  25     l = .false.
  26 !$omp parallel firstprivate (p, q, r) private (t, m) reduction (.or.:l) &
  27 !$omp & num_threads (2)
  28     do m = 1, 13
  29       if (s(m) .ne. m) l = .true.
  30     end do
  31     m = omp_get_thread_num ()
  32     l = l .or. p .ne. '01234567' .or. q .ne. 'ABCDEFGHI'
  33     l = l .or. r .ne. 'jklmnopqr' .or. u .ne. 'abc'
  34 !$omp barrier
  35     if (m .eq. 0) then
  36       p = 'A'
  37       q = 'B'
  38       r = 'C'
  39       t = '123'
  40       u = '987654321'
  41     else if (m .eq. 1) then
  42       p = 'D'
  43       q = 'E'
  44       r = 'F'
  45       t = '456'
  46       s = m
  47     end if
  48 !$omp barrier
  49     l = l .or. u .ne. '987654321'
  50     if (any (s .ne. 1)) l = .true.
  51     if (m .eq. 0) then
  52       l = l .or. p .ne. 'A' .or. q .ne. 'B' .or. r .ne. 'C'
  53       l = l .or. t .ne. '123'
  54     else
  55       l = l .or. p .ne. 'D' .or. q .ne. 'E' .or. r .ne. 'F'
  56       l = l .or. t .ne. '456'
  57     end if
  58 !$omp end parallel
  59     if (l) call abort
  60   end subroutine test
  61 end