PROGRAM NETLOCK
************************************************************************
*  This program will perform object locking and unlocking for the      *
*  NETLOCK system.  Only services offered at the local node may be     *
*  locked there.                                                       *
*                                                                      *
*  NETLOCK is a set of routines for the management of locks across a   *
*  DECnet network.  It consists of NETLOCK and NETLOCKMGR, as well as  *
*  associated command procedures.                                      *
*                                                                      *
*  This program was completed in March, 1991 by Roger G. Ruckert.      *
************************************************************************
      INCLUDE '($JPIDEF)'
      INCLUDE '($LCKDEF)'
      INCLUDE '($SSDEF)'
      INCLUDE '($LIBCLIDEF)'
      CHARACTER BUFFER*80, SYMNAME*20, SYMVALUE*20, ACTION*6, OBJECT*12
      CHARACTER Y*1, N*1, DATE*8, TIME*8, DEBUGTXT*3, PIDA*8
      CHARACTER USERNAME*12, FIRSTREC*70, OTHERREC*80, NETLOCKFNAME*40
      CHARACTER BUFFERSAVE*80, NETLOCKAUDIT*40, AUDITREC*80
      CHARACTER NETLOCKOBJECTS*40, NETLOCKNAME*13
      INTEGER*2 LOCK_STATUS, SYMLEN, ACTLEN, OBJLEN, DEBUGLEN
      BYTE BADAUDITCOUNT
      INTEGER*4 STATUS, SYS$ENQW, LIB$GETJPI, RESVAL, SYS$DEQ, PID
      INTEGER*4 LIB$GET_SYMBOL, LIB$SET_SYMBOL, IMAX, ICUR
      LOGICAL DEBUG, EXISTS
      EQUIVALENCE (BUFFER(22:33), USERNAME(1:12))   ! LJSF
      EQUIVALENCE (BUFFER(35:42), PIDA)
      EQUIVALENCE (BUFFER(62:62), BADAUDITCOUNT)
      EQUIVALENCE (BUFFER(63:66), PID)
      DATA SYMNAME /' '/, Y /'Y'/, N /'N'/
      DATA NETLOCKFNAME /'MED$NETLOCK:NETLOCKDB.DAT'/
      DATA NETLOCKAUDIT /'MED$NETLOCK:NETLOCKAUDIT.DAT'/
      DATA NETLOCKOBJECTS /'MED$NETLOCK:NETLOCKOBJECTS.DAT'/
      DATA NETLOCKNAME /'NETLOCK#NODE#'/
*
   50 FORMAT (A80)
*
      STATUS = LIB$GETJPI (JPI$_MODE,,,%REF(RESVAL),,)
      IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))
*
*     CHECK TO SEE IF THIS IS A NETWORK PROCESS
*
      IF (RESVAL .EQ. JPI$K_NETWORK) GO TO 200
************************************************************************
*                                                                      *
***   I N I T I A T I N G     P R O G R A M               BLOCK 100  ***
*                                                                      *
************************************************************************
*
***   FIRST, GET ACTION
*
      SYMNAME = 'MED$NETLOCK_ACTION'
      STATUS = LIB$GET_SYMBOL (SYMNAME, ACTION, %REF(ACTLEN))
*
      IF (.NOT. STATUS) THEN
          PRINT *, '%E, Cannot get symbol value for ', SYMNAME(1:20)
          CALL LIB$SIGNAL (%VAL(STATUS))
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, N,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL (%VAL(STATUS))
          END IF
*
          GO TO 190
      END IF
*
***   GET OBJECT NAME
*
      SYMNAME = 'MED$NETLOCK_OBJECT'
      STATUS = LIB$GET_SYMBOL (SYMNAME, OBJECT, %REF(OBJLEN))
*
      IF (.NOT. STATUS) THEN
          PRINT *, '%E, Cannot get symbol value for ', SYMNAME(1:20)
          CALL LIB$SIGNAL (%VAL(STATUS))
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, N,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL (%VAL(STATUS))
          END IF
*
          GO TO 190
      ELSE IF (OBJLEN .GT. 12) THEN
          PRINT *, '%E, Object length can only be 12 characters, not ',
     2      OBJLEN
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, N,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL (%VAL(STATUS))
          END IF
*
          GO TO 190
      END IF
*
***   CHECK DEBUG FLAG
*
      SYMNAME = 'MED$NETLOCK_DEBUG'
      STATUS = LIB$GET_SYMBOL (SYMNAME, DEBUGTXT, %REF(DEBUGLEN))
*
      IF (.NOT. STATUS) THEN
          PRINT *, '%E, Cannot get symbol value for ', SYMNAME(1:20)
          CALL LIB$SIGNAL (%VAL(STATUS))
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, N,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL (%VAL(STATUS))
          END IF
*
          GO TO 190
      END IF
*
      IF (DEBUGTXT .EQ. 'YES' .OR. DEBUGTXT .EQ. 'Y') THEN
          DEBUG = .TRUE.
      ELSE
          DEBUG = .FALSE.
      ENDIF
*
      OPEN (UNIT=1, ERR=920, IOSTAT=IOS, NAME='MED$NETLOCK_TASK',
     2  ACCESS='SEQUENTIAL', FORM='FORMATTED', 
     3  CARRIAGECONTROL='NONE', TYPE='NEW')
      READ (1, 50, IOSTAT=IOS, ERR=922) BUFFER(1:80)
      IF (DEBUG) PRINT *, BUFFER(1:80)
*
      IF (BUFFER(2:2) .EQ. 'E') THEN
          PRINT *, BUFFER(1:80)
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, N,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL(%VAL(STATUS))
          END IF
*
          GO TO 180
      END IF
*
***   NOW SET UP BUFFER FOR ACTION
*
      BUFFER = ' '
      IEND = 1 + OBJLEN
      BUFFER(2:IEND) = OBJECT(1:OBJLEN)
      CALL NODENAME (BUFFER, 15, 20, 'RJ', NLEN)
      CALL GETUSERNAME (USERNAME)
      CALL GETPID (PID, PIDA)
      BADAUDITCOUNT = 0
      IEND = 74 + ACTLEN
      BUFFER(75:IEND) = ACTION(1:ACTLEN)
      IF (DEBUG) PRINT *, BUFFER(1:80)
      WRITE (1, 50, IOSTAT=IOS, ERR=924) BUFFER(1:80)
      READ (1, 50, IOSTAT=IOS, ERR=922) BUFFER(1:80)
      IF (DEBUG .OR. BUFFER(2:2) .EQ. 'E') PRINT *, BUFFER(1:80)
*
      IF (BUFFER(2:2) .EQ. 'E') THEN
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, N,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL(%VAL(STATUS))
          END IF
      ELSE
          SYMNAME = 'MED$NETLOCK_FIN_OK'
          STATUS = LIB$SET_SYMBOL (SYMNAME, Y,
     2      %REF(LIB$K_CLI_GLOBAL_SYM))
*
          IF (.NOT. STATUS) THEN
              PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
              CALL LIB$SIGNAL(%VAL(STATUS))
          END IF
      ENDIF
*
  180 CLOSE (UNIT=1, ERR=926, IOSTAT=IOS)
  190 CALL EXIT (1)
************************************************************************
*                                                                      *
***   T A R G E T     P R O G R A M                       BLOCK 200  ***
*                                                                      *
************************************************************************
  200 OPEN (UNIT=1, NAME='SYS$NET', ACCESS='SEQUENTIAL', IOSTAT=IOS,
     2  FORM='FORMATTED', CARRIAGECONTROL='NONE', TYPE='OLD', ERR=910)
      CALL NODENAME (NETLOCKNAME, 8, 13, 'LJ', NLEN)
      STATUS = SYS$ENQW (, %VAL(LCK$K_EXMODE), LOCK_STATUS,
     2  %VAL(LCK$K_EXMODE), NETLOCKNAME,,,,,,)
*
      IF (.NOT. STATUS) THEN
          IF (STATUS .EQ. SS$_NOTQUEUED) THEN
              BUFFER(1:28) = '%E,#NODE# MM/DD/YY HH:MM:SS '
              BUFFER(29:80) = 'Another process already has lock on'
              BUFFER(65:77) = NETLOCKNAME(1:13)
              CALL NODENAME (BUFFER, 4, 9, 'RJ', NLEN)
              CALL CDATE (DATE)
              CALL CTIME (TIME)
              BUFFER(11:18) = DATE(1:8)
              BUFFER(20:27) = TIME(1:8)
          ELSE
              BUFFER(1:28) = '%E,#NODE# MM/DD/YY HH:MM:SS '
              BUFFER(29:60) = 'Invalid STATUS of ######### returned '
              BUFFER(61:80) = 'performing SYS$ENQW.'
              CALL NODENAME (BUFFER, 4, 9, 'RJ', NLEN)
              CALL CDATE (DATE)
              CALL CTIME (TIME)
              BUFFER(11:18) = DATE(1:8)
              BUFFER(20:27) = TIME(1:8)
              CALL I4DSP (STATUS, BUFFER, 47, 55, 'RJSFSL')
          END IF
*
          PRINT *, BUFFER(1:80)
          WRITE (1, 50, IOSTAT=IOS, ERR=914) BUFFER(1:80)
          GO TO 280
      END IF
*
      BUFFER(1:28) = '%I,#NODE# MM/DD/YY HH:MM:SS '
      BUFFER(29:68) = 'NETLOCK#NODE# lock obtained.  Action in '
      BUFFER(69:80) = 'progress ...'
      BUFFER(29:41) = NETLOCKNAME(1:13)
      CALL NODENAME (BUFFER, 4, 9, 'RJ', NLEN)
      CALL CDATE (DATE)
      CALL CTIME (TIME)
      BUFFER(11:18) = DATE(1:8)
      BUFFER(20:27) = TIME(1:8)
      PRINT *, BUFFER(1:80)
      WRITE (1, 50, IOSTAT=IOS, ERR=914) BUFFER(1:80)
*
***   NOW, GET FURTHER INFORMATION
*
      READ (1, 50, IOSTAT=IOS, ERR=912) BUFFER(1:80)
      ACTION = BUFFER(75:80)
*
      IF (ACTION(1:4) .EQ. 'LOCK') THEN
          GO TO 220
      ELSE IF (ACTION(1:6) .EQ. 'UNLOCK') THEN
          GO TO 240
      ELSE
          BUFFER(1:28) = '%E,#NODE# MM/DD/YY HH:MM:SS '
          BUFFER(29:80) = 'Invalid action of ###### submitted.'
          CALL NODENAME (BUFFER, 4, 9, 'RJ', NLEN)
          CALL CDATE (DATE)
          CALL CTIME (TIME)
          BUFFER(11:18) = DATE(1:8)
          BUFFER(20:27) = TIME(1:8)
          BUFFER(47:52) = ACTION(1:6)
          PRINT *, BUFFER(1:80)
          WRITE (1, 50, IOSTAT=IOS, ERR=914) BUFFER(1:80)
          GO TO 280
      END IF
*
***   OBJECT LOCKING
*
  220 BUFFERSAVE(1:80) = BUFFER(1:80)
      BUFFER(1:80) = '%I,#NODE# MM/DD/YY HH:MM:SS '
      CALL NODENAME (BUFFER, 4, 9, 'RJ', NLEN)
      CALL CDATE (DATE)
      CALL CTIME (TIME)
      BUFFER(11:18) = DATE(1:8)
      BUFFER(20:27) = TIME(1:8)
      OPEN (UNIT=2, ACCESS='DIRECT', RECL=80, ERR=900, IOSTAT=IOS,
     2  FILE=NETLOCKFNAME, STATUS='OLD',
     3  FORM='FORMATTED', ORGANIZATION='RELATIVE')
      I = 1
      READ (UNIT=2, REC=I, FMT=222, IOSTAT=IOS, ERR=902) IMAXREC, 
     2  ICURREC, FIRSTREC
  222 FORMAT (2(I5), A70)
*
      IF (ICURREC .EQ. 1) GO TO 225
*
      DO 224 I = 2, ICURREC
          READ (UNIT=2, REC=I, FMT=223, IOSTAT=IOS, ERR=902) OTHERREC
  223     FORMAT (A80)
          IF (BUFFERSAVE(2:13) .NE. OTHERREC(2:13)) GO TO 224
*
*         ENTRY ALREADY EXISTS
*
          BUFFER(2:2) = 'E'
          BUFFER(29:40) = BUFFERSAVE(2:13)
          BUFFER(41:80) = ' is locked by #NODE#::###USERID###'
          BUFFER(55:60) = OTHERREC(15:20)
          BUFFER(63:74) = OTHERREC(22:33)
          GO TO 235
  224 CONTINUE
*
***   NOW SEE IF THAT OBJECT IS OFFERED AT THIS NODE
*
  225 INQUIRE (FILE=NETLOCKOBJECTS, EXIST=EXISTS)
*
      IF (.NOT. EXISTS) THEN
          BUFFER(2:2) = 'E'
          BUFFER(29:80) = 'No NETLOCK services exist at this node.'
          GO TO 235
      ENDIF
*
      OPEN (UNIT=3, ERR=940, IOSTAT=IOS, FILE=NETLOCKOBJECTS, 
     2  STATUS='OLD', READONLY)
  226 READ (3, 50, END=228, ERR=943, IOSTAT=IOS) OTHERREC
*
      IF (BUFFERSAVE(2:13) .EQ. OTHERREC(1:12)) THEN
*       THIS OBJECT IS OFFERED AT THIS NODE
          CLOSE (3, ERR=946, IOSTAT=IOS)
          GO TO 230
      ELSE
*       LOOP THROUGH FILE
          GO TO 226
      END IF
*
  228 CLOSE (3, ERR=946, IOSTAT=IOS)
      BUFFER(2:2) = 'E'
      BUFFER(29:80) = 'Object ###OBJECT### does not exist at this node.'
      BUFFER(36:47) = BUFFERSAVE(2:13)
      GO TO 235
*
  230 IF (ICURREC .GE. IMAXREC) THEN
*       TABLE IS FULL
          BUFFER(2:2) = 'E'
          BUFFER(29:80) = 'Netlock database is full with XXXX entries.'
          CALL I4DSP (IMAXREC, BUFFER, 59, 62, 'RJSFSL')
          GO TO 235
      END IF
*
***   NOW UPDATE DATABASE WITH NEW ENTRY; FIRST, WRITE NEW RECORD
*
      OTHERREC(1:80) = BUFFERSAVE(1:80)
      OTHERREC(44:51) = DATE(1:8)
      OTHERREC(53:60) = TIME(1:8)
      ICURREC = ICURREC + 1
      I = ICURREC
      WRITE (2, REC=I, FMT=223, IOSTAT=IOS, ERR=904) OTHERREC
*
***   NOW UPDATE FIRST RECORD
*
      I = 1
      WRITE (2, REC=I, FMT=222, IOSTAT=IOS, ERR=904) IMAXREC, 
     2  ICURREC, FIRSTREC
      BUFFER(29:60) = 'Lock granted on ###OBJECT### to '
      BUFFER(61:80) = '#NODE#::##USERNAME##'
      BUFFER(45:56) = BUFFERSAVE(2:13)
      BUFFER(61:66) = BUFFERSAVE(15:20)
      BUFFER(69:80) = BUFFERSAVE(22:33)
*
  235 CLOSE (2, IOSTAT=IOS, ERR=906)
      PRINT *, BUFFER(1:80)
      WRITE (1, 50, IOSTAT=IOS, ERR=914) BUFFER(1:80)
      GO TO 275
*
***   OBJECT UNLOCKING
*
  240 BUFFERSAVE(1:80) = BUFFER(1:80)
      BUFFER(1:80) = '%I,#NODE# MM/DD/YY HH:MM:SS '
      CALL NODENAME (BUFFER, 4, 9, 'RJ', NLEN)
      CALL CDATE (DATE)
      CALL CTIME (TIME)
      BUFFER(11:18) = DATE(1:8)
      BUFFER(20:27) = TIME(1:8)
      OPEN (UNIT=2, ACCESS='DIRECT', RECL=80, ERR=900, IOSTAT=IOS,
     2  FILE=NETLOCKFNAME, STATUS='OLD',
     3  FORM='FORMATTED', ORGANIZATION='RELATIVE')
      I = 1
      READ (UNIT=2, REC=I, FMT=222, IOSTAT=IOS, ERR=902) IMAXREC, 
     2  ICURREC, FIRSTREC
*
      IF (ICURREC .EQ. 1) GO TO 250
*
      DO 245 I = 2, ICURREC
          READ (UNIT=2, REC=I, FMT=223, IOSTAT=IOS, ERR=902) AUDITREC
*
          IF (BUFFERSAVE(2:13) .EQ. AUDITREC(2:13)) THEN
              IF (BUFFERSAVE(14:42) .EQ. AUDITREC(14:42)) GO TO 252
*
*             A PROCESS IS TRYING TO UNLOCK SOMEONE ELSE'S LOCK
*
              BUFFER(2:2) = 'E'
              BUFFER(29:40) = BUFFERSAVE(2:13)
              BUFFER(41:80) = ' is locked by #NODE#::###USERID###'
              BUFFER(55:60) = AUDITREC(15:20)
              BUFFER(63:74) = AUDITREC(22:33)
              GO TO 257
          END IF
  245 CONTINUE
*
*     ENTRY WAS NOT FOUND
*
  250 BUFFER(29:59) = '###OBJECT### was not locked by '
      BUFFER(60:80) = '#NODE#::##USERNAME##'
      BUFFER(29:40) = BUFFERSAVE(2:13)
      BUFFER(60:65) = BUFFERSAVE(15:20)
      BUFFER(68:79) = BUFFERSAVE(22:33)
      AUDITREC(1:80) = BUFFERSAVE(1:80)
      AUDITREC(44:60) = ' (Never locked) '      
      GO TO 255
*
*     ENTRY FOUND; READJUST DATABASE TO DELETE IT
*
  252 IF (I .NE. ICURREC) THEN
*       MOVE LAST RECORD IN LIST TO THE "I"TH SLOT
          ISAVE = I
          I = ICURREC
          READ (UNIT=2, REC=I, FMT=223, IOSTAT=IOS, ERR=902)
     2      OTHERREC
          I = ISAVE
          WRITE (2, REC=I, FMT=223, IOSTAT=IOS, ERR=904) OTHERREC
      END IF
*
*     NOW REWRITE FIRST RECORD
*
      ICURREC = ICURREC - 1
      I = 1
      WRITE (2, REC=I, FMT=222, IOSTAT=IOS, ERR=904) IMAXREC, 
     2  ICURREC, FIRSTREC
      BUFFER(29:60) = 'Unlock given on ###OBJECT### to '
      BUFFER(61:80) = '#NODE#::##USERNAME##'
      BUFFER(45:56) = BUFFERSAVE(2:13)
      BUFFER(61:66) = BUFFERSAVE(15:20)
      BUFFER(69:80) = BUFFERSAVE(22:33)
      GO TO 255
*
*     WRITE AUDIT ENTRY
*
  255 INQUIRE (FILE=NETLOCKAUDIT, EXIST=EXISTS)
*
      IF (EXISTS) THEN
          OPEN (UNIT=3, FILE=NETLOCKAUDIT, IOSTAT=IOS, 
     2      ERR=932, ACCESS='APPEND', STATUS='OLD')
      ELSE
          OPEN (UNIT=3, FILE=NETLOCKAUDIT, IOSTAT=IOS, 
     2      ERR=930, ACCESS='SEQUENTIAL', STATUS='NEW')
          WRITE (3, 256, IOSTAT=IOS, ERR=934) NETLOCKNAME(8:13)
  256     FORMAT (T25,'NETLOCK AUDIT FOR NODE ', A6//
     2      ' OBJECT', T17, 'NODE USERNAME', T37, 'P I D', T46,
     3      'WHEN GRANTED', T65, 'WHEN RELEASED'/T2, 12('-'), T15,
     4      6('-'), T22, 12('-'), T35, 8('-'), T44, 17('-'), T63, 
     5      17('-'))
      END IF
*
      AUDITREC(62:80) = ' '
      AUDITREC(63:70) = DATE(1:8)
      AUDITREC(72:80) = TIME(1:8)
      WRITE (3, 223, IOSTAT=IOS, ERR=934) AUDITREC
      CLOSE (3, IOSTAT=IOS, ERR=936)
*
  257 CLOSE (2, IOSTAT=IOS, ERR=906)
      PRINT *, BUFFER(1:80)
      WRITE (1, 50, IOSTAT=IOS, ERR=914) BUFFER(1:80)
      GO TO 275
*
***   SHUT DOWN THE LINK
*
  275 STATUS = SYS$DEQ (,,,%VAL(LCK$M_DEQALL))
      IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))
  280 CLOSE (UNIT=1, IOSTAT=IOS, ERR=916)
      CALL EXIT (1)
************************************************************************
*                                                                      *
***   E R R O R S                                         BLOCK 900  ***
*                                                                      *
************************************************************************
*
***   NETLOCKFNAME ERRORS
*
  900 PRINT *, 'Cannot open ', NETLOCKFNAME, '; STATUS = ', IOS
      GO TO 999
*
  902 PRINT *, 'Cannot read ', NETLOCKFNAME, '; STATUS = ', IOS
      GO TO 999
*
  904 PRINT *, 'Cannot write ', NETLOCKFNAME, '; STATUS = ', IOS
      GO TO 999
*
  906 PRINT *, 'Cannot close ', NETLOCKFNAME, '; STATUS = ', IOS
      GO TO 999
*
***   SYS$NET ERRORS
*
  910 PRINT *, 'Cannot open SYS$NET; STATUS = ', IOS
      GO TO 999
*
  912 PRINT *, 'Cannot read SYS$NET; STATUS = ', IOS
      GO TO 999
*
  914 PRINT *, 'Cannot write SYS$NET; STATUS = ', IOS
      GO TO 999
*
  916 PRINT *, 'Cannot close SYS$NET; STATUS = ', IOS
      GO TO 999
*
***   MED$NETLOCKMGR_TASK ERRORS
*
  920 PRINT *, 'Cannot open MED$NETLOCKMGR_TASK; STATUS = ', IOS
      GO TO 999
*
  922 PRINT *, 'Cannot read MED$NETLOCKMGR_TASK; STATUS = ', IOS
      GO TO 999
*
  924 PRINT *, 'Cannot write MED$NETLOCKMGR_TASK; STATUS = ', IOS
      GO TO 999
*
  926 PRINT *, 'Cannot close MED$NETLOCKMGR_TASK; STATUS = ', IOS
      GO TO 999
*
***   NETLOCKAUDIT ERRORS
*
  930 PRINT *, 'Cannot create ', NETLOCKAUDIT, '; STATUS = ', IOS
      GO TO 999
*
  932 PRINT *, 'Cannot open ', NETLOCKAUDIT, '; STATUS = ', IOS
      GO TO 999
*
  934 PRINT *, 'Cannot write ', NETLOCKAUDIT, '; STATUS = ', IOS
      GO TO 999
*
  936 PRINT *, 'Cannot close ', NETLOCKAUDIT, '; STATUS = ', IOS
      GO TO 999
*
***   NETLOCKOBJECT ERRORS
*
  940 PRINT *, 'Cannot open ', NETLOCKOBJECT, '; STATUS = ', IOS
      GO TO 999
*
  943 PRINT *, 'Cannot read ', NETLOCKOBJECT, '; STATUS = ', IOS
      GO TO 999
*
  946 PRINT *, 'Cannot close ', NETLOCKOBJECT, '; STATUS = ', IOS
      GO TO 999
*
***   COMMON ERROR EXIT
*
  999 SYMNAME = 'MED$NETLOCK_FIN_OK'
      STATUS = LIB$SET_SYMBOL (SYMNAME, N, %REF(LIB$K_CLI_GLOBAL_SYM))
*
      IF (.NOT. STATUS) THEN
          PRINT *, '%E, Cannot set value of ', SYMNAME(1:20)
          CALL LIB$SIGNAL(%VAL(STATUS))
      END IF
*
      CALL EXIT (4)
*
      END