program ptest
      TYPE *,'ABOUT TO CALL P'
      CALL IFERR(SYS$CLREF(%VAL(1)))
      CALL P(1)
      TYPE *,'ABOUT TO CALL P'
      CALL P(1)
      STOP 'CALLED P TWICE'
      END
      SUBROUTINE P(N_FLAG)
C
C     This subroutine is a very inefficient
C     implementation of Dijkstra's P operation
C     on a semaphore.
C     Event flags are used as semaphores, and
C     the caller passes the number of an event
C     flag as the argument to this subroutine.
C
C     this time consider result integer
      INTEGER*4 SYS$SETEF     
C     symbol comes from outside
      EXTERNAL SS$_WASSET     
C     ERROR is a statement function which is
C     TRUE iff the status code is an error.
      LOGICAL ERROR
      ERROR(I) = MOD(I,2).NE.1
C     Atomically test and set the semaphore
C     event flag passed by immed. val.
10    I = SYS$SETEF(%VAL(N_FLAG))   
C     Always check for errors
      IF(ERROR(I))THEN
C        If there is one, give them error no.
         TYPE *,I
         STOP 'UNABLE TO SET EF IN P'
      END IF
C     Was the semaphore already set ?
C     if so, try again
      IF(I.EQ.%LOC(SS$_WASSET))GOTO 10 
C     we got it. Now we have exclusive access
C     to the resource. Return to caller.
      RETURN      
      END