home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / hp1000 / kasubs.ftn < prev    next >
Text File  |  2020-01-01  |  20KB  |  474 lines
  1.       subroutine SetTrap(SyRv)                           ,<871015.1451>
  2.      >Set Fortran Trapping
  3.       implicit none
  4.  
  5. !     KASUBS contains routines which are specific to RTE-A.  This
  6. !     revision operates with KERMIT revision 1.99a 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)                             ,<871015.1451>
  33.      >A/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 it's RTE-6 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            !If we changed port configuration
  66.           call control(lu,3000b,c30s)     !...put it back
  67.       endif
  68.       if (c33c .ne. c33s) then            !If we changed type-ahead
  69.           call control(lu,3300b,c33s)     !...restore that too
  70.       endif
  71.       if (c34c .ne. c34s) then            !If we changed handshake
  72.           call control(lu,3400b,c34s)     !...fix it up
  73.       endif
  74.  
  75.       if (.not. btest(Cnf,0) ) then       !D-mux or B-/C-mux?
  76.           call control(lu,4500b,10400b)   !Restore DC1 trigger-char
  77.           call control(lu,3700b,173400b)  !allow echo/edit; end on CR
  78.       else                ! --> Need not yet established!
  79.           call control(lu,1700b,c17s)     !Restore terminator
  80.       endif
  81.  
  82.       return
  83.       end
  84.  
  85.       subroutine enable(lu,imux)                         ,<871015.1451>
  86.      >A/Enable int-scheduling
  87.       implicit none
  88.  
  89.       include kercom.ftni,NOLIST          !Defines L
  90.       include kercnf.ftni,NOLIST          !Defines non-mux "trigger"
  91.  
  92.       integer*2 lu,iMux,dv6,if6,dp(12),p1(4),p2(4),xl(2),cw,p1s,p2s
  93.       integer*2 p1a,p1b,p1c,p1d,p2a,p2b,p2c,p2d
  94.       equivalence (dp(5),p1),(dp(9),p2),(xl(2),cw)
  95.       equivalence (p1(1),p1a),(p1(2),p1b),(p1(3),p1c),(p1(4),p1d)
  96.       equivalence (p2(1),p2a),(p2(2),p2b),(p2(3),p2c),(p2(4),p2d)
  97.  
  98. !     This routine differs from it's RTE-6 counterpart in that IDM00
  99. !     muxt keep up with the names of the interrupt-scheduled programs
  100. !     and DVM00 doesn't.
  101.  
  102.       if ( btest(iMux,0) ) then           !D-mux?
  103.           call control(lu,2000b)          !Yes - just re-enable
  104.       else
  105.           if (lu .eq. L) then
  106.               p1s = Ltrg
  107.               p2s = L17v
  108.           else
  109.               p1s = Rtrg
  110.               p2s = R17v
  111.           endif
  112.           xl = lu                         !Prepare for XLUEX
  113.           call control(lu,3700b,173400b)  !cn37: set read type
  114.           cw = 10000b                     !Set the "Z-bit"
  115.           call xluex(13,xl,dv6,if6,dp,12) !Get pri/sec program names
  116.           call control(lu,102300b,0)      !cn23: set scheduling flag
  117.           if (imux .ge. 0) p1a = p1s      !Restore P1a if not on mux
  118.           cw = 2000b                      !cn20: enable primary scheduling
  119.           call xluex(3,xl,p1a,p1b,p1c,p1d)
  120.           if (imux .ge. 0) p2a = p2s      !Restore P2a if not on mux
  121.           cw = 4000b                      !cn40: enable secondary sched
  122.           call xluex(3,xl,p2a,p2b,p2c,p2d)
  123.       endif
  124.  
  125.       return
  126.       end
  127.  
  128.       subroutine disable(lu,iMux)                        ,<871015.1451>
  129.      >A/Disable int-scheduling
  130.       implicit none
  131.  
  132.       integer*2 lu,iMux
  133.  
  134. !     This routine differs from it's RTE-6 counterpart in that IDM00
  135. !     uses CN23 to disable interrupts, whereas DVM00 should agree with
  136. !     the RTE-6 "D" mux driver in using a CN21 to do the same job.
  137.  
  138.       if ( btest(iMux,0) ) then           !D-mux?
  139.           call control(lu,2100b,1)        !cn21: disable scheduling
  140.       else
  141.           call control(lu,102300b,1)      !cn23: clr sched flg (to intfc)
  142.       endif
  143.  
  144.       return
  145.       end
  146.  
  147.       subroutine set_timeout(lu,val,iMux)                ,<871015.1451>
  148.      >A/Set LU timeout value
  149.       implicit none
  150.  
  151.       integer*2 lu,val,iMux
  152.  
  153. !     This routine differs from it's RTE-6 counterpart in that IDM00
  154. !     has two flavors of timeout ("user" and "system") where DVM00 has
  155. !     only one.
  156.  
  157.       if (val .lt. 0) return              !Don't set negative time-outs
  158.  
  159.       if ( btest(iMux,0) ) then           !D-mux or B-/C-mux?
  160.           call control(lu,2200b,val)      !D: only one flavor of timeout
  161.       else
  162.           call control(lu,2700b,val)      !B/C: set "user" time-out
  163.       endif
  164.  
  165.       return
  166.       end
  167.  
  168.       subroutine KillEnqAck                              ,<871015.1451>
  169.      >A/Disable remote ENQ/ACK
  170.       implicit none
  171.  
  172.       include kercom.ftni,NOLIST
  173.       include kercnf.ftni,NOLIST
  174.  
  175. !     This routine differs from it's RTE-6 counterpart in that IDM00
  176. !     has a CN45 request to clear the trigger-character, whereas DVM00
  177. !     uses DDV05 to perform triggering, and we bypass that anyway.
  178.  
  179.       if ( btest(iRmx,0) ) then           !D-mux?
  180.           if ( btest(r34c,0) ) then       !XON/XOFF enabled?
  181.               r34c = 5                    !Yes - add CPU<-->CPU protocol
  182.           else
  183.               r34c = 4                    !else change to CPU<-->CPU proto
  184.           endif
  185.           call control(R,3400b,r34c)
  186.           r33c = 100000b                  !Turn on FIFO mode
  187.       else
  188.           call control(R,4500b,0)         !cn45: set trigger-char (to none)
  189.           if ( btest(r30c,7) ) then       !is Enq/Ack on now?
  190.               r30c = r30c .xor. 200b      !Yes - turn it off
  191.               call control(R,3000b,r30c)  !...and send it to the port
  192.           endif
  193.           r33c = 22500b                   !Set for type-ahead
  194.       endif
  195.       call control(R,3300b,r33c)
  196.  
  197. !     If we are really modifying the local configuration, we must track
  198. !     the changes to the local array, or RESTORE won't work correctly!
  199.  
  200.       if (R .eq. L) call MoveWords(RemCnf,LocCnf,CnfSiz)
  201.  
  202.       return
  203.  
  204.       end
  205.  
  206.       Subroutine cPrep                                   ,<871015.1451>
  207.      >A/Prepare for Connect
  208.       implicit none
  209.  
  210.       include kercom.ftni,NOLIST          !Defines L and R
  211.       include kercnf.ftni,NOLIST
  212.       include kconcw.ftni,NOLIST
  213.  
  214. !     This routine differs from it's RTE-6 counterpart in the function-
  215. !     codes it sets for IDM00 (12040B/C) vs. DVM00 (12792B/C), and for
  216. !     ID*00 (12005) vs. DVA05 (12966).
  217.  
  218.       call disable(L)                     !Kill local interrupt scheduling
  219.       Ltx=L $ Lrx=L $ Rtx=R $ Rrx=R       !Prepare XLUEX hi control words
  220.       term = 5200b                        !(B/C mux terminate rcv buffer)
  221.       dstat = 100600b                     !Dynamic status bypasses dev-dvr
  222.  
  223. !     Prepare the local LU for connect - allows for ASIC and 2 Mux types
  224.  
  225.       if ( fLmx ) then                    !Local on a mux?
  226.           if ( fLcm ) then                !Yes - if B or C mux...
  227.               Lrc = 3100b                 !...use trans/save t-a data
  228.               L33c = 22600b               !Turn on local FIFO
  229.               call control(L,3300b,L33c)
  230.               call control(L,3600b,1)     !Set read length
  231.               call control(L,3700b,4000b) !terminate on count only
  232.               call control(L,term,0)      !terminate all buffers
  233.               call control(L,term,0)      !terminate all buffers again
  234.               call control(L,term,0)      !terminate all buffers once more
  235.           else
  236.               Lrc = 100b                  !D mux uses only binary
  237.               L33c = 100000b              !Turn on local FIFO mode
  238.               call control(L,3300b,l33c)
  239.           endif
  240.           call control(L,2600b,1)         !Flush card
  241.       else
  242.           Lrc = 100100b                   !Skip device-driver + binary
  243.       endif
  244.       Ltc = 2000b                         !transparent
  245.  
  246. !     Prepare the remote LU for connect - allows for 2 mux types only
  247.  
  248.       if ( fRcm ) then                    !Prepping a B/C mux port?
  249.           Rrc = 3100b                     !transparent + save t-a data
  250.           Rtc = 3700b                     !transparent + no handshake
  251.           R33c = 22600b                   !cn33: read reconfig off
  252.           call control(R,3300b,R33c)      !cn33: read reconfig off
  253.           call control(R,3600b,254)       !cn36: set read len (254 bytes)
  254.           call control(R,3700b,4000b)     !cn37: terminate on count only
  255.           call control(R,term,0)          !terminate all buffers
  256.           call control(R,term,0)          !terminate all buffers again
  257.           call control(R,term,0)          !terminate all buffers once more
  258.           call sleep(10)                  !allow .1 sec settling time
  259.       else
  260.           Rrc = 100b                      !D-mux is simple: just binary
  261.           Rtc = 2000b                     !...still simple: transparent
  262.       endif
  263.  
  264.       if ( fLmx ) call control(L,2600b,1) !Flush local if on a mux
  265.       call control(R,2600b,1)             !Flush remote
  266.       return
  267.  
  268.       end
  269.  
  270.       integer*2 function GetPak()                        ,<871015.1451>
  271.      >A/Read a packet
  272.       implicit none
  273.  
  274.       include kercom.ftni,NOLIST
  275.       include kercnf.ftni,NOLIST          !To define fRmx
  276.       integer*2 buf(128),xr(2),cw
  277.       equivalence (buf,RecPkt),(xr(2),cw)
  278.  
  279. !     This routine differs from it's RTE-6 equivalent in that we must
  280. !     bypass DD*00 and suppress a trigger in the read call under RTE-A.
  281.  
  282.       if ( btest(iRmx,0) ) then           !D-mux?
  283.           cw = 0                          !Yes - set for normal ASCII
  284.       else
  285.           cw = 103000b                    !B/C: no ddvr, trans, keep t-a
  286.       endif
  287.       xr = R                              !Set remote lu into control word
  288.       call xluex(1,xr,buf,-254,40000b)    !Get the info
  289.       call abreg(GetPak,rlen)             !Get the received length
  290.       return
  291.  
  292.       end
  293.  
  294.       subroutine PutPak(len)                             ,<871015.1451>
  295.      >A/Send a packet
  296.       implicit none
  297.  
  298.       include kercom.ftni,NOLIST          !Defines
  299.       include kercnf.ftni,NOLIST          !Defines fRmx
  300.       integer*2 len,xl(2),cw,PakBuf
  301.       equivalence (xl(2),cw),(Packet,PakBuf)
  302.  
  303. !     This routine differs from it's RTE-6 counterpart in that we must
  304. !     bypass DD*00 and suppress handshake under RTE-A.
  305.  
  306.       if ( btest(iRmx,0) ) then           !D-mux
  307.           cw = 2000b                      !Yes - do transparent write
  308.       else
  309.           cw = 102700b                    !Else bypass, trans, no handshake
  310.       endif
  311.       xl = R                              !Get the remote LU
  312.       call control(R,2600b,1)             !Flush the card before sending
  313.       call xluex(2,xl,PakBuf,-len)
  314.       return
  315.  
  316.       end
  317.       subroutine GetMux(LU,CnfArr)                       ,<871015.1451>
  318.      >A/Get MUX info
  319.       implicit none
  320.  
  321. !     This routine fills the Loc or Rem CNF array for the given LU.
  322. !     If it uses the new serial drivers, we can ask the driver what kind of
  323. !     card the LU is connected to; if it doesn't, we will look in the DVP
  324. !     of the LU to see what we can learn.
  325. !
  326. !     The value placed in fLmx or fRmx tells KERMIT what kind of LU it is:
  327. !         Bit 15: set if LU supports KERMIT protocol as follows
  328. !                  RTE-A: 12040 mux
  329. !                  RTE-6: 12792 mux (or 12966 using DVW00 - see note below)
  330. !         Bit 0:  set if LU uses the new serial drivers
  331. !         Bit 1:  set if LU is on the A400 OBIO
  332. !
  333. !     NOTE: This version of KERMIT doesn't actually support the 12966/DVW00
  334. !           combination.  It is supported by KERMIT-CX as part of CONNECT,
  335. !           which is a terminal-emulation program by ICT.  If KERMIT-RTE
  336. !           does things which you would like to see in KERMIT-CX, ask Don
  337. !           Wright (at ICT) to add the appropriate code.
  338.  
  339. $alias /lut/ = '$LUTA', NoAllocate
  340. $alias opsy  = '.OPSY', direct
  341. $alias xluex, NoAbort
  342.  
  343.       include kercnf.ftni,NOLIST
  344.       include kercom.ftni,NOLIST
  345.       integer*2 LU,CnfArr(CnfSiz)
  346.       integer*2 xl(2),cw,j,a,b,lut,dvta,dvxa
  347.       integer*2 LuTru,AddressOf,IxGet,opsy
  348.       integer*2 naRd,naCn
  349.       parameter (naRd = 100001b)
  350.       parameter (naCn = 100003b)
  351.       logical*2 xftty
  352.       common /lut/ lut
  353.       equivalence (xl(2),cw)
  354.  
  355.       integer*2 Cnf(CnfSiz)
  356.       logical*2 fmxc
  357.       integer*2 imxc,syuc,timc,trgc,v17c
  358.       integer*2 c30c,c33c,c34c,s30c,s33c,s34c
  359.       equivalence (fmxc,imxc,Cnf(fmx)),(syuc,Cnf(syu))
  360.       equivalence (timc,Cnf(tim)),(trgc,Cnf(trg)),(v17c,Cnf(v17))
  361.       equivalence (c30c,Cnf(c30)),(c33c,Cnf(c33)),(c34c,Cnf(c34))
  362.       equivalence (s30c,Cnf(s30)),(s33c,Cnf(s33)),(s34c,Cnf(s34))
  363.  
  364. !     The following are equivalences to cfg (in kercnf.ftni)
  365.       character*6 pnam,snam
  366.       character*4 dnam,inam
  367.       integer*2   drev,dvt6,dvad,irev,frev
  368.       integer*2   cn17,cn22,cn30,cn31,cn33,cn34,dv20
  369.       equivalence (dnam, cfg(1)),(drev, cfg(4)),(dvt6, cfg(5))
  370.       equivalence (dvad, cfg(6)),(inam, cfg(7)),(irev,cfg(10))
  371.       equivalence (frev,cfg(11)),(pnam,cfg(12)),(snam,cfg(15))
  372.       equivalence (cn17,cfg(18)),(cn22,cfg(19)),(cn30,cfg(20))
  373.       equivalence (cn31,cfg(21)),(cn33,cfg(22)),(cn34,cfg(23))
  374.       !           cfg words 24-31 are currently (rev 4.1) spares
  375.       equivalence (dv20,cfg(32))
  376.  
  377. !     This routine differs from it's RTE-6 counterpart in that
  378. !     determination of the interface type is different.
  379.  
  380.       j = opsy()                          !Get the operating-system type
  381.       if (j.ne.-53 .and. j.ne.-37 .and. j.ne.-61) then
  382.           call tpFm('Aborting - not set up for this system!')
  383.           call exec(6)
  384.       endif
  385.  
  386.       Cnf = 0
  387.       Call MoveWords(Cnf,Cnf(2),CnfSiz-1) !Clear the configuration array
  388.       syuc = LuTru(LU)                    !Get system LU
  389.       xl = syuc .or. 100000b              !Set session override for XLUEX
  390.       imxc = 0                            !Preset to 'not a mux'
  391.  
  392.       rtobit = 1                          !Set the time-out bit for RTE-A
  393.       if ( xftty(xl) ) then               !If interactive...
  394.           cw = 60600b                     !see if we can do SSR
  395.           call xluex(naCn,xl,-2,*10)      !No-abort special dynamic status
  396.           call abreg(a,b)                 !Get the return flag
  397.           if (b .ne. 123456b) goto 10     !Not SSR compatible
  398.           cw = 3700b                      !Prepare for the SSR
  399.           call xluex(naRd,xl,cfg,32,*30)  !Do the SSR
  400.           if (inam .eq. 'ID80') then      !We have a "D" mux!
  401.               imxc = 100001b
  402.           endif
  403.           if (inam .eq. 'ID40') then      !See if maybe it's A400 OBIO
  404.               imxc = 100003b
  405.           endif
  406.           if (imxc .eq. 0) goto 20        !Not a mux? Just return to caller
  407.           v17c = cn17                     !Get current terminator
  408.           timc = cn22                     !Current time-out value
  409.           c30c = cn30                     !Current CN30 value
  410.           c33c = cn33                     !Current CN33 value
  411.           c34c = cn34                     !Current CN34 value
  412.       endif
  413.       goto 20
  414.  
  415. !     We come here if the LU is interactive but the driver won't do SSR.
  416. !     We decide it is a MUX LU if:
  417. !         It has 12 driver parameters (eliminates IO-mapped LUs)
  418. !         It has 57 DVT-extension words (eliminates ASIC LUs)
  419. !         DVP1 has bit 2 set (further eliminates ASIC LUs)
  420.  
  421. 10    dvta = AddressOf(lut)               !Get address of $LUTA
  422.       dvta = IxGet(dvta)                  !Get the address of the LUT
  423.       dvta = IxGet(dvta + syuc - 1)       !Get LU's DVT address
  424. !1.99a     dvta = IxGet(dvta)                  !Get the DVT address
  425.       a = IxGet(dvta + 20)                !Get DVP/DVX size word
  426.       b = a .and. 777b                    !Isolate the DVX size
  427.       a = ibits(a,9,7)                    !...and the DVP size
  428.       if (a .ne. 12) goto 20              !Terminals have 12 DVP words
  429.       timc = abs(IxGet(dvta+28))          !Get the current timeout value
  430.       if (b .ne. 57) then                 !MUX (IDM00) has 57 DVX words
  431.           trgc = IxGet(dvta + 29)         !Capture 1st word of pri prog name
  432.           v17c = IxGet(dvta + 33)         !...and 1st word of sec prog name
  433.           goto 20
  434.       endif
  435.       a = IxGet(dvta + 25)                !Get Driver Parameter #1
  436.       if (.not. btest(a,2)) goto 20       !DVP1 bit 2 must be set
  437.       imxc = 100000b                      !Flag as KERMIT-useable
  438.       trgc = IxGet(dvta + 27)             !Get the current trigger-character
  439.       dvxa = IxGet(dvta + 21)             !Get DVT-extension address
  440.       c30c = IxGet(dvxa + 40)             !Get the current CN30 value
  441.       c33c = IxGet(dvxa + 39)             !Get the current cn33 value
  442.       if (iand(c33c,177760b) .eq. 0) then !any configuration setup?
  443.           c33c = 52500b                   !No - set power-on defaults
  444.       endif
  445.       !Note: the cn34 parameter isn't needed with 12040B/C muxes
  446.  
  447.  20   call MoveWords(c30c,s30c,3)         !Copy current values to saves
  448.       call MoveWords(cnf,CnfArr,CnfSiz)   !Copy config back to caller
  449.       return
  450.  
  451.  30   call tpFm('Aborting: SSR-compatible driver rejected the SSR')
  452.       call quit
  453.  
  454.       end
  455.  
  456.       subroutine LogOff                                  ,<871015.1451>
  457.      >A/Log the server off
  458.       implicit none
  459.  
  460.       integer*2 sess,err,usnum
  461.  
  462. !     This routine differs from it's RTE-6 counterpart in that the jobs
  463. !     performed by the log-off program are completely different under
  464. !     RTE-A and under RTE-6.  Further, CLGOF doesn't exist for RTE-6!
  465.  
  466.       sess = usnum()                      !Get the session number
  467.       call Clgof(sess,2,err)              !Go to background (suppress msgs)
  468.       sess = usnum()                      !My session# has changed
  469.       call Clgof(sess,1,err)              !Now kill everything off.
  470.  
  471.       call exec(6)                        !(...and die, just in case)
  472.  
  473.       end
  474.