      subroutine SetTrap(SyRv)                           ,<881219.1353>
     >Set Fortran Trapping
      implicit none
 
!     K6SUBS contains routines which are specific to RTE-6.  This
!     revision operates with KERMIT revision 1.99 or later.
 
!     This routine is actually system-independent.  It is included in the
!     system-dependent outines only because it contains conditionally-
!     compiled code.  If the user MUST use this KERMIT on a C.83 system,
!     having this routine here will reduce the installation time greatly.
!     BE SURE TO RE-INDEX the appropriate library file!
 
      include kercom.ftni,NOLIST          !Defines "SysRev"
      integer*2 SyRv
 
      external FtnTrap
 
      if (SysRev .ge. 2440) then          !Fortran trapping desired?
          if (SyRv .ge. 2440) then        !Yes - is it available?
              call Ftrap(FtnTrap)         !Yes - use it
          else
              call tpFm('You must set "SysRev" (in KERCOM) <_')
              call tpFm(' 2440, then recompile/relink KxSubs!')
              call quit
          endif
      endif
      return
 
      end
 
      subroutine restore(lu)                             ,<881219.1353>
     >6/Restore LU's
      implicit none
 
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
      integer*2 lu,cnf(CnfSiz)
      logical*2 fMux
      integer*2 timv,ctrg,c17s,c30c,c30s,c33c,c33s,c34c,c34s
      equivalence (fMux,Cnf(fMx)), (timv,Cnf(tim)), (ctrg,Cnf(trg))
      equivalence (c17s,Cnf(v17))
      equivalence (c30c,Cnf(c30)), (c33c,Cnf(c33)), (c34c,Cnf(c34))
      equivalence (c30s,Cnf(s30)), (c33s,Cnf(s33)), (c34s,Cnf(s34))
 
!     This routine differs from its RTE-A counterpart in that IDM00
!     has a CN45 request to kill the DC1 trigger character, which would
!     need to be restored.  The DVM00 trigger handling is part of the
!     DDV05 device-driver, which is restored (if needed) when we do the
!     CN33 to restore the driver-responses configuration.
 
      if (lu .eq. L) then                 !Use which configuration array?
          call MoveWords(LocCnf,cnf,CnfSiz)
      else
          call MoveWords(RemCnf,cnf,CnfSiz)
      endif
 
      call Set_timeout(lu,timv,fMux)      !Restore original timeout
 
      if (.not. fMux) return              !Not mux?  Nothing left to do
 
c     At this point, we will restore ONLY those parameters we have altered
c     as a result of KERMIT's normal operations.
 
      if (c30c .ne. c30s) then
          call control(lu,3000b,c30s)     !restore char format
      endif
      if (c33c .ne. c33s) then
          call control(lu,3300b,c33s)     !restore configuration
      endif
      if (c34c .ne. c34s) then
          call control(lu,3400b,c34s)
      endif
 
      if (.not. btest(cnf,0) ) then       !D mux?
          call control(lu,3700b,173400b)  !No: allow echo/edit; end on CR
      else                ! --> Need not yet established!
          call control(lu,1700b,c17s)     !Yes: restore terminator
      endif
      return
 
      end
 
      subroutine enable(lu,imux)                         ,<881219.1353>
     >6/Enable int-scheduling
      implicit none
 
      integer*2 lu,imux
 
!     This routine differs from its RTE-A counterpart in that IDM00
!     muxt keep up with the names of the interrupt-scheduled programs
!     and DVM00 doesn't.
 
      if (.not. btest(imux,0) ) then      !B/C mux?
          call control(lu,3700b,173400b)  !cn37: set read type
      endif
      call control(lu,2000b,0)            !cn20: enable interrupts
      return
 
      end
 
      subroutine disable(lu,imux)                        ,<881219.1353>
     >6/Disable int-scheduling
      implicit none
 
      integer*2 lu,imux
 
!     This routine differs from its RTE-A counterpart in that IDM00
!     uses CN23 to disable interrupts, whereas DVM00 should agree with
!     the RTE-6 "D" mux driver in using a CN21 to do the same job.
 
      call control(lu,2100b,0)            !cn21: disable interrupts
      return
 
      end
 
      subroutine set_timeout(lu,val,imux)                ,<881219.1353>
     >6/Set LU timeout value
      implicit none
 
      integer*2 lu,val,imux
 
!     This routine differs from its RTE-A counterpart in that IDM00
!     has two flavors of timeout ("user" and "system") where DVM00 has
!     only one.
 
      if (val .lt. 0) return              !Don't set negative time-outs
 
      call control(lu,2200b,val)          !cn22: set time-out
      return
 
      end
 
      subroutine KillEnqAck                              ,<881219.1353>
     >6/Disable ENQ/ACK
      implicit none
 
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
 
!     This routine differs from its RTE-A counterpart in that IDM00
!     has a CN45 request to clear the trigger-character, whereas DVM00
!     uses DDV05 to perform triggering, and we bypass that anyway.
 
      if ( btest(iRmx,0) ) then           !D-mux?
          if ( btest(r34c,0) ) then       !XON/XOFF enabled?
              r34c = 5                    !Yes - add CPU<-->CPU protocol
          else
              r34c = 4                    !else change to CPU<-->CPU proto
          endif
          call control (R,3400b,r34c)
          r33c = 100000b                  !Turn on FIFO mode
      else
          if ( btest(r30c,7) ) then       !Is Enq/Ack on now?
              r30c = ibclr(r30c,7)        !Yes - turn it off
              call control(R,3000b,r30c)
          endif
          r33c = 22501B                   !Bypass dev-drvr/type-ahead on
      endif
      call control(R,3300b,r33c)
 
!     If we are really modifying the local configuration, we must track
!     the changes to the local array, or RESTORE won't work correctly!
 
      if (R .eq. L) call MoveWords(RemCnf,LocCnf,CnfSiz)
 
      return
 
      end
 
      Subroutine cPrep                                   ,<881219.1353>
     >6/Prepare for Connect
      implicit none
 
      include kercom.ftni,NOLIST          !Defines L and R
      include kercnf.ftni,NOLIST
      include kconcw.ftni,NOLIST
 
!     This routine differs from its RTE-A counterpart in the function-
!     codes it sets for IDM00 (12040B/C) vs. DVM00 (12792B/C), and for
!     ID*00 (12005) vs. DVA05 (12966).
 
      call disable(L)                     !Kill local interrupt scheduling
      Ltx=L $ Lrx=L $ Rtx=R $ Rrx=R       !Prepare XLUEX hi control words
      term = 1200b                        !(B/C mux terminate rcv buffer)
      dstat = 600b                        !Dynamic status request code
 
!     Prepare the local LU for connect - allows 12966 and 2 Mux types
 
      if ( fLmx ) then                    !Local on a mux?
          if ( fLcm ) then                !Yes - if B or C mux...
              Lrc = 3300b                 !transparent + save t-a data
              L33c = iand(L33c,17b) .or. 22600b  !Turn on type-ahead
              call control(L,3300b,L33c)
              call control(L,3600b,1)     !Set read length
              call control(L,3700b,4000b) !Terminate on count only
              call control(L,term,0)      !Terminate all buffers
              call control(L,term,0)      !Terminate all buffers again
              call control(L,term,0)      !Terminate all buffers once more
          else
              Lrc = 100b                  !D mux uses only binary
              L33c = 100000b              !Turn on FIFO mode
              call control(L,3300b,L33c)
          endif
          call control(L,2600b,1)         !Flush card
      else
          Lrc = 100b                      !binary
      endif
      Ltc = 2000b                         !transparent
 
!     Prepare the remote LU for connect - allows for 2 mux types only
 
      if ( fRcm ) then                    !Prepping a B/C mux port?
          Rrc = 3300b                     !transparent + save t-a data
          Rtc = 3300b                     !transparent
          R33c = (R33c.and.17b) + 22600b  !cn33: read reconfig off
          call control(R,3300b,R33c)
          call control(R,3600b,254)       !cn36: set read len (254 bytes)
          call control(R,3700b,4000b)     !cn37: terminate on count only
          call control(R,term,0)          !terminate all buffers
          call control(R,term,0)          !terminate all buffers again
          call control(R,term,0)          !terminate all buffers once more
          call sleep(10)                  !allow .1 sec settling time
      else
          Rrc = 100b                      !D-mux is simple: just binary
          Rtc = 2000b                     !...still simple: transparent
      endif
 
      if ( fLmx ) call control(L,2600b,1) !Flush local if on a mux
      call control(R,2600b,1)             !Flush remote
      return
 
      end
 
      integer*2 function GetPak()                        ,<881219.1353>
     >6/Read a packet
      implicit none
 
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !To define iRmx
      integer*2 buf(128),xr(2),cw
      equivalence (buf,RecPkt),(xr(2),cw)
 
!     This routine differs from its RTE-A equivalent in that we must
!     bypass DD*00 and suppress a trigger in the read call under RTE-A.
 
      if ( btest(iRmx,0) ) then           !D-mux?
          cw = 0                          !Yes - set for normal ASCII
      else
          cw = 3000b                      !B/C: transparent, keep t-a data
      endif
      xr = R                              !Set remote lu into control word
      call xluex(1,xr,buf,-254)           !Read a buffer
      call abreg(GetPak,rlen)             !Get the received length
      return
 
      end
 
      subroutine PutPak(len)                             ,<881219.1353>
     >6/Send a packet
      implicit none
 
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines iRmx
      integer*2 len,xl(2),cw,PakBuf
      equivalence (xl(2),cw),(Packet,PakBuf)
      data cw /2000b/                     !transparent
 
!     This routine differs from its RTE-A counterpart in that we must
!     bypass DD*00 and suppress handshake under RTE-A.
 
      xl = R                              !Get the remote LU
      call control(R,2600b,1)             !Flush card before sending
      call xluex(2,xl,PakBuf,-len)
      return
 
      end
 
      subroutine GetMux(LU,CnfArr)                       ,<881219.1353>
     >6/Get MUX info
      implicit none
 
!     This routine fills the Loc or Rem CNF array for the given LU.
!     If it uses the new serial drivers, we can ask the driver what kind of
!     card the LU is connected to; if it doesn't, we will look in the DVP
!     of the LU to see what we can learn.
!
!     The value placed in fLmx or fRmx tells KERMIT what kind of LU it is:
!         Bit 15: set if LU supports KERMIT protocol as follows
!                  RTE-A: 12040 mux only
!                  RTE-6: 12792 mux (or 12966 using DVW00 - see note below)
!         Bit 0:  set if LU is on a D MUX
!         Bit 1:  set if LU is on the A400 OBIO
!
!     NOTE: This version of KERMIT doesn't actually support the 12966/DVW00
!           combination.  It is supported by KERMIT-CX as part of CONNECT,
!           which is a terminal-emulation program by ICT.  If KERMIT-RTE
!           does things which you would like to see in KERMIT-CX, ask Don
!           Wright (at ICT) to add the appropriate code.
 
$alias /datc/ = '$DATC', NoAllocate
$alias opsy  = '.OPSY', direct
$alias xla   = '.XLA', direct
$alias xluex, NoAbort
 
      include kercnf.ftni,NOLIST
      include kercom.ftni,NOLIST
      integer*2 LU,CnfArr(CnfSiz)
      integer*2 xl(2),cw,j,a,b,z,datc,eqta,eqxa
      integer*2 LuTru,AddressOf,IxGet,opsy,xla,sc,eqx
      integer*2 naRd,naCn
      parameter (naRd = 100001b)
      parameter (naCn = 100003b)
      logical*2 xftty
      common /datc/ datc
      equivalence (xl(2),cw)
 
      integer*2 Cnf(CnfSiz)
      logical*2 fmxc
      integer*2 imxc,syuc,timc,trgc,v17c
      integer*2 c30c,c33c,c34c,s30c,s33c,s34c
      equivalence (fmxc,imxc,Cnf(fmx)),(syuc,Cnf(syu))
      equivalence (timc,Cnf(tim)),(trgc,Cnf(trg)),(v17c,Cnf(v17))
      equivalence (c30c,Cnf(c30)),(c33c,Cnf(c33)),(c34c,Cnf(c34))
      equivalence (s30c,Cnf(s30)),(s33c,Cnf(s33)),(s34c,Cnf(s34))
 
!     The following are equivalences to cfg (in kercnf.ftni)
      character*6 pnam,snam
      character*4 dnam,inam
      integer*2   drev,dvt6,dvad,irev,frev
      integer*2   cn17,cn22,cn30,cn31,cn33,cn34,dv20
      equivalence (dnam, cfg(1)),(drev, cfg(4)),(dvt6, cfg(5))
      equivalence (dvad, cfg(6)),(inam, cfg(7)),(irev,cfg(10))
      equivalence (frev,cfg(11)),(pnam,cfg(12)),(snam,cfg(15))
      equivalence (cn17,cfg(18)),(cn22,cfg(19)),(cn30,cfg(20))
      equivalence (cn31,cfg(21)),(cn33,cfg(22)),(cn34,cfg(23))
      !           cfg words 24-31 are currently (rev 4.1) spares
      equivalence (dv20,cfg(32))
 
      !Statement function:
      sc(j) =  ixget(j) .and. 77b         !Get/isolate a select-code
      eqx(j) = ixget(j+8) .and. 377b      !Get/isolate the EQTX size
 
!     This routine differs from its RTE-A counterpart in that the
!     determination of the interface type is different.
 
      j = opsy()                          !Get the operating-system type
      if (j .ne. -17) then
          call tpFm('Aborting - not set up for this system!')
          call exec(6)
      endif
 
      Cnf = 0
      Call MoveWords(Cnf,Cnf(2),CnfSiz-1) !Clear the configuration array
      syuc = LuTru(LU)                    !Get system LU
      xl = syuc .or. 100000b              !Set session override for XLUEX
      imxc = 0                            !Preset to 'not a mux'
 
      if (xla(datc) .lt. 2440) then       !timeout bit moved at rev 2440
          rtoBit = 7
      else
          rtoBit = 0
      endif
 
      if ( xftty(xl) ) then               !If interactive...
          cw = 60600b                     !see if we can do SSR
          call xluex(naCn,xl,-2,*10)      !No-abort special dynamic status
          call abreg(a,b)                 !Get the return flag
          if (b .ne. 123456b) goto 10     !Not SSR compatible
          cw = 3700b                      !Prepare for the SSR
          call xluex(naRd,xl,cfg,32,*30)  !Do the SSR
          if (dnam .eq. 'DV80') then      !Remains to be seen what happens
              imxc = 100001b
              rtoBit = 1                  !just a guess...
          endif
          if (imxc .eq. 0) goto 20        !Not a mux? Just return to caller
          v17c = cn17                     !Get current terminator
          timc = cn22                     !Current time-out value
          c30c = cn30                     !Current CN30 value
          c33c = cn33                     !Current CN33 value
          c34c = cn34                     !Current CN34 value
      endif
      goto 20
 
!     We come here if the LU is interactive but the driver won't do SSR.
!     We decide it is a MUX LU if there are 3 or more EQTs using the
!     same select-code (Don Wright: thanks for that idea!).  We must also
!     eliminate DVV00 LUs, so each of the LUs using the same select-code
!     must also have an EQT-extension of more than 13 words.  Sad to say,
!     once DVM00 is happy with the EQTX size, it clears that word, so we
!     must also allow the EQTX size to be zero!
 
10    call exec(13,LU,a,b)                !Get the EQT4 value in "b"
      b = b .and. 77b                     !Isolate the select-code
      eqta = IxGet(1650b) + 3             !Point to 1st EQT4 word
      a = 0                               !Clear the loop counter
      do j = 1,IxGet(1651b)               !Loop through the EQT table
          if (sc(eqta) .eq. b) then       !Same select-code?
              z = eqx(eqta)               !Get the EQT-extension size
              if (z.gt.13 .or. z.eq.0)
     >            a = a + 1
              endif
          eqta = eqta + 15                !Bump to next EQT4
      end do
      if (a .lt. 3) goto 20               !probably not a mux
      imxc = 100000b                      !Flag as KERMIT-useable
      eqta = IxGet(1652b) + syuc - 1      !Find my DRT entry
      eqta = IxGet(eqta) .and. 377b       !Find my EQT-number
      eqta = IxGet(1650b) + (eqta-1)*15   !Find my EQT entry
      timc = abs(IxGet(eqta+13))          !Get current timeout value
      eqxa = IxGet(eqta+12)               !Get my EQT-extension address
      c30c = IxGet(eqxa + 4)              !Get the current CN30 value
      c33c = IxGet(eqxa + 5)              !Get the current CN33 value
      if (iand(c33c,177760b) .eq. 0) then !any cn33 configuration set up?
          c33c = c33c .or. 52500b         !No - set power-on defaults
      endif
      !Note: the cn34 parameter isn't needed with 12792B/C muxes
 
 20   call MoveWords(c30c,s30c,3)         !Copy current values to saves
      call MoveWords(cnf,CnfArr,CnfSiz)   !Copy config back to caller
      return
 
 30   call tpFm('Aborting: SSR-compatible driver rejected the SSR')
      call quit
 
      end
 
      subroutine LogOff                                  ,<881219.1353>
     >6/Log the server off
      implicit none
 
      include kercom.ftni,NOLIST          !Needed for system
      integer*2 sess,Eqt,EqTypA,EqTyp,junk,err,ime(3)
      integer*2 LuTru,LuSes,LogLu,ixget
      integer*2 drt,eqta
      character*6 me
      equivalence (me,ime)
 
!     This routine differs from its RTE-A counterpart in that the jobs
!     performed by the log-off program are completely different under
!     RTE-A and under RTE-6.  Further, CLGOF doesn't exist for RTE-6!
 
      sess = LuTru( L )                   !Get our true terminal LU#
 
!     Trace down the EQT entry for this session - we will be modifying
!     the device type so that it doesn't look interactive.
 
      drt=ixget(1652b) $ eqta=ixget(1650b)!Locate system tables
      Eqt = ixget(drt+sess-1) .and. 377b  !Get our EQT#
      EqTypA = (Eqt - 1) * 15 + eqta + 4  !Locate device-type word
      junk = ixget(EqTypA)                !Get current device-type word
      EqTyp = junk .and. 37400b           !Isolate current device-type
      junk = junk .or. 37400b             !Turn us into an instrument...
      call ixPut(EqTypA,junk)             !...now!
 
      call clgof(sess,1,err)              !Log us off now
 
      junk = ixget(EqTypA) .xor. 37400b .or. EqTyp
      call ixPut(EqTypA,junk)             !Restore device-type word
 
      call pname(ime)                     !Who am I
      call ShootProg(me,'8')              !Commit suicide
 
      end
 
      subroutine clgof(sess,dum1,dum2)                   ,<881219.1353>
     >6/Perform programmatic log-off
      implicit none
 
!     CLGOF logs the session indicated by SESS off.
!
!     This routine differs from the versions submitted to the CSL by
!     Don Wright and Bill Donze in that the shutdown of any programs
!     running in the session is performed here, and not in LGOFF (as
!     it would otherwise be).  If the caller of this routine has
!         a) DeTACHed from the session and
!         b) set the device-type of the user's terminal to a non-
!            interactive type
!     then it is possible to perform a completely "silent" log-off
!     (i.e., no messages will be emitted to the user's terminal).
!     BE SURE TO RESTORE THE TERMINAL'S DEVICE TYPE!
!
!     Note -- this code was obtained originally by disassembling the
!     appropriate code from RTE-A (of all things) to find out what
!     operations were done by CLGOF there.  I reasoned that I could
!     perform similar operations under RTE-6, and a look at LGOFF
!     verified the methods used here.
 
      integer*2 sess                      !Formal parameters
      integer*2 dum1,dum2                 !(for RTE-A compatibility)
 
      integer*2 lgof,lgcl,dscs            !External stuff
$alias /lgof/ = '$LGOF', NoAllocate
$alias xla = '.XLA', direct
      common /lgof/ lgof
      common /LogOffInfo/ scba,sessn,idad
      integer*2 xla,LUSes,LogLU,LUTru,TrimLen,GetMySons
      integer*2 scba,sessn,idad
 
      integer*2 junk,temp,p1,p2,p3        !Local stuff
      integer*2 myses,cclas,prog(3),ime(3)
      logical*2 fses
      character*5 pgnam,me
      equivalence (pgnam,prog),(me,ime)
 
!     The RTE-A equivalent to this code is furnished by the system.
 
      myses = LuTru(LogLu(junk))          !Get my session#
      call pname(ime)
      sessn = sess                        !...and passed session#
      if (sessn .eq. myses) call dtach    !Get out of LGOFF's way
 
      lgcl = xla(lgof)                    !Get LGOFF's class#
      if (lgcl .eq. 0) return             !Session not available
      lgcl = lgcl .or. 20000b             !Set 'no deallocate' bit
 
      scba = LuSes(sessn)                 !Get the SCB address
      if (scba .eq. 0) return             !No such session? Just return!
 
!     The following loop terminates all programs running in the given
!     session except:
!         My caller (in case we didn't actually detach...)
!         D.RTR/SMP (special cases - they clean themselves up)
 
      p2 = 0                              !Initialize for program-search
      do while (GetMySons(prog,p2,fses) .ne. 0)
          if (pgnam .eq. 'D.RTR') goto 10
          if (pgnam .eq. 'SMP')   goto 10
          if (pgnam .eq. me) goto 10
          if ( fses ) then                !Normal program in session?
              call ShootProg(pgnam,'8')
          else
              call ShootProg(pgnam,'1')   !A "system utility"
          endif
 10   end do
 
      cclas = 0                           !Insure we allocate a class#
      call exec(18,0,0,0,0,0,cclas)       !Write to new comm class
 
!     Tell LGOFF to log off the given session
      call exec(100024b,0,cclas,1,sessn+20000b,scba,lgcl,*999)
 
!     Get messages from LGOFF until LGOFF is done.
 20   call exec(100025b,cclas+20000b,junk,0,p1,p2,p3,*999)
      if (p3 .ne. 1) goto 20              !Must be class read or write/read
      if (p2 .gt. 0) goto 20              !Ignore class-writes/-controls
      call clrq(2,cclas)                  !Release the class#
 
 999  return
 
      end
      integer*2 function GetMySons(pgnam,idno,fses)      ,<881219.1353>
     >6/Find Session Programs
      implicit none
 
      integer*2 pgnam(3),idno             !My parameters
      logical*2 fses
 
      integer*2 ixget                     !Externals
      common /LogOffInfo/ scb,sessn,idad
      integer*2 scb,sessn,idad
 
      integer*2 keywd,temp                !Local stuff
 
!     The RTE-A equivalent to this code is furnished by the system.
 
      keywd = ixget(1657b)                !Get ID-segment table pointer
      GetMySons = 0                       !Prepare for pessimistic result
      fses = .true.                       !Assume program is in session
 
 10   idad = ixget(keywd + idno)          !Get an ID-segment address
      if (idad .eq. 0) return             !End of ID-segment table - done
 
      idno = idno + 1                     !Prep for next iteration
      temp = ixget(idad + 14)             !Get the ID-segment status
      if (.not. btest(temp,4) ) then      !If this is a long ID-segment
          temp = ixget(idad+32)           !Get the SCB pointer from it
          if (scb .eq. temp) then         !If it matches the target
              pgnam = ixget(idad+12)      !...get progname (1st word)
              pgnam(2) = ixget(idad+13)   !...get progname (2nd word)
              pgnam(3) = ixget(idad+14) .and. 177400b .or. 40b
              GetMySons = 1               !Flag success
              temp = ixget(idad+31) .and. 377b
              fSes = temp .eq. sessn      !Flag program in session
              return
          endif
      endif
 
      goto 10
 
      end
 
      subroutine ShootProg(name,how)                     ,<881219.1353>
     >6/Quietly kill a program
      implicit none
 
      character*(*) name,how
 
      integer*2 buf(7),TrimLen,p
      character*13 cBuf
      equivalence (buf,cbuf)
 
!     The RTE-A equivalent to this routine is furnished by RTE-A
 
      p = TrimLen(name)
      cbuf = 'OF,' // name(:p) // ',' // how // ',NP'
      call messs(buf,13)
      return
 
      end
 
      integer*2 function WhoLockedLu(LU)
     >, 92084-1Y013 REV 2718 870506 <ps>
      implicit none
 
!     This source was obtained via disassembly of the system routine of the
!     same name.  As of the 4.1 system revision, the original system routine
!     caused its caller to be non-transportable; this is fixed here:
!         The original WhoLockedLu used "AddressOf($RNTB)" via an alias to
!             obtain the true address of the Resource Number table.
!         By going one level indirect using "XLA($$RTB)" also via an alias
!             to retrieve this address, the code becomes transportable.
 
$alias /rntb/ = '$$RTB', NoAllocate
$alias xla = '.XLA', direct
 
      integer*2 rntb
      common /rntb/ rntb
      integer*2 LU
      integer*2 drt,lumax,drt3,LockWord,LockerRN,LockerIDNo
      integer*2 IxGet,IDNumberToAdd,xla   !<ps>
 
      WhoLockedLu = 0                     !Preset return value
      drt = ixget(1652b)                  !Locate the Device Reference Table
      lumax = ixget(1653b)                !...and the size of it
      if (LU .gt. lumax) return           !Return if illegal LU
 
      drt3 = drt + lumax*2                !Locate DRT part 3
      LockWord = IxGet( ((LU-1)/2)+drt3 ) !Get word with lock for this lu
      if (iand(LU,1) .ne. 0) then         !Upper or lower byte?
          LockerRN = ibits(LockWord,8,8)  !Odd LU uses upper byte
      else
          LockerRN = ibits(LockWord,0,8)  !Even LU uses lower byte
      endif
 
      if (LockerRN .eq. 0) return         !Quit if not locked
 
      LockerIDNo = ixget(xla(rntb) + LockerRn) .and. 377b
 
      WhoLockedLu = IDNumberToAdd(LockerIDNo)
 
      return
      end
 
      subroutine IDAddToName(idaddr,PrgName,lu)
     >, 92084-1Y013 REV 2718 870506 <ps>
      implicit none
 
!     The source for this routine was obtained via disassembly of the system
!     routine of the same name.  As of the 4.1 system revision, this routine
!     did not provide the ID-segment's session info; it is fixed here!
 
      integer*2 idaddr,PrgName(*),lu,IxGet
 
      PrgName(1) = IxGet(idaddr+12)
      PrgName(2) = IxGet(idaddr+13)
      PrgName(3) = IxGet(idaddr+14) .and. 177400b .or. 40b
      lu         = IxGet(idaddr+31) .and. 377b    !870506-ps
      return
 
      end
