zar@JULIET.CALTECH.EDU.UUCP (06/18/87)
$!------------------------------Cut Here-------------------------
$ chk = "356694722"
$ create nf1.for
$ deck/dollars="ThEgReAtZaR"
subroutine wait_rel
parameter ss$_normal = 1
implicit integer*4 (a-z)
code = sys$wake(,)
if (bug(code,'WAKE').ne.ss$_normal) then
call output(2,'Forced exit: Waking error')
call sys$exit(%val('2c'x))
end if
return
end
subroutine account(inline,uic,dumy)
C
C Insert a message into the VMS accounting log file with the
C service $SNDACC. p1 of INLINE is the requesting PID and p2
C is the message to insert.
c
c (c) Zar Ltd. 1985
c
parameter min = '0 0:0:3.0'
parameter nan$_invcom = '1d'x
parameter nan$_nopriv = '20'x
parameter nan$_retwarn = '1c'x
implicit integer*4 (a-z)
include '($jpidef)'
include '($sjcdef)'
include '($ssdef)'
character*(*) inline
character*115 message
character*12 username
integer*4 getlis(7),jbclis(4),qmin(2)
integer*2 uic(2),uicc(2)
logical*1 dumy
c
c Initialize
c
dumy = nan$_invcom
getlis(1) = jpi$_username * 2**16 + 12
getlis(2) = %loc(username)
getlis(3) = 0
getlis(4) = jpi$_uic * 2**16 + 4
getlis(5) = %loc(uicc)
getlis(6) = 0
getlis(7) = 0
code = sys$bintim(min,qmin)
if (bug(code,'BINTIM').ne.ss$_normal) goto 999
c
c Get rid of the command string
c
if (inline(1:7).ne.'ADDACC ') return
inline = inline(8:)
if (lench(inline).eq.0) goto 999
do while(inline(1:1).eq.' ')
inline = inline(2:)
end do
C
C Get the requestor's Process ID
C
i = index(inline,' ')-1
if (i.lt.1) goto 999
read(inline(:i),'(z<i>)',err=999) pidc
inline = inline(i+2:)
C
C Get the requesters username
C
code = sys$setimr(%val(5),qmin,,)
if (bug(code,'SETIMR').ne.ss$_normal) goto 999
code = sys$getjpi(%val(6),pidc,,getlis,,,)
if (bug(code,'GETJPI').ne.ss$_normal) goto 999
code = sys$wflor(%val(5),%val(2**5.or.2**6))
call bug(code,'WFLOR')
C
C Make sure the mailbox UIC and the requestor's are the same
C
if (uic(1).ne.uicc(1).or.uic(2).ne.uicc(2)) then
write(message,'(a,o3,a,o3,a)',err=999)
1 'System being violated by UIC [',UIC(2),',',UIC(1),']'
call output(2,message(:46))
dumy = nan$_nopriv
return
end if
C
C Construct the accounting message and send it
C
message = inline
jbclis(1) = sjc$_accounting_message * 2**16 + 115
jbclis(2) = %loc(message)
jbclis(3) = 0
jbclis(4) = 0
code = sys$setimr(%val(5),qmin,,)
if (bug(code,'SETIMR').ne.ss$_normal) goto 999
jbcstat = sys$sndjbc(%val(6),%val(sjc$_write_accounting),
1 ,jbclis,,,)
if (bug(code,'SNDJBC').ne.ss$_normal) goto 888
code = sys$wflor(%val(5),%val(2**5.or.2**6))
call bug(code,'WFLOR')
C
C Get the status returned from job_control
C
if (bug(jbcstat,'SNDACC').ne.ss$_normal) goto 888
C
C Stamp the log file with completion
C
call output(2,'Accounting record sent by '//
1 username//' was successful')
dumy = 1
return
C
C Error
C
888 call output(1,'Accounting record sent by '//
1 username//' was aborted on error')
dumy = nan$_retwarn
return
999 call output(1,'Unable to send accounting record '//
1 'for '//username)
return
end
C
C======================================================================
C
c
c (c) Zar Ltd. 1985
c
integer*4 function len1(str)
character*(*) str
i = lench(str)
if (i.eq.0) i = 1
len1 = i
return
end
subroutine alloc(inline,dumy)
c
c Routine to allocate or deallocate devices to keep users
c from accessing them.
c
c (c) Zar Ltd. 1985
c
parameter nan$_invcom = '1d'x
parameter nan$_nopriv = '20'x
parameter nan$_retwarn = '1c'x
implicit integer*4 (a-z)
include '($ssdef)'
character*(*) inline
character*20 devnam,phydevnam
character*4 funct
logical*1 dumy
c
c Get the command
c
dumy = nan$_invcom
if (lench(inline).eq.0) goto 999
do while(inline(1:1).eq.' ')
inline=inline(2:)
end do
i=index(inline,' ')-1
if (i.lt.1) goto 999
funct=inline(:i)
call str$upcase(funct,funct)
c
c Get the device to allocate or deallocate
c
inline=inline(i+2:)
if (lench(inline).eq.0) goto 999
do while(inline(1:1).eq.' ')
inline=inline(2:)
end do
i=index(inline,' ')-1
if (i.lt.1.or.i.gt.20) goto 999
devnam=inline(:i)
if (lench(devnam).eq.0) goto 999
c
c Do the dirty deed
c
if (funct.eq.'GRAB') then
code = sys$alloc(devnam(:len1(devnam)),dev_l,phydevnam,,)
else if (funct.eq.'FREE') then
code = sys$dalloc(devnam(:len1(devnam)),)
else
goto 999
end if
if (bug(code,'ALLOC').ne.ss$_normal) goto 999
c
c Write out an appropriate message
c
if (funct.eq.'GRAB') then
call output(2,phydevnam(:dev_l)//' has been allocated and '//
1 'is no longer available')
else
call output(2,phydevnam(:dev_l)//' has been deallocated and'//
1 ' is available for use')
end if
dumy = 1
return
c
c An error occurred
c
999 call output(1,'Unable to '//funct//' device '//devnam(:len1(
1 devnam)))
return
end
subroutine boost
c
c Return all processes to what we think their authorized
c priority is.
c
c (c) Zar Ltd. 1985
c
implicit integer*4 (a-z)
include 'nanny.inc'
include '($ssdef)'
c
c Loop for processes
c
do i=1,crush_p
if (crush(i).ne.0) then
pt = ipid(i)
if (system(pt).ne.nan$v_inter.and.system(pt).ne.
1 nan$v_subproc) then
code = sys$setpri(crush(i),,%val(crpri(i)),)
if (code.ne.ss$_nonexpr.and.code.ne.ss$_normal) then
call bug(code,'SETPRI')
call output(1,'Unable to reset a specific priority')
else
prib(pt) = crpri(i)
end if
end if
crush(i) = 0
crpri(i) = 0
end if
end do
crush_p = 0
return
end
integer*4 function bug(code,routine)
c
c Error handler for the Nanny
c
c (c) Zar Ltd. 1985
c
parameter ss$_normal = 1
implicit integer*4 (a-z)
character*(*) routine
character*132 message
c
c If the code is not equal to a normal status, get the error
c message
c
bug = -1
if (code.ne.ss$_normal) then
i = sys$getmsg(%val(code),message_l,message,%val(15),)
c
c Couldn't get the error message
c
if (i.ne.ss$_normal) then
write(message,'(a,z8)',err=999) 'Unable to receive '//
1 'message for error number ',code
call output(1,'Message from routine '//routine(:len1(
1 routine))//char(13)//char(10)//' '//message(:51))
c
c Write out only Errors, Fatals, Warnings, and Unknowns
c
else
i = index(message,'-') + 1
if (message(i:i).ne.'S'.and.message(i:i).ne.'I'.and.
1 message(i+2:i+7).ne.'NORMAL') then
call output(1,'Message from routine '//routine(:len1(
1 routine))//char(13)//char(10)//' '//
2 message(:message_l))
else
bug = ss$_normal
end if
end if
c
c No error
c
else
bug = ss$_normal
end if
999 return
end
subroutine nan$die
c
c Routine to stop the Nanny cleanly
c
c (c) Zar Ltd. 1985
c
implicit integer*4 (a-z)
include 'nanny.inc'
include '($ssdef)'
c
c Set users priorities back to normal
c
do i=1,maxuser
if (system(i).ne.4.and.system(i).ne.2.and.pid(i).ne.0) then
code = sys$setpri(pid(i),,%val(authpri(i)),)
if (code.ne.ss$_nonexpr) call bug(code,'SETPRI')
end if
end do
c
c Resume any jobs we suspended
c
do i=1,suspids
if (susp_pid(i).ne.0) then
code = sys$resume(susp_pid(i),)
if (code.ne.ss$_nonexpr) call bug(code,'RESUME')
end if
end do
c
c Flag the exit and return to operation
c
die = 1
call output(2,'Request to exit approved')
call wait_rel
return
end
subroutine dskchk(inp_disks,start_flg)
c
c Routine to check disks for low space. If low, a message is
c sent to the operator console.
c
c (c) Zar Ltd. 1985
c
implicit integer*4 (a-z)
include 'nanny.inc'
character*(*) inp_disks
character*6 disknam(maxdisks)
logical*1 start_flg
c
c Sort out the disk names from arg list
c
if (start_flg) dsk_die = .false.
dsk_point = 1
1 i = index(inp_disks,',')
if (i.lt.1) i = lench(inp_disks)
if (i.lt.2) then
if (lench(disks(1)).gt.0) call output(2,'Request to '//
1 'abort disk check approved')
dsk_die = .true.
do cnt=1,maxdisks
disks(cnt) = ' '
end do
return
end if
dsk_die = .false.
disknam(dsk_point) = inp_disks(:i-1)
inp_disks = inp_disks(i+2:)
dsk_point = dsk_point + 1
if (lench(inp_disks).gt.0.and.dsk_point.le.maxdisks) goto 1
c
c Zero the rest of the disk array
c
do i=dsk_point,maxdisks
disknam(i) = ' '
end do
do i=1,maxdisks
if (disks(i).ne.disknam(i)) lasterr(i) = 0
disks(i) = disknam(i)
end do
c
c Start the disk checking mechanism
c
if (start_flg) call dsk_loop('0 0:0:13.0')
return
end
c
c=======================================================================
c
subroutine dsk_loop(cycle)
c
c Routine to setup AST for disk checker
c
c (c) Zar Ltd. 1985
c
parameter cycle_tim = '0 0:15:0.0'
parameter ss$_normal = 1
implicit integer*4 (a-z)
include 'nanny.inc'
character*(*) cycle
integer*4 qwait(2)
external dskmon
c
c Setup timer
c
if (dsk_die) return
if (lench(cycle).eq.0) then
code = sys$bintim(cycle_tim,qwait)
else
code = sys$bintim(cycle(:len1(cycle)),qwait)
end if
if (bug(code,'BINTIM').ne.ss$_normal) goto 1
code = sys$setimr(,qwait,dskmon,)
if (bug(code,'BINTIM').ne.ss$_normal) goto 1
return
c
c An error occurred
c
1 call output(1,'Disk monitor crash')
return
end
c
c=======================================================================
c
subroutine dskmon
c
c Subroutine to check disk space on flagged disks to check if
c low on space.
c
c (c) Zar Ltd. 1985
c
parameter maxerr = 10
parameter wait_time = '0 0:0:3.0'
implicit integer*4 (a-z)
include 'nanny.inc'
include '($dvidef)'
include '($ssdef)'
character*60 disknam
integer*4 dvilis(13),qwait(2)
logical*1 errflg
c
c Loop for each disk
c
if (dsk_die) return
errflg = .false.
dvilis(1) = dvi$_devnam * 2**16 + 60
dvilis(2) = %loc(disknam)
dvilis(3) = %loc(disknam_l)
dvilis(4) = dvi$_errcnt * 2**16 + 4
dvilis(5) = %loc(errcnt)
dvilis(6) = 0
dvilis(7) = dvi$_freeblocks * 2**16 + 4
dvilis(8) = %loc(freeblks)
dvilis(9) = 0
dvilis(10) = dvi$_maxblock * 2**16 + 4
dvilis(11) = %loc(maxblock)
dvilis(12) = 0
dvilis(13) = 0
code = sys$bintim(wait_time,qwait)
if (code.ne.ss$_normal) goto 1
do icnt=1,maxdisks
c
c Get the device information
c
if (lench(disks(icnt)).ne.0) then
code = sys$setimr(%val(3),qwait,,)
if (code.eq.ss$_normal) then
dvicode = sys$getdvi(%val(4),,disks(icnt)(:len1(disks(
1 icnt))),dvilis,,,,)
if (dvicode.eq.ss$_normal.or.dvicode.eq.ss$_concealed)
1 code = sys$wflor(%val(3),%val(2**3.or.2**4))
if (dvicode.eq.ss$_normal.or.dvicode.eq.ss$_concealed) then
c
c Check the space left
c
blks = maxblock / lowdivd
if (blks.gt.freeblks) call output(2,'Device '//
1 disknam(:disknam_l)//' is low on disk space')
c
c Check for large increases in error count
c
if (errcnt-lasterr(icnt).ge.maxerr) call output(2,
1 'Device '//disknam(:disknam_l)//' is receiving '//
2 'excessive errors')
if (errcnt-lasterr(icnt).ge.maxerr) errflg = .true.
lasterr(icnt) = errcnt
end if
end if
end if
end do
c
c Reset the timer to AST this routine
c
1 if (errflg) then
call dsk_loop('0 0:2:0.0')
else
call dsk_loop(' ')
end if
return
end
subroutine forget(inline,uic,dumy)
C
C Remove/Enter a process from/into the Nanny's watch.
c
c (c) Zar Ltd. 1985
c
parameter ss$_normal = 1
parameter wait_time = '0 0:0:3.0'
implicit integer*4 (a-z)
include 'nanny.inc'
include '($jpidef)'
character*(*) inline
character*80 message
character*12 userc,usert
character*6 funct
integer*4 getlis(7),qwait(2)
integer*2 uic(2),uicc(2)
logical*1 dumy
C
C Get the target process id
C
dumy = nan$_invcom
i=index(inline,' ')-1
funct=inline(1:i)
inline=inline(i+2:)
if (lench(inline).eq.0) goto 999
do while(lench(inline(1:1)).eq.0)
inline=inline(2:)
end do
i=index(inline,' ')-1
read(inline(1:i),'(z<i>)',err=999) pidt
inline=inline(i+2:)
C
C Are we watching the target process?
C
point=0
do i=1,maxuser
if (pid(i).eq.pidt) point=i
end do
if (point.eq.0) goto 999
C
C Get his username
C
getlis(1) = jpi$_username * 2**16 + 12
getlis(2) = %loc(usert)
getlis(3) = 0
getlis(4) = jpi$_uic * 2**16 + 4
getlis(5) = %loc(uicc)
getlis(6) = 0
getlis(7) = 0
code = sys$bintim(wait_time,qwait)
if (bug(code,'BINTIM').ne.ss$_normal) goto 999
code = sys$setimr(%val(8),qwait,,)
if (bug(code,'SETIMR').ne.ss$_normal) goto 999
code = sys$getjpi(%val(7),pidt,,getlis,,,)
if (bug(code,'GETJPI').ne.ss$_normal) goto 999
code = sys$wflor(%val(7),%val(2**7.or.2**8))
call bug(code,'WFLOR')
C
C Decode to requesting process I.D.
C
if (lench(inline).eq.0) goto 999
do while(lench(inline(1:1)).eq.0)
inline=inline(2:)
end do
i=index(inline,' ')-1
read(inline(1:i),'(z<i>)',err=999) pidc
if (pidc.eq.0) goto 999
C
C Get the requestor's username
C
getlis(1) = jpi$_username * 2**16 + 12
getlis(2) = %loc(userc)
getlis(3) = 0
getlis(4) = jpi$_uic * 2**16 + 4
getlis(5) = %loc(uicc)
getlis(6) = 0
getlis(7) = 0
code = sys$setimr(%val(8),qwait,,)
if (bug(code,'SETIMR').ne.ss$_normal) goto 999
code = sys$getjpi(%val(7),pidc,,getlis,,,)
if (bug(code,'GETJPI').ne.ss$_normal) goto 999
code = sys$wflor(%val(7),%val(2**7.or.2**8))
call bug(code,'WFLOR')
C
C Make sure requestor and mailbox UIC are the same
C
if (uic(1).ne.uicc(1).or.uic(2).ne.uicc(2)) then
write(message,'(a,o3,a,o3,a)') 'System being violated'//
1 ' by UIC [',uic(2),',',uic(1),']'
call output(2,message(:38))
return
end if
C
C Remove the process and write a message.
C
if (funct.eq.'FORGET') system(point) =nan$v_unknown
if (funct(:5).eq.'ENTER') system(point)=nan$v_inter+nan$_system
message = funct(:lench(funct))//' '//usert(:len1(usert))//
1 ' by '//userc(:len1(userc))//'''s command.'
call output(2,message(:len1(message)))
dumy=1
return
999 message = 'Unable to '//funct(:lench(funct))//' '//
1 usert(:len1(usert))
call output(1,message(:len1(message)))
return
end
subroutine gotmess
C
C Routine to communicate with outside world
C
c (c) Zar Ltd. 1985
c
parameter ss$_normal = 1
parameter wait_time = '0 0:0:3.0'
implicit integer*4 (a-z)
include 'nanny.inc'
include '($dvidef)'
character*128 inline
character*12 retmbxnam
character*9 dat
integer*4 dvilis(4)
integer*4 qwait(2)
integer*2 retmbx,uict(2)
logical*1 dumy
equivalence (inbuff,inline)
C
dumy = nan$_nopriv
if (lench(inline).eq.0) goto 999 !There was no message
do while(lench(inline(1:1)).eq.0)
inline=inline(2:)
end do
i = index(inline,' ')
call str$upcase(inline(:i),inline(:i))
funct_l = i-1
if (startup_flg) then
uict(2)=0
uict(1)=0
goto 5
end if
C
C Get the return mailbox name
C
j = i+1
if (lench(inline(j:)).eq.0) goto 2
do while(inline(j:j).eq.' ')
inline=inline(1:j-1)//inline(j+1:)
end do
k = index(inline(j:),' ')+j-2
if (k.lt.j) goto 2
retmbxnam = inline(j:k)
inline = inline(1:i)//inline(k+2:)
C
C Get the PID of the owner of this mailbox
C
dvilis(1) = dvi$_ownuic * 2**16 + 4
dvilis(2) = %loc(uict)
dvilis(3) = 0
dvilis(4) = 0
code = sys$bintim(wait_time,qwait)
if (bug(code,'BINTIM').ne.ss$_normal) goto 2
code = sys$setimr(%val(9),qwait,,)
if (bug(code,'SETIMR').ne.ss$_normal) goto 2
code = sys$getdvi(%val(10),,retmbxnam,dvilis,,,,)
if (bug(code,'GETDVI').ne.ss$_normal) goto 2
code = sys$wflor(%val(9),%val(2**9.or.2**10))
call bug(code,'WFLOR')
C
C Assign a channel to the mailbox
C
code = sys$assign(retmbxnam,retmbx,,)
if (bug(code,'ASSIGN').ne.ss$_normal) goto 2
C
C Current commands(32 max):
C ADDACC - Insert an accounting record into acc file
C DIE - Request the Nanny to exit
C ENTER - Request the Nanny to enter a process into
C her tables.
C FORGET - Request to consider a process system owned
C FREE - Deallocate a device for system use
C GRAB - Allocate a device and make it unavailable
C IGNORE - Stop sending messages to NANNY$PEEK
C KILL - Request to delete a process
C LISTEN - Start sending messages to NANNY$PEEK
C NEW - Reread parameter file and reopen log file
C ODIS - Disable a terminal for operator messages
C OEN - Enable a terminal for operator messages
C QSTART - Start a batch/device queue
C QSTOP - Stop a batch/device queue
C REQUEUE - Stop a device queue and requeue current job
C RESUME - Request to resume a process
C STOP - Request to force exit a process
C SUSPEND - Request to suspend a process
C WAKE - Request a wakeup call
C WCLR - Request to clear a wake-up call
C WSHOW - Request to return queue information on all
C wake-up calls
C
5 if (inline(1:7).eq.'ADDACC') then
i='fffffffe'x.or.disable
if (i.ne.'ffffffff'x) call account(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:4).eq.'DIE') then
if (uict(2).gt.sysgrp) goto 4
i='fffffffd'x.or.disable
if (i.ne.'ffffffff'x) call nan$die
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else if (inline(1:6).eq.'ENTER') then
if (uict(2).gt.sysgrp) goto 4
i='fffffffb'x.or.disable
if (i.ne.'ffffffff'x) call forget(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'FORGET') then
if (uict(2).gt.sysgrp) goto 4
i='fffffff7'x.or.disable
if (i.ne.'ffffffff'x) call forget(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'FREE') then
if (uict(2).gt.sysgrp) goto 4
i='ffffffef'x.or.disable
if (i.ne.'ffffffff'x) call alloc(inline,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'GRAB') then
if (uict(2).gt.sysgrp) goto 4
i='ffffffdf'x.or.disable
if (i.ne.'ffffffff'x) call alloc(inline,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'IGNORE') then
if (uict(2).gt.sysgrp) goto 4
i='ffffffbf'x.or.disable
if (i.ne.'ffffffff'x) call listener(0)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else if (inline(1:5).eq.'KILL') then
i='ffffff7f'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'LISTEN') then
if (uict(2).gt.sysgrp) goto 4
i='fffffeff'x.or.disable
if (i.ne.'ffffffff'x) call listener(1)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else if (inline(1:4).eq.'NEW') then
if (uict(2).gt.sysgrp) goto 4
i='fffffdff'x.or.disable
if (i.ne.'ffffffff'x) call new_log(dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:4).eq.'ODIS') then
i='fffffbff'x.or.disable
if (i.ne.'ffffffff'x) call oprman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:3).eq.'OEN') then
i='fffff7ff'x.or.disable
if (i.ne.'ffffffff'x) call oprman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'QSTART') then
i='ffffefff'x.or.disable
if (i.ne.'ffffffff'x) call queman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:6).eq.'QSTOP') then
i='ffffdfff'x.or.disable
if (i.ne.'ffffffff'x) call queman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:8).eq.'REQUEUE') then
i='ffffbfff'x.or.disable
if (i.ne.'ffffffff'x) call queman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'RESUME') then
if (uict(2).gt.sysgrp) goto 4
i='ffff7fff'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'STOP') then
i='fffeffff'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:8).eq.'SUSPEND') then
if (uict(2).gt.sysgrp) goto 4
i='fffdffff'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'WAKE') then
i='fffbffff'x.or.disable
if (i.ne.'ffffffff'x) call waker(inline,1,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'WCLR') then
i='fff7ffff'x.or.disable
if (i.ne.'ffffffff'x) call wakeclr(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:6).eq.'WSHOW') then
i='ffefffff'x.or.disable
if (i.ne.'ffffffff'x) call showake(retmbx)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else
call output(1,'Received unknown message: '//
1 inline(:len1(inline)))
dumy = nan$_nosuchcom
end if
if (.not.startup_flg) goto 3
999 do i=1,128
inbuff(i)=0
end do
call loop
return
1 call output(1,inline(1:funct_l)//' command aborted. '//
1 'Function disabled.')
3 code=sys$qio(,%val(retmbx),%val('70'x),,,,dumy,%val(1),,,,)
call bug(code,'QIO')
code=sys$dassgn(%val(retmbx))
call bug(code,'DASSGN')
goto 999
2 call output(1,inline(1:funct_l)//' command aborted. '//
1 'No return mailbox.')
goto 999
4 call output(1,inline(1:funct_l)//' command aborted. Non-'//
1 'system user.')
dumy = nan$_nonsys
goto 3
end
ThEgReAtZaR
$ checksum nf1.for
$ if chk.nes.checksum$checksum then write sys$output -
"NF1.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit