home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / hp1000 / k6subs.ftn < prev    next >
Text File  |  2020-01-01  |  27KB  |  672 lines
  1.       subroutine SetTrap(SyRv)                           ,<881219.1353>
  2.      >Set Fortran Trapping
  3.       implicit none
  4.  
  5. !     K6SUBS contains routines which are specific to RTE-6.  This
  6. !     revision operates with KERMIT revision 1.99 or later.
  7.  
  8. !     This routine is actually system-independent.  It is included in the
  9. !     system-dependent outines only because it contains conditionally-
  10. !     compiled code.  If the user MUST use this KERMIT on a C.83 system,
  11. !     having this routine here will reduce the installation time greatly.
  12. !     BE SURE TO RE-INDEX the appropriate library file!
  13.  
  14.       include kercom.ftni,NOLIST          !Defines "SysRev"
  15.       integer*2 SyRv
  16.  
  17.       external FtnTrap
  18.  
  19.       if (SysRev .ge. 2440) then          !Fortran trapping desired?
  20.           if (SyRv .ge. 2440) then        !Yes - is it available?
  21.               call Ftrap(FtnTrap)         !Yes - use it
  22.           else
  23.               call tpFm('You must set "SysRev" (in KERCOM) <_')
  24.               call tpFm(' 2440, then recompile/relink KxSubs!')
  25.               call quit
  26.           endif
  27.       endif
  28.       return
  29.  
  30.       end
  31.  
  32.       subroutine restore(lu)                             ,<881219.1353>
  33.      >6/Restore LU's
  34.       implicit none
  35.  
  36.       include kercom.ftni,NOLIST
  37.       include kercnf.ftni,NOLIST
  38.       integer*2 lu,cnf(CnfSiz)
  39.       logical*2 fMux
  40.       integer*2 timv,ctrg,c17s,c30c,c30s,c33c,c33s,c34c,c34s
  41.       equivalence (fMux,Cnf(fMx)), (timv,Cnf(tim)), (ctrg,Cnf(trg))
  42.       equivalence (c17s,Cnf(v17))
  43.       equivalence (c30c,Cnf(c30)), (c33c,Cnf(c33)), (c34c,Cnf(c34))
  44.       equivalence (c30s,Cnf(s30)), (c33s,Cnf(s33)), (c34s,Cnf(s34))
  45.  
  46. !     This routine differs from its RTE-A counterpart in that IDM00
  47. !     has a CN45 request to kill the DC1 trigger character, which would
  48. !     need to be restored.  The DVM00 trigger handling is part of the
  49. !     DDV05 device-driver, which is restored (if needed) when we do the
  50. !     CN33 to restore the driver-responses configuration.
  51.  
  52.       if (lu .eq. L) then                 !Use which configuration array?
  53.           call MoveWords(LocCnf,cnf,CnfSiz)
  54.       else
  55.           call MoveWords(RemCnf,cnf,CnfSiz)
  56.       endif
  57.  
  58.       call Set_timeout(lu,timv,fMux)      !Restore original timeout
  59.  
  60.       if (.not. fMux) return              !Not mux?  Nothing left to do
  61.  
  62. c     At this point, we will restore ONLY those parameters we have altered
  63. c     as a result of KERMIT's normal operations.
  64.  
  65.       if (c30c .ne. c30s) then
  66.           call control(lu,3000b,c30s)     !restore char format
  67.       endif
  68.       if (c33c .ne. c33s) then
  69.           call control(lu,3300b,c33s)     !restore configuration
  70.       endif
  71.       if (c34c .ne. c34s) then
  72.           call control(lu,3400b,c34s)
  73.       endif
  74.  
  75.       if (.not. btest(cnf,0) ) then       !D mux?
  76.           call control(lu,3700b,173400b)  !No: allow echo/edit; end on CR
  77.       else                ! --> Need not yet established!
  78.           call control(lu,1700b,c17s)     !Yes: restore terminator
  79.       endif
  80.       return
  81.  
  82.       end
  83.  
  84.       subroutine enable(lu,imux)                         ,<881219.1353>
  85.      >6/Enable int-scheduling
  86.       implicit none
  87.  
  88.       integer*2 lu,imux
  89.  
  90. !     This routine differs from its RTE-A counterpart in that IDM00
  91. !     muxt keep up with the names of the interrupt-scheduled programs
  92. !     and DVM00 doesn't.
  93.  
  94.       if (.not. btest(imux,0) ) then      !B/C mux?
  95.           call control(lu,3700b,173400b)  !cn37: set read type
  96.       endif
  97.       call control(lu,2000b,0)            !cn20: enable interrupts
  98.       return
  99.  
  100.       end
  101.  
  102.       subroutine disable(lu,imux)                        ,<881219.1353>
  103.      >6/Disable int-scheduling
  104.       implicit none
  105.  
  106.       integer*2 lu,imux
  107.  
  108. !     This routine differs from its RTE-A counterpart in that IDM00
  109. !     uses CN23 to disable interrupts, whereas DVM00 should agree with
  110. !     the RTE-6 "D" mux driver in using a CN21 to do the same job.
  111.  
  112.       call control(lu,2100b,0)            !cn21: disable interrupts
  113.       return
  114.  
  115.       end
  116.  
  117.       subroutine set_timeout(lu,val,imux)                ,<881219.1353>
  118.      >6/Set LU timeout value
  119.       implicit none
  120.  
  121.       integer*2 lu,val,imux
  122.  
  123. !     This routine differs from its RTE-A counterpart in that IDM00
  124. !     has two flavors of timeout ("user" and "system") where DVM00 has
  125. !     only one.
  126.  
  127.       if (val .lt. 0) return              !Don't set negative time-outs
  128.  
  129.       call control(lu,2200b,val)          !cn22: set time-out
  130.       return
  131.  
  132.       end
  133.  
  134.       subroutine KillEnqAck                              ,<881219.1353>
  135.      >6/Disable ENQ/ACK
  136.       implicit none
  137.  
  138.       include kercom.ftni,NOLIST
  139.       include kercnf.ftni,NOLIST
  140.  
  141. !     This routine differs from its RTE-A counterpart in that IDM00
  142. !     has a CN45 request to clear the trigger-character, whereas DVM00
  143. !     uses DDV05 to perform triggering, and we bypass that anyway.
  144.  
  145.       if ( btest(iRmx,0) ) then           !D-mux?
  146.           if ( btest(r34c,0) ) then       !XON/XOFF enabled?
  147.               r34c = 5                    !Yes - add CPU<-->CPU protocol
  148.           else
  149.               r34c = 4                    !else change to CPU<-->CPU proto
  150.           endif
  151.           call control (R,3400b,r34c)
  152.           r33c = 100000b                  !Turn on FIFO mode
  153.       else
  154.           if ( btest(r30c,7) ) then       !Is Enq/Ack on now?
  155.               r30c = ibclr(r30c,7)        !Yes - turn it off
  156.               call control(R,3000b,r30c)
  157.           endif
  158.           r33c = 22501B                   !Bypass dev-drvr/type-ahead on
  159.       endif
  160.       call control(R,3300b,r33c)
  161.  
  162. !     If we are really modifying the local configuration, we must track
  163. !     the changes to the local array, or RESTORE won't work correctly!
  164.  
  165.       if (R .eq. L) call MoveWords(RemCnf,LocCnf,CnfSiz)
  166.  
  167.       return
  168.  
  169.       end
  170.  
  171.       Subroutine cPrep                                   ,<881219.1353>
  172.      >6/Prepare for Connect
  173.       implicit none
  174.  
  175.       include kercom.ftni,NOLIST          !Defines L and R
  176.       include kercnf.ftni,NOLIST
  177.       include kconcw.ftni,NOLIST
  178.  
  179. !     This routine differs from its RTE-A counterpart in the function-
  180. !     codes it sets for IDM00 (12040B/C) vs. DVM00 (12792B/C), and for
  181. !     ID*00 (12005) vs. DVA05 (12966).
  182.  
  183.       call disable(L)                     !Kill local interrupt scheduling
  184.       Ltx=L $ Lrx=L $ Rtx=R $ Rrx=R       !Prepare XLUEX hi control words
  185.       term = 1200b                        !(B/C mux terminate rcv buffer)
  186.       dstat = 600b                        !Dynamic status request code
  187.  
  188. !     Prepare the local LU for connect - allows 12966 and 2 Mux types
  189.  
  190.       if ( fLmx ) then                    !Local on a mux?
  191.           if ( fLcm ) then                !Yes - if B or C mux...
  192.               Lrc = 3300b                 !transparent + save t-a data
  193.               L33c = iand(L33c,17b) .or. 22600b  !Turn on type-ahead
  194.               call control(L,3300b,L33c)
  195.               call control(L,3600b,1)     !Set read length
  196.               call control(L,3700b,4000b) !Terminate on count only
  197.               call control(L,term,0)      !Terminate all buffers
  198.               call control(L,term,0)      !Terminate all buffers again
  199.               call control(L,term,0)      !Terminate all buffers once more
  200.           else
  201.               Lrc = 100b                  !D mux uses only binary
  202.               L33c = 100000b              !Turn on FIFO mode
  203.               call control(L,3300b,L33c)
  204.           endif
  205.           call control(L,2600b,1)         !Flush card
  206.       else
  207.           Lrc = 100b                      !binary
  208.       endif
  209.       Ltc = 2000b                         !transparent
  210.  
  211. !     Prepare the remote LU for connect - allows for 2 mux types only
  212.  
  213.       if ( fRcm ) then                    !Prepping a B/C mux port?
  214.           Rrc = 3300b                     !transparent + save t-a data
  215.           Rtc = 3300b                     !transparent
  216.           R33c = (R33c.and.17b) + 22600b  !cn33: read reconfig off
  217.           call control(R,3300b,R33c)
  218.           call control(R,3600b,254)       !cn36: set read len (254 bytes)
  219.           call control(R,3700b,4000b)     !cn37: terminate on count only
  220.           call control(R,term,0)          !terminate all buffers
  221.           call control(R,term,0)          !terminate all buffers again
  222.           call control(R,term,0)          !terminate all buffers once more
  223.           call sleep(10)                  !allow .1 sec settling time
  224.       else
  225.           Rrc = 100b                      !D-mux is simple: just binary
  226.           Rtc = 2000b                     !...still simple: transparent
  227.       endif
  228.  
  229.       if ( fLmx ) call control(L,2600b,1) !Flush local if on a mux
  230.       call control(R,2600b,1)             !Flush remote
  231.       return
  232.  
  233.       end
  234.  
  235.       integer*2 function GetPak()                        ,<881219.1353>
  236.      >6/Read a packet
  237.       implicit none
  238.  
  239.       include kercom.ftni,NOLIST
  240.       include kercnf.ftni,NOLIST          !To define iRmx
  241.       integer*2 buf(128),xr(2),cw
  242.       equivalence (buf,RecPkt),(xr(2),cw)
  243.  
  244. !     This routine differs from its RTE-A equivalent in that we must
  245. !     bypass DD*00 and suppress a trigger in the read call under RTE-A.
  246.  
  247.       if ( btest(iRmx,0) ) then           !D-mux?
  248.           cw = 0                          !Yes - set for normal ASCII
  249.       else
  250.           cw = 3000b                      !B/C: transparent, keep t-a data
  251.       endif
  252.       xr = R                              !Set remote lu into control word
  253.       call xluex(1,xr,buf,-254)           !Read a buffer
  254.       call abreg(GetPak,rlen)             !Get the received length
  255.       return
  256.  
  257.       end
  258.  
  259.       subroutine PutPak(len)                             ,<881219.1353>
  260.      >6/Send a packet
  261.       implicit none
  262.  
  263.       include kercom.ftni,NOLIST
  264.       include kercnf.ftni,NOLIST          !Defines iRmx
  265.       integer*2 len,xl(2),cw,PakBuf
  266.       equivalence (xl(2),cw),(Packet,PakBuf)
  267.       data cw /2000b/                     !transparent
  268.  
  269. !     This routine differs from its RTE-A counterpart in that we must
  270. !     bypass DD*00 and suppress handshake under RTE-A.
  271.  
  272.       xl = R                              !Get the remote LU
  273.       call control(R,2600b,1)             !Flush card before sending
  274.       call xluex(2,xl,PakBuf,-len)
  275.       return
  276.  
  277.       end
  278.  
  279.       subroutine GetMux(LU,CnfArr)                       ,<881219.1353>
  280.      >6/Get MUX info
  281.       implicit none
  282.  
  283. !     This routine fills the Loc or Rem CNF array for the given LU.
  284. !     If it uses the new serial drivers, we can ask the driver what kind of
  285. !     card the LU is connected to; if it doesn't, we will look in the DVP
  286. !     of the LU to see what we can learn.
  287. !
  288. !     The value placed in fLmx or fRmx tells KERMIT what kind of LU it is:
  289. !         Bit 15: set if LU supports KERMIT protocol as follows
  290. !                  RTE-A: 12040 mux only
  291. !                  RTE-6: 12792 mux (or 12966 using DVW00 - see note below)
  292. !         Bit 0:  set if LU is on a D MUX
  293. !         Bit 1:  set if LU is on the A400 OBIO
  294. !
  295. !     NOTE: This version of KERMIT doesn't actually support the 12966/DVW00
  296. !           combination.  It is supported by KERMIT-CX as part of CONNECT,
  297. !           which is a terminal-emulation program by ICT.  If KERMIT-RTE
  298. !           does things which you would like to see in KERMIT-CX, ask Don
  299. !           Wright (at ICT) to add the appropriate code.
  300.  
  301. $alias /datc/ = '$DATC', NoAllocate
  302. $alias opsy  = '.OPSY', direct
  303. $alias xla   = '.XLA', direct
  304. $alias xluex, NoAbort
  305.  
  306.       include kercnf.ftni,NOLIST
  307.       include kercom.ftni,NOLIST
  308.       integer*2 LU,CnfArr(CnfSiz)
  309.       integer*2 xl(2),cw,j,a,b,z,datc,eqta,eqxa
  310.       integer*2 LuTru,AddressOf,IxGet,opsy,xla,sc,eqx
  311.       integer*2 naRd,naCn
  312.       parameter (naRd = 100001b)
  313.       parameter (naCn = 100003b)
  314.       logical*2 xftty
  315.       common /datc/ datc
  316.       equivalence (xl(2),cw)
  317.  
  318.       integer*2 Cnf(CnfSiz)
  319.       logical*2 fmxc
  320.       integer*2 imxc,syuc,timc,trgc,v17c
  321.       integer*2 c30c,c33c,c34c,s30c,s33c,s34c
  322.       equivalence (fmxc,imxc,Cnf(fmx)),(syuc,Cnf(syu))
  323.       equivalence (timc,Cnf(tim)),(trgc,Cnf(trg)),(v17c,Cnf(v17))
  324.       equivalence (c30c,Cnf(c30)),(c33c,Cnf(c33)),(c34c,Cnf(c34))
  325.       equivalence (s30c,Cnf(s30)),(s33c,Cnf(s33)),(s34c,Cnf(s34))
  326.  
  327. !     The following are equivalences to cfg (in kercnf.ftni)
  328.       character*6 pnam,snam
  329.       character*4 dnam,inam
  330.       integer*2   drev,dvt6,dvad,irev,frev
  331.       integer*2   cn17,cn22,cn30,cn31,cn33,cn34,dv20
  332.       equivalence (dnam, cfg(1)),(drev, cfg(4)),(dvt6, cfg(5))
  333.       equivalence (dvad, cfg(6)),(inam, cfg(7)),(irev,cfg(10))
  334.       equivalence (frev,cfg(11)),(pnam,cfg(12)),(snam,cfg(15))
  335.       equivalence (cn17,cfg(18)),(cn22,cfg(19)),(cn30,cfg(20))
  336.       equivalence (cn31,cfg(21)),(cn33,cfg(22)),(cn34,cfg(23))
  337.       !           cfg words 24-31 are currently (rev 4.1) spares
  338.       equivalence (dv20,cfg(32))
  339.  
  340.       !Statement function:
  341.       sc(j) =  ixget(j) .and. 77b         !Get/isolate a select-code
  342.       eqx(j) = ixget(j+8) .and. 377b      !Get/isolate the EQTX size
  343.  
  344. !     This routine differs from its RTE-A counterpart in that the
  345. !     determination of the interface type is different.
  346.  
  347.       j = opsy()                          !Get the operating-system type
  348.       if (j .ne. -17) then
  349.           call tpFm('Aborting - not set up for this system!')
  350.           call exec(6)
  351.       endif
  352.  
  353.       Cnf = 0
  354.       Call MoveWords(Cnf,Cnf(2),CnfSiz-1) !Clear the configuration array
  355.       syuc = LuTru(LU)                    !Get system LU
  356.       xl = syuc .or. 100000b              !Set session override for XLUEX
  357.       imxc = 0                            !Preset to 'not a mux'
  358.  
  359.       if (xla(datc) .lt. 2440) then       !timeout bit moved at rev 2440
  360.           rtoBit = 7
  361.       else
  362.           rtoBit = 0
  363.       endif
  364.  
  365.       if ( xftty(xl) ) then               !If interactive...
  366.           cw = 60600b                     !see if we can do SSR
  367.           call xluex(naCn,xl,-2,*10)      !No-abort special dynamic status
  368.           call abreg(a,b)                 !Get the return flag
  369.           if (b .ne. 123456b) goto 10     !Not SSR compatible
  370.           cw = 3700b                      !Prepare for the SSR
  371.           call xluex(naRd,xl,cfg,32,*30)  !Do the SSR
  372.           if (dnam .eq. 'DV80') then      !Remains to be seen what happens
  373.               imxc = 100001b
  374.               rtoBit = 1                  !just a guess...
  375.           endif
  376.           if (imxc .eq. 0) goto 20        !Not a mux? Just return to caller
  377.           v17c = cn17                     !Get current terminator
  378.           timc = cn22                     !Current time-out value
  379.           c30c = cn30                     !Current CN30 value
  380.           c33c = cn33                     !Current CN33 value
  381.           c34c = cn34                     !Current CN34 value
  382.       endif
  383.       goto 20
  384.  
  385. !     We come here if the LU is interactive but the driver won't do SSR.
  386. !     We decide it is a MUX LU if there are 3 or more EQTs using the
  387. !     same select-code (Don Wright: thanks for that idea!).  We must also
  388. !     eliminate DVV00 LUs, so each of the LUs using the same select-code
  389. !     must also have an EQT-extension of more than 13 words.  Sad to say,
  390. !     once DVM00 is happy with the EQTX size, it clears that word, so we
  391. !     must also allow the EQTX size to be zero!
  392.  
  393. 10    call exec(13,LU,a,b)                !Get the EQT4 value in "b"
  394.       b = b .and. 77b                     !Isolate the select-code
  395.       eqta = IxGet(1650b) + 3             !Point to 1st EQT4 word
  396.       a = 0                               !Clear the loop counter
  397.       do j = 1,IxGet(1651b)               !Loop through the EQT table
  398.           if (sc(eqta) .eq. b) then       !Same select-code?
  399.               z = eqx(eqta)               !Get the EQT-extension size
  400.               if (z.gt.13 .or. z.eq.0)
  401.      >            a = a + 1
  402.               endif
  403.           eqta = eqta + 15                !Bump to next EQT4
  404.       end do
  405.       if (a .lt. 3) goto 20               !probably not a mux
  406.       imxc = 100000b                      !Flag as KERMIT-useable
  407.       eqta = IxGet(1652b) + syuc - 1      !Find my DRT entry
  408.       eqta = IxGet(eqta) .and. 377b       !Find my EQT-number
  409.       eqta = IxGet(1650b) + (eqta-1)*15   !Find my EQT entry
  410.       timc = abs(IxGet(eqta+13))          !Get current timeout value
  411.       eqxa = IxGet(eqta+12)               !Get my EQT-extension address
  412.       c30c = IxGet(eqxa + 4)              !Get the current CN30 value
  413.       c33c = IxGet(eqxa + 5)              !Get the current CN33 value
  414.       if (iand(c33c,177760b) .eq. 0) then !any cn33 configuration set up?
  415.           c33c = c33c .or. 52500b         !No - set power-on defaults
  416.       endif
  417.       !Note: the cn34 parameter isn't needed with 12792B/C muxes
  418.  
  419.  20   call MoveWords(c30c,s30c,3)         !Copy current values to saves
  420.       call MoveWords(cnf,CnfArr,CnfSiz)   !Copy config back to caller
  421.       return
  422.  
  423.  30   call tpFm('Aborting: SSR-compatible driver rejected the SSR')
  424.       call quit
  425.  
  426.       end
  427.  
  428.       subroutine LogOff                                  ,<881219.1353>
  429.      >6/Log the server off
  430.       implicit none
  431.  
  432.       include kercom.ftni,NOLIST          !Needed for system
  433.       integer*2 sess,Eqt,EqTypA,EqTyp,junk,err,ime(3)
  434.       integer*2 LuTru,LuSes,LogLu,ixget
  435.       integer*2 drt,eqta
  436.       character*6 me
  437.       equivalence (me,ime)
  438.  
  439. !     This routine differs from its RTE-A counterpart in that the jobs
  440. !     performed by the log-off program are completely different under
  441. !     RTE-A and under RTE-6.  Further, CLGOF doesn't exist for RTE-6!
  442.  
  443.       sess = LuTru( L )                   !Get our true terminal LU#
  444.  
  445. !     Trace down the EQT entry for this session - we will be modifying
  446. !     the device type so that it doesn't look interactive.
  447.  
  448.       drt=ixget(1652b) $ eqta=ixget(1650b)!Locate system tables
  449.       Eqt = ixget(drt+sess-1) .and. 377b  !Get our EQT#
  450.       EqTypA = (Eqt - 1) * 15 + eqta + 4  !Locate device-type word
  451.       junk = ixget(EqTypA)                !Get current device-type word
  452.       EqTyp = junk .and. 37400b           !Isolate current device-type
  453.       junk = junk .or. 37400b             !Turn us into an instrument...
  454.       call ixPut(EqTypA,junk)             !...now!
  455.  
  456.       call clgof(sess,1,err)              !Log us off now
  457.  
  458.       junk = ixget(EqTypA) .xor. 37400b .or. EqTyp
  459.       call ixPut(EqTypA,junk)             !Restore device-type word
  460.  
  461.       call pname(ime)                     !Who am I
  462.       call ShootProg(me,'8')              !Commit suicide
  463.  
  464.       end
  465.  
  466.       subroutine clgof(sess,dum1,dum2)                   ,<881219.1353>
  467.      >6/Perform programmatic log-off
  468.       implicit none
  469.  
  470. !     CLGOF logs the session indicated by SESS off.
  471. !
  472. !     This routine differs from the versions submitted to the CSL by
  473. !     Don Wright and Bill Donze in that the shutdown of any programs
  474. !     running in the session is performed here, and not in LGOFF (as
  475. !     it would otherwise be).  If the caller of this routine has
  476. !         a) DeTACHed from the session and
  477. !         b) set the device-type of the user's terminal to a non-
  478. !            interactive type
  479. !     then it is possible to perform a completely "silent" log-off
  480. !     (i.e., no messages will be emitted to the user's terminal).
  481. !     BE SURE TO RESTORE THE TERMINAL'S DEVICE TYPE!
  482. !
  483. !     Note -- this code was obtained originally by disassembling the
  484. !     appropriate code from RTE-A (of all things) to find out what
  485. !     operations were done by CLGOF there.  I reasoned that I could
  486. !     perform similar operations under RTE-6, and a look at LGOFF
  487. !     verified the methods used here.
  488.  
  489.       integer*2 sess                      !Formal parameters
  490.       integer*2 dum1,dum2                 !(for RTE-A compatibility)
  491.  
  492.       integer*2 lgof,lgcl,dscs            !External stuff
  493. $alias /lgof/ = '$LGOF', NoAllocate
  494. $alias xla = '.XLA', direct
  495.       common /lgof/ lgof
  496.       common /LogOffInfo/ scba,sessn,idad
  497.       integer*2 xla,LUSes,LogLU,LUTru,TrimLen,GetMySons
  498.       integer*2 scba,sessn,idad
  499.  
  500.       integer*2 junk,temp,p1,p2,p3        !Local stuff
  501.       integer*2 myses,cclas,prog(3),ime(3)
  502.       logical*2 fses
  503.       character*5 pgnam,me
  504.       equivalence (pgnam,prog),(me,ime)
  505.  
  506. !     The RTE-A equivalent to this code is furnished by the system.
  507.  
  508.       myses = LuTru(LogLu(junk))          !Get my session#
  509.       call pname(ime)
  510.       sessn = sess                        !...and passed session#
  511.       if (sessn .eq. myses) call dtach    !Get out of LGOFF's way
  512.  
  513.       lgcl = xla(lgof)                    !Get LGOFF's class#
  514.       if (lgcl .eq. 0) return             !Session not available
  515.       lgcl = lgcl .or. 20000b             !Set 'no deallocate' bit
  516.  
  517.       scba = LuSes(sessn)                 !Get the SCB address
  518.       if (scba .eq. 0) return             !No such session? Just return!
  519.  
  520. !     The following loop terminates all programs running in the given
  521. !     session except:
  522. !         My caller (in case we didn't actually detach...)
  523. !         D.RTR/SMP (special cases - they clean themselves up)
  524.  
  525.       p2 = 0                              !Initialize for program-search
  526.       do while (GetMySons(prog,p2,fses) .ne. 0)
  527.           if (pgnam .eq. 'D.RTR') goto 10
  528.           if (pgnam .eq. 'SMP')   goto 10
  529.           if (pgnam .eq. me) goto 10
  530.           if ( fses ) then                !Normal program in session?
  531.               call ShootProg(pgnam,'8')
  532.           else
  533.               call ShootProg(pgnam,'1')   !A "system utility"
  534.           endif
  535.  10   end do
  536.  
  537.       cclas = 0                           !Insure we allocate a class#
  538.       call exec(18,0,0,0,0,0,cclas)       !Write to new comm class
  539.  
  540. !     Tell LGOFF to log off the given session
  541.       call exec(100024b,0,cclas,1,sessn+20000b,scba,lgcl,*999)
  542.  
  543. !     Get messages from LGOFF until LGOFF is done.
  544.  20   call exec(100025b,cclas+20000b,junk,0,p1,p2,p3,*999)
  545.       if (p3 .ne. 1) goto 20              !Must be class read or write/read
  546.       if (p2 .gt. 0) goto 20              !Ignore class-writes/-controls
  547.       call clrq(2,cclas)                  !Release the class#
  548.  
  549.  999  return
  550.  
  551.       end
  552.       integer*2 function GetMySons(pgnam,idno,fses)      ,<881219.1353>
  553.      >6/Find Session Programs
  554.       implicit none
  555.  
  556.       integer*2 pgnam(3),idno             !My parameters
  557.       logical*2 fses
  558.  
  559.       integer*2 ixget                     !Externals
  560.       common /LogOffInfo/ scb,sessn,idad
  561.       integer*2 scb,sessn,idad
  562.  
  563.       integer*2 keywd,temp                !Local stuff
  564.  
  565. !     The RTE-A equivalent to this code is furnished by the system.
  566.  
  567.       keywd = ixget(1657b)                !Get ID-segment table pointer
  568.       GetMySons = 0                       !Prepare for pessimistic result
  569.       fses = .true.                       !Assume program is in session
  570.  
  571.  10   idad = ixget(keywd + idno)          !Get an ID-segment address
  572.       if (idad .eq. 0) return             !End of ID-segment table - done
  573.  
  574.       idno = idno + 1                     !Prep for next iteration
  575.       temp = ixget(idad + 14)             !Get the ID-segment status
  576.       if (.not. btest(temp,4) ) then      !If this is a long ID-segment
  577.           temp = ixget(idad+32)           !Get the SCB pointer from it
  578.           if (scb .eq. temp) then         !If it matches the target
  579.               pgnam = ixget(idad+12)      !...get progname (1st word)
  580.               pgnam(2) = ixget(idad+13)   !...get progname (2nd word)
  581.               pgnam(3) = ixget(idad+14) .and. 177400b .or. 40b
  582.               GetMySons = 1               !Flag success
  583.               temp = ixget(idad+31) .and. 377b
  584.               fSes = temp .eq. sessn      !Flag program in session
  585.               return
  586.           endif
  587.       endif
  588.  
  589.       goto 10
  590.  
  591.       end
  592.  
  593.       subroutine ShootProg(name,how)                     ,<881219.1353>
  594.      >6/Quietly kill a program
  595.       implicit none
  596.  
  597.       character*(*) name,how
  598.  
  599.       integer*2 buf(7),TrimLen,p
  600.       character*13 cBuf
  601.       equivalence (buf,cbuf)
  602.  
  603. !     The RTE-A equivalent to this routine is furnished by RTE-A
  604.  
  605.       p = TrimLen(name)
  606.       cbuf = 'OF,' // name(:p) // ',' // how // ',NP'
  607.       call messs(buf,13)
  608.       return
  609.  
  610.       end
  611.  
  612.       integer*2 function WhoLockedLu(LU)
  613.      >, 92084-1Y013 REV 2718 870506 <ps>
  614.       implicit none
  615.  
  616. !     This source was obtained via disassembly of the system routine of the
  617. !     same name.  As of the 4.1 system revision, the original system routine
  618. !     caused its caller to be non-transportable; this is fixed here:
  619. !         The original WhoLockedLu used "AddressOf($RNTB)" via an alias to
  620. !             obtain the true address of the Resource Number table.
  621. !         By going one level indirect using "XLA($$RTB)" also via an alias
  622. !             to retrieve this address, the code becomes transportable.
  623.  
  624. $alias /rntb/ = '$$RTB', NoAllocate
  625. $alias xla = '.XLA', direct
  626.  
  627.       integer*2 rntb
  628.       common /rntb/ rntb
  629.       integer*2 LU
  630.       integer*2 drt,lumax,drt3,LockWord,LockerRN,LockerIDNo
  631.       integer*2 IxGet,IDNumberToAdd,xla   !<ps>
  632.  
  633.       WhoLockedLu = 0                     !Preset return value
  634.       drt = ixget(1652b)                  !Locate the Device Reference Table
  635.       lumax = ixget(1653b)                !...and the size of it
  636.       if (LU .gt. lumax) return           !Return if illegal LU
  637.  
  638.       drt3 = drt + lumax*2                !Locate DRT part 3
  639.       LockWord = IxGet( ((LU-1)/2)+drt3 ) !Get word with lock for this lu
  640.       if (iand(LU,1) .ne. 0) then         !Upper or lower byte?
  641.           LockerRN = ibits(LockWord,8,8)  !Odd LU uses upper byte
  642.       else
  643.           LockerRN = ibits(LockWord,0,8)  !Even LU uses lower byte
  644.       endif
  645.  
  646.       if (LockerRN .eq. 0) return         !Quit if not locked
  647.  
  648.       LockerIDNo = ixget(xla(rntb) + LockerRn) .and. 377b
  649.  
  650.       WhoLockedLu = IDNumberToAdd(LockerIDNo)
  651.  
  652.       return
  653.       end
  654.  
  655.       subroutine IDAddToName(idaddr,PrgName,lu)
  656.      >, 92084-1Y013 REV 2718 870506 <ps>
  657.       implicit none
  658.  
  659. !     The source for this routine was obtained via disassembly of the system
  660. !     routine of the same name.  As of the 4.1 system revision, this routine
  661. !     did not provide the ID-segment's session info; it is fixed here!
  662.  
  663.       integer*2 idaddr,PrgName(*),lu,IxGet
  664.  
  665.       PrgName(1) = IxGet(idaddr+12)
  666.       PrgName(2) = IxGet(idaddr+13)
  667.       PrgName(3) = IxGet(idaddr+14) .and. 177400b .or. 40b
  668.       lu         = IxGet(idaddr+31) .and. 377b    !870506-ps
  669.       return
  670.  
  671.       end
  672.