!
!
! Copyright (c) 2011 - 2015
!   University of Houston System and UT-Battelle, LLC.
! Copyright (c) 2009 - 2015
!   Silicon Graphics International Corp.  SHMEM is copyrighted
!   by Silicon Graphics International Corp. (SGI) The OpenSHMEM API
!   (shmem) is released by Open Source Software Solutions, Inc., under an
!   agreement with Silicon Graphics International Corp. (SGI).
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
! o Redistributions of source code must retain the above copyright notice,
!   this list of conditions and the following disclaimer.
!
! o Redistributions in binary form must reproduce the above copyright
!   notice, this list of conditions and the following disclaimer in the
!   documentation and/or other materials provided with the distribution.
!
! o Neither the name of the University of Houston System, UT-Battelle, LLC
!   nor the names of its contributors may be used to endorse or promote
!   products derived from this software without specific prior written
!   permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
! HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
! TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!

program test_shmem_lock
  implicit none
  include 'shmem.fh'

  integer*8, save :: L
  integer  , save :: x

  integer         :: me, npes;
  integer         :: slp;
  integer         :: ret_val;
  integer         :: new_val;

  ! Function definitions
  integer                   :: shmem_my_pe, shmem_n_pes
  integer                   :: shmem_test_lock

  call shmem_init()
  me   = shmem_my_pe()
  npes = shmem_n_pes()
  L = 0
  x = 0
  ret_val = -1

  if(npes .gt. 1) then

    slp = 1
    call shmem_barrier_all()

    call shmem_set_lock(L)

    call shmem_integer_get(new_val, x, 1, 0)
    new_val = new_val + 1

    call shmem_integer_put(x, new_val, 1, 0)  ! increment x on PE 0
    call shmem_quiet()

    call shmem_clear_lock(L)

    call shmem_barrier_all()

    if(me .eq. 0) then
      if(x .eq. npes) then
        write(*,*) "Test for set, and clear lock: Passed"
      else
        write(*,*) "Test for set, and clear lock: Failed"
      end if
      x=0
    end if

    call shmem_barrier_all()

    ret_val = 1
    do while(ret_val .eq. 1)
      ret_val = shmem_test_lock(L)
    end do

    call shmem_integer_get(new_val, x, 1, 0)
    new_val = new_val + 1

    call shmem_integer_put(x, new_val, 1, 0)  ! increment x on PE 0

    call shmem_quiet()

    call shmem_clear_lock(L)

    call shmem_barrier_all()

    if(me .eq. 0) then
      if(x .eq. npes) then
        write(*,*) "Test for test lock: Passed"
      else
        write(*,*) "Test for test lock: Failed"
      end if

    end if

    call shmem_barrier_all()
  else
    write(*,*) "Number of PEs must be > 1 to test locks, test skipped"
  end if

  call shmem_finalize()

end program test_shmem_lock
