! Collection of code snippets by Arne Vajhøj 
! (from articles on eksperten.dk / vajhoej.dk written sometime between 2004 and now) 
program correct
    call test(2560, 1)
    call test(2560, 2)
    call test(2560, 4)
    call test(2560, 8)
    call test(2560, 16)
    call test(2560, 32)
    call test(2560, 64)
end

subroutine test(njobs, nthreads)
    use omp_lib
    implicit none
    integer(kind=4) njobs, nthreads
    integer(kind=4) i, j, k, t1, t2, slen, c
    character(len=32768) s
    call omp_set_num_threads(nthreads)
    call system_clock(t1)
    slen = 0
    !$omp parallel private(i) shared(s, slen)
    !$omp do
    do i = 1, njobs
        call run(s, slen)
    end do
    !$omp end do
    !$omp end parallel
    c = 0
    do i = 1, njobs
        if (s(i:i) .eq. 'X') then
            c = c + 1
        end if
    end do
    call system_clock(t2)
    write(*,'(1x,I2,A,I4,A,I4)') nthreads,' threads : expected = ', njobs, ' actual = ', c
end

subroutine run(s, slen)
    use omp_lib
    use iso_c_binding
    implicit none
    character(len=32768) s
    integer(kind=4) slen
    character(len=32768) temp
    !$omp sections
    !$omp section
    !$omp critical
    temp(1:slen) = s(1:slen)
    call usleep(100)
    slen = slen + 1
    temp(slen:slen) = 'X'
    s(1:slen) = temp(1:slen)
    !$omp end critical
    !$omp end sections
end
