*COPY                                                 IK0PRO            07000000
         TITLE 'SERVER Routine - performs Server mode functions'        07001000
SERVER   ENTER                                                          07002000
         LA    0,SRVKFIN                                       @SC86295 07003000
         L     1,=A(SRVKCMD)                                   @SC87012 07004000
         BAL   14,LOOPS      Set up command loop               @SC86295 07005000
         KCALL INTINI,1,E=SRVXIT Initialize for server         @SC87300 07006000
         OI    FL2,SRV               Server is on                       07007000
         MVI   ERRNUM,ERRNOE No errors yet                     @SC86156 07008000
         BAL   8,SRVLUP      Set state table                   @SC86135 07009000
* Server mode Rpack interpret input table                      @SC86135 07010000
         DC    AL1(AS),AL3(SRVREC)  Micro wants to send a file @SC86135 07011000
         DC    AL1(AC),AL3(SRVHST)  A host command             @SC86171 07012000
         DC    AL1(AI),AL3(0)       Micro sent parms           @SC86135 07013000
         DC    AL1(AG),AL3(SRVGEN)  A generic command          @SC86135 07014000
         DC    AL1(AK),AL3(SRVKRM)  A KERMIT command           @SC86158 07015000
         DC    AL1(AR),AL3(SRVSND)  Micro wants to get a file  @SC86135 07016000
         DC    AL1(00),AL3(SRVILL)  Error routine              @SC86355 07017000
SRVLUP   MVI   SEQ,0         Reset packet number               @SC86135 07018000
         OI    FL1,NAK0              Resend NAK during retry            07019000
         MVC   SRVTIM,TIMOUT Save time-out limit               @SC86355 07020000
         MVI   TIMOUT,120    Set to 2 minutes                  @SC86355 07021000
         MVC   LIMTRY,F5     Error loop 5 times for command    @SC86355 07022000
         MVC   OLDERR,ERRNUM Save for STATUS                   @SC86158 07023000
         BAL   9,INPUT       Read a packet and interpret       @SC86295 07024000
         MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07025000
         KCALL SPARSET       Set up for exchange               @SC86152 07026000
         KCALL SPAR          Interpret I packet from other              07027000
         KCALL RPAR          Reply to the I packet                      07028000
         BAL   2,SENDACKL            Send an ACK, length set            07029000
         MVI   ERRNUM,ERRNOE OK                                @SC86158 07030000
         B     SRVLUP        Loop again no matter what                  07031000
*                                                                       07032000
SRVREC   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07033000
         XC    SCANPTR,SCANPTR                                 @SC86295 07034000
         LA    0,FFRCF                                         @SC86295 07035000
         KCALL FSPEC,FILNAM  Get filespec                      @SC86295 07036000
         KCALL INTINI,3,E=SRVXIT                               @SC87300 07037000
         KCALL RECEIV        Get the file                               07038000
         B     SRVLUP                End of file protocol               07039000
*                                                                       07040000
SRVSND   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07041000
         BAL   9,DECODEN     Decode the file name              @SC86295 07042000
         ICM   0,B'1111',WBUFL       decoded name length                07043000
         BNP   SRVIPS                                          @SC86158 07044000
         L     1,WBUF                Decoded data                       07045000
SRVSNT   STM   0,1,SCANPTR                                     @SC86295 07046000
         LA    0,FFSND                                         @SC86295 07047000
         KCALL FSPEC,IFILE,E=SRVERP   Get filespec             @SC86295 07048000
         XC    SCANPTR,SCANPTR                                 @SC86295 07049000
         LA    0,FFSND+FFRCF                                   @SC86295 07050000
         KCALL FSPEC,JFSPEC,E=SRVERP  Get filespec             @SC86295 07051000
SRVSNC   KCALL SEND                                                     07052000
         B     SRVLUP                Go around again                    07053000
*                                                                       07054000
SRVGEN   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07055000
         BAL   9,DECODEN     Decode the command                @SC86295 07056000
         ICM   0,15,WBUFL    Decoded command length            @SC86158 07057000
         BNP   SRVIPS                                          @SC86158 07058000
         MVI   ERRNUM,ERRNOE OK so far                         @SC86171 07059000
         BCTR  0,0           Remove command from data length   @SC86158 07060000
         L     1,WBUF        Decoded data                      @SC86158 07061000
         IC    4,0(1)                                          @SC86158 07062000
         BAL   2,CLKP        Dispatch on command               @SC86158 07063000
         DC    AL1(AC),AL3(SRVCWD)  cwd                        @SC86158 07064000
         DC    AL1(AD),AL3(SRVDIR)  directory                  @SC86158 07065000
         DC    AL1(AE),AL3(SRVDEL)  erase                      @SC86158 07066000
         DC    AL1(AF),AL3(SRVFIN)  finish                     @SC86158 07067000
         DC    AL1(AH),AL3(SRVHLP)  help                       @SC86158 07068000
         DC    AL1(AK),AL3(SRVCPY)  copy                       @SC86158 07069000
         DC    AL1(AL),AL3(SRVFIN)  bye                        @SC86158 07070000
         DC    AL1(AR),AL3(SRVREN)  rename                     @SC86158 07071000
         DC    AL1(AT),AL3(SRVTYP)  type                       @SC86158 07072000
         DC    AL1(AU),AL3(SRVQDS)  space                      @SC86158 07073000
         DC    AL1(00),AL3(SRVERS)  Unknown command            @SC86158 07074000
*                                                                       07075000
SRVILL   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07076000
SRVERS   MVI   ERRNUM,ERRUSC Unknown Server command            @SC86156 07077000
SRVERP   KCALL SUPFNC,5                                        @SC86158 07078000
         KCALL ERPACK        Send an error packet              @SC86158 07079000
         L     0,IOERC       I/O error count                   @SC86158 07080000
         CL    0,F5          Lots of consecutive errors?       @SC86158 07081000
         BL    SRVLUP        Not yet, OK                       @SC86158 07082000
         B     SRVXIT        Yes, give up now                  @SC86158 07083000
*                                                                       07084000
SRVIPS   MVI   ERRNUM,ERRIPS Invalid syntax                    @SC86158 07085000
         B     SRVERP                                          @SC86158 07086000
*                                                                       07087000
SRVHST   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07088000
         BAL   9,DECODEN     Get command for host              @SC86171 07089000
         BAL   9,SRVGPRW     To EBCDIC, start interception     @SC86295 07090000
         B     LUPHST        Do it                             @SC86295 07091000
*                                                                       07092000
SRVKRM   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07093000
         BAL   9,DECODEN     Get command for Kermit            @SC86295 07094000
         BAL   9,SRVGPRW     To EBCDIC, start interception     @SC86295 07095000
         B     LUPTOK        Parse command                     @SC87012 07096000
*                                                                       07097000
SRVKF0   MVI   ERRNUM,ERRNOE No errors                         @SC86295 07098000
SRVKFIN  MVC   OLDERR,ERRNUM Save error code                   @SC86295 07099000
         KCALL SUPFNC,2      Clean up after interception       @SC86295 07100000
SRVKFTX  LM    4,5,TXTPTR                                      @SC86158 07101000
         SR    5,4           Any?                              @SC86158 07102000
         LA    2,SRVLUP      Return adr                        @SC86158 07103000
         BNP   SENDACK       No, just ACK command              @SC86158 07104000
         LA    3,1023(5)     Round up                          @SC86158 07105000
         SRA   3,10          Convert to kbytes                 @SC86158 07106000
         ST    3,KBYTES                                        @SC86158 07107000
         OI    FL4,SFM+TXT                                     @SC86158 07108000
         KCALL SEND          Send all                          @SC86158 07109000
         CLI   ERRNUM,ERRNOE Problem with SEND?                @SC86295 07110000
         BNE   SRVLUP        Yes, remember that                @SC86295 07111000
         MVC   ERRNUM,OLDERR No, use code from commands        @SC86295 07112000
         B     SRVLUP        Get another command               @SC86158 07113000
*                                                                       07114000
SRVTYP   OI    FL4,TXT       Send disk file to remote display  @SC86158 07115000
         BAL   9,SRVGSTR     Get file-spec                     @SC86295 07116000
          B    SRVERP        None, error                       @SC86158 07117000
         B     SRVSNT                                          @SC86158 07118000
*                                                                       07119000
*        Send remote help message to other system              @SC86158 07120000
SRVHLP   LA    4,RMHTXT      Where to copy HELP TEXT from      @SC86158 07121000
         LA    5,RMHTXTZ     End of text                       @SC86158 07122000
         STM   4,5,TXTPTR                                      @SC86158 07123000
         B     SRVKFTX                                         @SC86158 07124000
*                                                                       07125000
SRVDIR   BAL   3,SRVUTL                                        @SC86295 07126000
         DC    AL1(13,4+1)   Wild matches                      @SC86295 07127000
*                                                                       07128000
SRVDEL   BAL   3,SRVUTL                                        @SC86295 07129000
         DC    AL1(14,0+1)   No wild matches                   @SC86295 07130000
*                                                                       07131000
SRVREN   BAL   3,SRVUTL                                        @SC86295 07132000
         DC    AL1(15,4+2)   Wild matches                      @SC86295 07133000
*                                                                       07134000
SRVCPY   BAL   3,SRVUTL                                        @SC86295 07135000
         DC    AL1(16,0+2)   No wild matches                   @SC86295 07136000
*                                                                       07137000
SRVCWD   BAL   9,SRVGSTR     Get operand                       @SC86295 07138000
          B    SRVERP                                          @SC86158 07139000
         BAL   9,SRVGPRM     Convert to plist                  @SC86295 07140000
         MVI   ERRNUM,ERRFNF In case of error                  @SC86158 07141000
         KCALL CWDSET,E=SRVERP                                 @SC86158 07142000
         B     SRVKF0        No errors                         @SC86295 07143000
*                                                                       07144000
SRVQDS   BAL   9,SRVGSTR     Extract letter                    @SC86295 07145000
          LA   0,0           None, use default                 @SC86158 07146000
         BAL   9,SRVGPRM                                       @SC86295 07147000
         B     LUPSPA                                          @SC86295 07148000
* Generate command PLIST: R3-> parms                           @SC86158 07149000
SRVUTL   LA    2,FILNAM      1st or only filespec              @SC86295 07150000
         LH    4,0(3)                                          @SC86295 07151000
         N     4,F3          Get number of names               @SC86295 07152000
SRVUTLP  XC    SCANPTR,SCANPTR                                 @SC86295 07153000
         BAL   9,SRVGSTR     Extract file-spec                 @SC86295 07154000
          B    SRVUT1        None, check if wildcard allowed   @SC86158 07155000
         STM   0,1,SCANPTR                                     @SC86295 07156000
SRVUT1   LA    0,FFUTL                                         @SC86295 07157000
         TM    1(3),4        Test flag                         @SC86295 07158000
         BZ    *+8                                             @SC86295 07159000
         LA    0,FFUTL+FFWLD Wild match if part omitted        @SC86295 07160000
         KCALL FSPEC,(2),E=SRVERP  Get filespec into command   @SC86295 07161000
         LR    0,6           Length remaining                  @SC86158 07162000
         LR    1,7           Next field                        @SC86158 07163000
         LA    2,IFILE       2nd ptr                           @SC86158 07164000
         BCT   4,SRVUTLP     Loop over file-specs              @SC86158 07165000
         KCALL SUPFNC,1      Start interception                @SC86158 07166000
         CLC   0(1,3),SRVDIR+4                                 @SC86158 07167000
         BE    SRVUT6        Don't issue STATE if DIR cmd      @SC86158 07168000
         MVI   ERRNUM,ERRFNF Assume not found                  @SC86158 07169000
         OPENF T,FILNAM,E=SRVERP                               @SC86295 07170000
SRVUT6   LA    1,FILNAM      1st or only filespec              @SC86295 07171000
         LA    2,IFILE       Possible 2nd                      @SC86295 07172000
         XR    0,0                                             @SC86295 07173000
         IC    0,0(3)                                          @SC86295 07174000
         KCALL DISKIO                                          @SC86295 07175000
         CLI   ERRNUM,ERRNOE Problem?                          @SC86295 07176000
         BNE   SRVERP        Yes, too bad                      @SC86295 07177000
         B     SRVKFIN                                         @SC86295 07178000
* Get substring from Generic command                           @SC86158 07179000
* R0= no. of chars left in packet excluding substr count byte  @SC86158 07180000
* R1-> one before count byte                                   @SC86158 07181000
SRVGSTR  MVI   ERRNUM,ERRMOP Assume missing operand            @SC86158 07182000
         BCTR  0,0           Remove operand length field       @SC86158 07183000
         LA    7,1(1)        ditto                             @SC86158 07184000
         LTR   6,0           If no operands                    @SC86158 07185000
         BNPR  9              then return error                @SC86295 07186000
         UNCHR 0,1(1)        Operand size                      @SC86158 07187000
         BZR   9             Error if zero length field        @SC86295 07188000
         BM    SRVIPS        Really bad                        @SC86158 07189000
         LA    1,2(1)        Location of operand               @SC86158 07190000
         AR    7,0           Get ptr to next field             @SC86158 07191000
         SR    6,0           Length remaining                  @SC86158 07192000
         BM    SRVIPS        Inconsistant                      @SC86158 07193000
         B     4(9)                                            @SC86295 07194000
* Set up copy                                                           07195000
SRVGPRW  ICM   0,15,WBUFL                                      @SC86171 07196000
         BNP   SRVIPS        No text                           @SC86171 07197000
         L     1,WBUF        Ptr to text                       @SC86171 07198000
* Copy parameter at (R1), length in R0 and set up interception @SC86158 07199000
SRVGPRM  LTR   15,0          Any chars?                        @SC86171 07200000
         BNP   SRVGPS        No                                @SC86171 07201000
         BCTR  15,0          Yes, translate                    @SC86171 07202000
         EX    15,TRATOE                                       @SC86171 07203000
         EX    15,TRUPCAS                                      @SC86171 07204000
SRVGPS   STM   0,1,SCANPTR   Save string ptrs                  @SC86158 07205000
         KCALL SUPFNC,1      Start intercepting                @SC86158 07206000
         BR    9                                               @SC86295 07207000
*                                                                       07208000
SRVFIN   MVI   WRRD,0                Just write (no read) when ending   07209000
         MVC   S1HND,SVHND   Always use requested handshake    @SC87343 07210000
         BAL   2,SENDACK             Send an ACK                        07211000
         L     1,WBUF        Ptr to decoded data               @SC86190 07212000
         CLI   0(1),AL                                         @SC86190 07213000
         BNE   SRVNOLOG      Skip logging out                  @SC86295 07214000
         CLOSF LOGPTR        Close debug-log                   @SC86135 07215000
         KCALL SUPFNC,8      Log out                           @SC86295 07216000
SRVNOLOG DS    0H            (or fall through just in case)    @SC86295 07217000
         MVC   ERRNUM,OLDERR Copy back error number            @SC86171 07218000
SRVXIT   NI    FL2,255-SRV   Turn off SERVER mode              @SC86158 07219000
         KCALL INTINI,0      Clear interrupt trapping                   07220000
         RET                                                            07221000
*                                                                       07222000
RMHTXT   DC    C'Kermit-&KSYS. Server handles the following:'  @SC86268 07223000
         DC    X'1515'                                         @SC86158 07224000
         DC C'Function          Standard command',X'15'        @SC86158 07225000
         DC C'--------          ----------------',X'1515'      @SC86158 07226000
         DC C'Send a file       SEND file',X'15'               @SC86158 07227000
         DC C'Retrieve a file   GET file',X'15'                @SC86158 07228000
         DC C'Log off system    BYE or LOGOUT',X'15'           @SC86158 07229000
         DC C'Exit from server  FINISH',X'15'                  @SC86158 07230000
         DC C'Issue Kermit cmd  REMOTE KERMIT cmd',X'15'       @SC86158 07231000
         DC C'Issue system cmd  REMOTE HOST [CP] cmd',X'15'    @SC86268 07232000
         DC C'List directory    REMOTE DIRECTORY file',X'15'   @SC86158 07233000
         DC C'Type a file       REMOTE TYPE file',X'15'        @SC86158 07234000
         DC C'Copy a file       REMOTE COPY f1 f2',X'15'       @SC86158 07235000
         DC C'Rename a file     REMOTE RENAME f1 f2',X'15'     @SC86158 07236000
         DC C'Erase a file      REMOTE DELETE file',X'15'      @SC86158 07237000
         DC C'Change disk area  REMOTE CWD area',X'15'         @SC86158 07238000
         DC C'Show disk space   REMOTE SPACE area',X'15'       @SC86158 07239000
RMHTXTZ  EQU   *                                               @SC86158 07240000
         LOCALS ,                                              @SC86295 07241000
RETADR   DS    A             Return adr if no more TAKE stuff  @SC86295 07242000
CMDPTR   DS    A             Adr of command table              @SC86295 07243000
TAKLEV   DS    F             Take file level                   @SC86121 07244000
TAKTAB   DS    (TAKMAX)F     Tickets for I/O                   @SC86295 07245000
SRVTIM   DS    X             Saved timeout limit               @SC86355 07246000
SERVER   EXIT                                                           07247000
         TITLE 'SEND Routine - sends a file'                            07248000
* Send file(s) and set ERRNUM appropriately                             07249000
* Entry: filespec pattern in IFILE                                      07250000
SEND     ENTER                                                          07251000
         XC    TOUTOT(LSTATS),TOUTOT Clear statistics          @SC86295 07252000
         KCALL SUPFNC,10                                       @SC86295 07253000
         ST    15,SECTOT     Save start time                   @SC86295 07254000
         TM    FL4,SFM                                         @SC86295 07255000
         BO    *+10          From memory: keep old file list   @SC86295 07256000
         XC    NSENT,NSENT           Number of files sent               07257000
         MVI   SNFLG,FIRST   Haven't started yet               @SC86295 07258000
         XC    FDATE,FDATE   Clear file date                   @SC86295 07259000
         LA    0,30          Tune up after 30 packets          @SC86345 07260000
         STH   0,SNPKCT                                        @SC86345 07261000
         MVI   REASON,0      Not rejected yet                  @SC86316 07262000
         MVI   SEQ,0         Reset packet number               @SC86135 07263000
       NXTFSET IFILE,E=SNDNON Init for NXTFST call             @SC87012 07264000
         BAL   8,SNDNXT      Set state table                   @SC86135 07265000
* Send mode Rpack interpret input table                        @SC86135 07266000
SNDNST   DC    AL1(AY),AL3(0)        Micro ACK'd               @SC86295 07267000
         DC    AL1(00),AL3(SNDABR)   Error routine             @SC86135 07268000
SNDNXT   CLI   CXZ,AZ                                                   07269000
         BE    SNDBRK        Stop file group send                       07270000
         MVI   FRECF,C'F'    Just in case                      @SC86151 07271000
         TM    FL4,SFM                                         @SC86158 07272000
         BO    SNDNOW        Just sending from memory          @SC86158 07273000
         NXTF  E=SNDNON      Get next/first file               @SC86295 07274000
         MVI   CXZ,0                 In case aborted last file          07275000
         MVI   REASON,0      Not rejected yet                  @SC86316 07276000
         L     5,TSENT               TABLE W/FILES SENT SO FAR          07277000
         ICM   4,B'1111',NSENT       Number of files sent so far        07278000
         AIF   ('&KSYS' NE 'CMS').SOPN                         @SC86295 07279000
         BZ    SNDOPN        Go if none sent yet               @SC86295 07280000
SNDTBL   CLC   0(16,5),FILNAM                                  @SC86295 07281000
         BE    SNDNXT                Go if sent already                 07282000
         LA    5,LFID(5)     Next file                         @SC86295 07283000
         BCT   4,SNDTBL                                                 07284000
.SOPN    ANOP                                                           07285000
SNDOPN   OPENF I,FILNAM,FILFDB,FILPTR,E=SNDFNF                 @SC87012 07286000
         USING FDBD,1                                          @SC86295 07287000
         MVC   FRECF,FDBRCF  Save format and file size         @SC86295 07288000
         MVC   KBYTES,FDBSIZE                                  @SC86295 07289000
         MVC   FDATE,FDBDATE Save file date                    @SC86295 07290000
         DROP  1                                               @SC86295 07291000
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07292000
         BE    SNDNOW        No, be quiet                      @SC87300 07293000
         MVC   CMD(8),=CL8'Sending '  Yes, display message     @SC87300 07294000
         LA    7,CMD+8                                         @SC87300 07295000
         LA    1,FILNAM                                        @SC87300 07296000
         BAL   2,STAFSP      Format name and show it           @SC87300 07297000
SNDNOW   TM    SNFLG,FIRST                                     @SC86295 07298000
         BZ    SNDFIL                Go if not first file               07299000
         NI    SNFLG,255-FIRST No first file flag              @SC86295 07300000
         MVC   LIMTRY,MAXTNT Limit for INIT retries            @SC86345 07301000
         TM    FL4,NPS       Non-protocol?                     @HF86232 07302000
         BZ    SNDPRO        No, normal send message           @HF86232 07303000
         KCALL INTINI,5,E=SNDRET  Initialize for non-protocol  @SC87300 07304000
         B     SNDATZ        Skip protocol stuff               @HF86232 07305000
SNDPRO   KCALL INTINI,2,E=SNDRET  Initialize for send          @SC87300 07306000
         TM    FL2,SRV                                                  07307000
         BO    SNDINI                Go if Server mode                  07308000
         L     0,LCLDLY      Time to wait                      @SC86164 07309000
         KCALL SUPFNC,9                                        @SC86295 07310000
SNDINI   DS    0H                                              @SC86152 07311000
         KCALL RPARSET       Set up for exchange               @SC86152 07312000
         KCALL RPAR          Our S packet to send              @SC86152 07313000
         MVI   STYPE,AS              PACKET TYPE = SEND INITIATE        07314000
         BAL   9,INPUTSPK    Send RPAR and Interpret response  @SC86295 07315000
         KCALL SPAR          Interpret reply to our S packet            07316000
         MVC   BCTU,BCTR             Switch chksum to negotiated one    07317000
         MVC   LIMTRY,MAXTRY Reset limit                       @SC86164 07318000
         BAL   14,INCRSEQ                                               07319000
SNDFIL   MVI   STYPE,AX      Text transmission?                @SC86158 07320000
         TM    FL4,TXT                                         @SC86158 07321000
         BO    *+8           Yes                               @SC86158 07322000
         MVI   STYPE,AF      Packet type = file header         @SC86158 07323000
         XC    DATL,DATL     Null file spec.                   @SC86158 07324000
         TM    FL4,SFM                                         @SC86158 07325000
         BNZ   SNDCNTH       From memory, no file name         @SC86158 07326000
         BAL   9,PAKFIL      Compress to buffer with appends   @HF86223 07327000
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07328000
         BE    SNDFIL2       No, be quiet                      @SC87300 07329000
         MVC   CMD(5),=CL5'  as '  Yes, display message        @SC87300 07330000
         L     1,RBUF        Ptr to name in ASCII              @SC87300 07331000
         MVC   CMD+5(250),0(1)                                 @SC87300 07332000
         TR    CMD+5(250),ATOE Back to EBCDIC                  @SC87300 07333000
         LA    0,CMD+5(7)    End of msg + name                 @SC87300 07334000
         BAL   2,STAPMSG     Show sending name                 @SC87300 07335000
SNDFIL2  DS    0H                                              @SC87300 07336000
         L     3,NSENT               Number of files sent so far        07337000
         LR    4,3                   Ditto                              07338000
         C     3,=A(MAXNSENT) Did we send more than countable? @SC86135 07339000
         BNL   SNDCNT                Yes, cannot keep track of 'em      07340000
         MH    3,=Y(LFID)    Times length of items             @SC86295 07341000
         A     3,TSENT               Loc in sent-table                  07342000
         MVC   0(LFID,3),FILNAM Save fn ft sent                @SC86295 07343000
         LA    4,1(4)                Incr number of sent files          07344000
         ST    4,NSENT               Keep it                            07345000
SNDCNT   BAL   9,ENCODEN     Encode fn                         @SC86295 07346000
SNDCNTH  BAL   9,INPUTSPK    Send name and interpret response  @SC86295 07347000
         BAL   14,INCRSEQ                                               07348000
         MVC   TMP,SCAPA     Copy my flags                     @SC86149 07349000
         NI    TMP,8         Attributes                        @SC86149 07350000
         NC    TMP,RCAPA     Check if both on                  @SC86149 07351000
         BZ    SNDATZ        No, skip it                       @SC86149 07352000
         L     5,ASDATA                                        @SC86295 07353000
         ICM   4,15,KBYTES   File length known?                @SC86295 07354000
         BZ    SNDAT0        No, skip it                       @SC86316 07355000
         MVI   0(5),C'!'     Yes                               @SC86295 07356000
         LA    15,2(5)                                         @SC86295 07357000
         BAL   2,EDDEC       Format it                         @SC86295 07358000
         SR    15,5                                            @SC86295 07359000
         IC    4,ATOE+ABL-2(15) Indicate number of digits      @SC86295 07360000
         STC   4,1(5)                                          @SC86295 07361000
         AR    5,15          End of string                     @SC86295 07362000
SNDAT0   MVC   0(L'SYSATR,5),SYSATR                            @SC86316 07363000
         LA    5,L'SYSATR(5) System code                       @SC86295 07364000
         MVC   0(3,5),=C'"!B' Say it's binary                  @SC86316 07365000
         TM    FL1,BINF      Binary file?                      @SC86149 07366000
         BO    SNDAT1        Yes                               @SC86316 07367000
         MVC   2(4,5),=C'A*!A'  No, also say it's ASCII        @SC86316 07368000
         LA    5,3(5)        Advance over extra item           @SC86316 07369000
SNDAT1   LA    5,3(5)                                          @SC86316 07370000
         IC    4,TYPFIL      Specific file type                @SC86295 07371000
         BAL   2,CLKP        Dispatch via table                @SC86295 07372000
         DC    C'T',AL3(SNDATT)  Text                          @SC86295 07373000
         DC    C'D',AL3(SNDATD)  D-binary                      @SC86295 07374000
         DC    C'V',AL3(SNDATV)  V-binary                      @SC86295 07375000
         DC    X'0',AL3(SNDAT3)  Must be Binary                @SC86295 07376000
SNDATT   BAL   2,SNDAT2                                        @SC86295 07377000
         DC    AL1(3),C'AMJ' Format is delimited               @SC86295 07378000
SNDATD   BAL   2,SNDAT2                                        @SC86295 07379000
         DC    AL1(2),C'D%'  Format is undelimited             @SC86316 07380000
SNDATV   BAL   2,SNDAT2                                        @SC86295 07381000
         DC    AL1(2),C'V"'  Format is 2-byte binary prefix    @SC86295 07382000
SNDAT2   MVI   0(5),C'/'     Format                            @SC86295 07383000
         MVC   1(9,5),0(2)   Copy string                       @SC86295 07384000
         TR    1(1,5),ATOE+ABL Convert to char                 @SC86295 07385000
         SR    4,4                                             @SC86295 07386000
         IC    4,0(2)        Get length                        @SC86295 07387000
         LA    5,2(4,5)      Update string ptr                 @SC86295 07388000
SNDAT3   CLI   FDATE,0       File date defined?                @SC86295 07389000
         BE    SNDAT9        No, skip it                       @SC86295 07390000
         MVC   0(2,5),=C'#(' Yes, use yyyymmdd                 @SC86295 07391000
         UNPK  2(9,5),FDATE(5) Insert zones                    @SC86295 07392000
         LA    5,10(5)       Update ptr                        @SC86295 07393000
SNDAT9   L     15,ASDATA                                       @SC86295 07394000
         SR    5,15                                            @SC86295 07395000
         TR    0(256,15),ETOA Convert to ASCII                 @SC86295 07396000
         ST    5,DATL        Set length                        @SC86295 07397000
         LA    8,SNDNST      Restore state ptr                 @SC86295 07398000
         MVI   STYPE,AA                                        @SC86149 07399000
         BAL   9,INPUTSPK    Send it                           @SC86295 07400000
         BAL   14,INCRSEQ                                      @SC86149 07401000
         CLC   DATL,F0       Any objections?                   @SC86149 07402000
         BE    SNDATZ        Ok                                @SC86149 07403000
         L     1,ARDATA                                        @SC86316 07404000
         CLI   0(1),AN       Refused?                          @SC86149 07405000
         BE    SNDCAN        Sigh                              @SC86149 07406000
SNDATZ   DS    0H                                              @SC86149 07407000
         NI    FL1,255-EOF           Not end of file yet                07408000
         BAL   14,RDWSET     Check for special format          @SC86151 07409000
         XC    RBUFL,RBUFL           No data in input buffer            07410000
         TM    FL4,NPS       Non-protocol?                     @SC86165 07411000
         BO    SNDNPS        Yes, do it                        @SC86165 07412000
SNDENC   KCALL ENCODE,E=SNDENX Encode the data and more                 07413000
SNDDAT   MVI   STYPE,AD              PACKET TYPE = DATA                 07414000
         BAL   9,INPUTSPK    Send data and interpret reply     @SC86295 07415000
         BAL   14,INCRSEQ                                               07416000
         LH    15,SNPKCT                                       @SC86345 07417000
         BCT   15,SNDTUNZ    No tuning yet                     @SC86345 07418000
         CLC   MAXSIZ+4,AKMAX Long packets selected?           @SC86345 07419000
         BNP   SNDTUNY       No                                @SC86345 07420000
         BAL   9,OPTPKT      Calculate optimum size            @SC86345 07421000
         LTR   15,15         Valid?                            @SC86345 07422000
         BNP   SNDTUNY       No                                @SC86345 07423000
         C     15,MAXSIZ+4   Other Kermit's limit              @SC86345 07424000
         BNH   *+8                                             @SC86345 07425000
         L     15,MAXSIZ+4                                     @SC86345 07426000
         C     15,AKMAX                                        @SC86345 07427000
         BNL   *+8                                             @SC86345 07428000
         L     15,AKMAX      Don't get too small               @SC86345 07429000
         ST    15,MAXSIZ     Set send limit                    @SC86345 07430000
SNDTUNY  LA    15,20         Repeat after 20 more              @SC86345 07431000
SNDTUNZ  STH   15,SNPKCT                                       @SC86345 07432000
         CLC   DATL,F1                                                  07433000
         BNE   SNDENC                Go if no Data in ack               07434000
         L     1,ARDATA                                        @SC86190 07435000
         CLI   0(1),AX                                         @SC86190 07436000
         BE    SNDCAN                Go if Abort sending file           07437000
         CLI   0(1),AZ                                         @SC86190 07438000
         BNE   SNDENC                Go if not Abort sending grp        07439000
SNDCAN   MVC   CXZ,0(1)      Pick up data                      @SC86190 07440000
         MVI   ERRNUM,ERRTRC Send cancelled                    @SC86156 07441000
         CLC   DATL,F2       Any reason given (if A-pkt)       @SC86316 07442000
         BL    SNDEOF        None                              @SC86316 07443000
         UNCHR 2,1(1),REASON Yes, save it                      @SC86316 07444000
SNDEOF   BAL   9,SNDCLS      Close file                        @SC86295 07445000
         MVI   STYPE,AZ              PACKET TYPE = EOF                  07446000
         XC    DATL,DATL                                                07447000
         L     9,ASDATA                                        @SC86295 07448000
         MVI   0(9),AD       In case of discard                @SC86295 07449000
         CLI   CXZ,0         Aborting this file?               @SC86125 07450000
         BE    *+8           No, ok                            @SC86125 07451000
         MVI   DATL+3,1      Yes, send 'D'                     @SC86125 07452000
         BAL   9,INPUTSPK    Send EOF and Interpret response   @SC86295 07453000
         BAL   14,INCRSEQ                                               07454000
         TM    FL4,SFM                                         @SC86158 07455000
         BO    SNDBRK        Memory has only one 'file'        @SC86158 07456000
         B     SNDNXT                else GET-NEXT-FILE                 07457000
*                                                                       07458000
SNDNPS   MVI   WRRD,0        Set for send only                 @SC86165 07459000
SNDNPSL  KCALL NPREAD,E=(SNDABR,P)                             @SC86165 07460000
         CLC   SNDPKL,F0     OK, any data?                     @SC86165 07461000
         BE    SNDNPZ        No, must be done                  @SC86165 07462000
         KCALL SIO,E=SNDABR  Send what we got                  @SC86165 07463000
         TM    FL1,EOF       Any more?                         @SC86165 07464000
         BZ    SNDNPSL       Yes, get it                       @SC86165 07465000
SNDNPZ   BAL   9,SNDCLS      Reached end                       @SC86295 07466000
         B     SNDBR2        All done                          @SC86165 07467000
*                                                                       07468000
SNDENX   LTR   15,15                 Positive or negative error?        07469000
         BP    SNDABR                Pos: error from ENCODE, not EOF    07470000
         CLC   DATL,F0                                                  07471000
         BE    SNDEOF                No more data to send               07472000
         B     SNDDAT                Send last chunk                    07473000
*                                                                       07474000
SNDNON   TM    SNFLG,FIRST                                     @SC86295 07475000
         BZ    SNDBRK                Go if not first file               07476000
SNDFNF   MVI   ERRNUM,ERRFNF Not found                         @SC87012 07477000
         TM    FL2,SRV                                                  07478000
         BO    SNDABR                Go if server                       07479000
         B     SNDRET                                          @SC86295 07480000
*                                                                       07481000
SNDBRK   MVI   STYPE,AB              PACKET TYPE = BREAK                07482000
         XC    DATL,DATL                                                07483000
         BAL   9,INPUTSPK    Send BRK and Interpret response   @SC86295 07484000
SNDBR2   DS    0H                                              @SC86165 07485000
         MVI   ERRNUM,ERRNOE Reset error (OK)                  @SC86156 07486000
         CLI   CXZ,0                                                    07487000
         BE    SNDRET                Go if x-fer not stopped            07488000
         MVI   ERRNUM,ERRTRC Set this anyway                   @SC86156 07489000
SNDABR   BAL   9,SNDCLS      Close disk file                   @SC86295 07490000
         TM    FL4,NPS       Non-protocol?                     @SC86165 07491000
         BO    SNDRET        Yes, skip error packet            @SC86165 07492000
         KCALL ERPACK        Send error packet                          07493000
SNDRET   NI    FL4,255-NPS-SFM-TXT                             @SC86165 07494000
         B     RETSNRC       Close statistics and return       @SC86295 07495000
*                                                                       07496000
SNDCLS   TM    FL4,SFM       Text xmit?                        @SC86158 07497000
         BOR   9             Yes, no disk file                 @SC86295 07498000
         CLOSF FILPTR        Close it                          @SC86158 07499000
         BR    9                                               @SC86295 07500000
         LOCALS ,                                              @SC86295 07501000
SNPKCT   DS    H             Cyclic counter for tuning         @SC86345 07502000
CXZ      DS    X             Flag for aborted transmission     @SC86295 07503000
SNFLG    DS    X             More local flags                  @SC86295 07504000
FIRST    EQU   X'80'         File is the first one             @SC86295 07505000
SEND     EXIT                                                           07506000
         TITLE 'RECEIV Routine - receives a file'                       07507000
* Receive file(s) and set ERRNUM appropriately                          07508000
* Entry: filespec in FILNAM if ROVR is set                              07509000
RECEIV   ENTER                                                          07510000
         XC    TOUTOT(LSTATS),TOUTOT Clear statistics          @SC86295 07511000
         KCALL SUPFNC,10                                       @SC86295 07512000
         ST    15,SECTOT     Save start time                   @SC86295 07513000
         MVI   SEQ,0         Reset packet number               @SC86135 07514000
         KCALL SPARSET       Set up for exchange               @SC86152 07515000
         LA    8,RECINST             Next state table for RECEIVE I     07516000
         MVC   LIMTRY,MAXTNT Limit for INIT retries            @SC86345 07517000
         TM    FL2,SRV                                                  07518000
         BO    RECSRV                Go if in server                    07519000
         KCALL RPACK         Get init info                              07520000
RECSRV   SR    3,3                   Clear retry counter for INPUTLUP   07521000
         BAL   9,INPUTINR    Interpret response to RPAC        @SC86295 07522000
         KCALL SPAR          Interpret his S packet                     07523000
         KCALL RPAR          Reply to the S packet                      07524000
         BAL   2,SENDACKL            Send an ACK, length set            07525000
         MVC   BCTU,BCTR             Restore desired chksum             07526000
         MVC   LIMTRY,MAXTRY Set retry limit                   @SC86164 07527000
         BAL   14,INCRSEQ                                               07528000
RECFIL   LA    8,RECFNST             Next state table for RECEIVE F     07529000
         BAL   9,INPUT       Read a packet and interpret       @SC86295 07530000
         NI    RFLG,255-RTRC-RRJC Clear each time              @SC86316 07531000
         MVI   REASON,0                                                 07532000
         NI    FL1,255-EOF           Turn of EOF = no ctl-z seen        07533000
         TM    FL1,ROVR                                                 07534000
         BO    RECOVR                Overwrite the name sent?           07535000
         BAL   9,DECODEN     Decode the input                  @SC86295 07536000
         L     1,WBUF                Start of data                      07537000
         L     0,WBUFL               Data length decoded                07538000
         TR    0(256,1),ATOE         First to EBCDIC                    07539000
         STM   0,1,SCANPTR   Set up scan                       @SC86295 07540000
         MVC   CMD+5(250),0(1)  Extra copy for display         @SC87300 07541000
         LA    0,FFHDR                                         @SC86295 07542000
         KCALL FSPEC,FILNAM                                    @SC86295 07543000
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07544000
         BE    RECOVR        No, be quiet                      @SC87300 07545000
         MVC   CMD(5),=CL5'File '  Yes, display message        @SC87300 07546000
         LA    0,CMD+5                                         @SC87300 07547000
         A     0,WBUFL                                         @SC87300 07548000
         BAL   2,STAPMSG     Show name                         @SC87300 07549000
RECOVR   LA    3,FILNAM              Point to fn                        07550000
         TM    FL3,APPN      Appending to old files?           @SC86203 07551000
         BO    RECOPN        Yes, just do it                   @SC86295 07552000
         TM    FL1,REN                                                  07553000
         BZ    RECOPN        No, just do it                    @SC86295 07554000
         LA    0,FFNEW                                         @SC86295 07555000
         KCALL FSPEC,FILNAM,E=RECRER Check collisions          @SC86295 07556000
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07557000
         BE    RECOPN        No, be quiet                      @SC87300 07558000
         MVC   CMD(9),=CL9'  Rcv as '  Yes, display message    @SC87300 07559000
         LA    7,CMD+9                                         @SC87300 07560000
         LA    1,FILNAM                                        @SC87300 07561000
         BAL   2,STAFSP      Format name and show it           @SC87300 07562000
RECOPN   XC    FILFLGS,FL3   Set flag for DISP                 @SC86295 07563000
         NI    FILFLGS,255-APPN                                @SC86295 07564000
         XC    FILFLGS,FL3                                     @SC86295 07565000
         OPENF O,FILNAM,FILFDB,FILPTR,E=RECRER                 @SC86295 07566000
         USING FDBD,1                                          @SC86295 07567000
         SR    0,0                                             @SC86295 07568000
         ICM   0,3,FDBLRC                                      @SC86295 07569000
         ST    0,FSIZE       Copy LRECL                        @SC86295 07570000
         MVC   FRECF,FDBRCF  Save info                         @SC86295 07571000
         DROP  1                                               @SC86295 07572000
         BAL   14,RDWSET     Check for special format          @SC86295 07573000
         BAL   2,SENDACK                                                07574000
         XC    WBUFL,WBUFL           Data length in WBUF                07575000
         MVI   PREV,0                Char previously decoded            07576000
         LA    8,RECANST     State table: REC D or A           @SC86149 07577000
RECDAT   BAL   14,INCRSEQ                                      @SC86316 07578000
         BAL   9,INPUT       Read a packet and interpret       @SC86295 07579000
         LA    8,RECDNST     Next state table: REC D only      @SC86149 07580000
         KCALL DECODE,E=RECABR Decode and write to file        @SC86316 07581000
RECDAK   BAL   2,SENDACK     Send an ack                       @SC86149 07582000
         B     RECDAT                                                   07583000
*                                                                       07584000
RECCKA   L     2,ARDATA      Attributes                        @SC86316 07585000
         LR    5,2           Save start                        @SC86316 07586000
         L     3,DATL        Get length                        @SC86316 07587000
         LA    15,ATOE                                         @SC86316 07588000
         BAL   14,TRANSLAT   Convert to EBCDIC                 @SC86316 07589000
         LR    3,2           Save end                          @SC86316 07590000
         MVI   ERRNUM,ERRIPS In case of error                  @SC86316 07591000
RECCKL   CR    5,3           Another attribute?                @SC86316 07592000
         BNL   RECDAK        No, done                          @SC86316 07593000
         LR    6,5                                             @SC86316 07594000
         IC    4,0(6)        Get code                          @SC86316 07595000
         SR    5,5                                             @SC86316 07596000
         IC    5,1(6)        Get length of value               @SC86316 07597000
         UNCHR 7,ETOA(5)                                       @SC86316 07598000
         BM    RECABR        Invalid: length was <0            @SC86316 07599000
         LA    6,2(6)        Space over code+length            @SC86316 07600000
         LA    5,0(7,6)      Next field                        @SC86316 07601000
         CR    5,3           Does it match?                    @SC86316 07602000
         BH    RECABR        Overflows data                    @SC86316 07603000
         BAL   2,CLKP                                          @SC86316 07604000
         DC    C'!',AL3(RECALN) File length                    @SC86316 07605000
         DC    X'0',AL3(RECCKL) Other                          @SC86316 07606000
RECALN   BAL   14,GETNUM     Get file length                   @SC86316 07607000
          B    RECABR                                          @SC86316 07608000
         LR    2,0                                             @SC86316 07609000
         LA    0,11          Ask for length check              @SC86316 07610000
         KCALL DISKIO,FILPTR,E=RECRJC                          @SC86316 07611000
         B     RECCKL        Ok, keep looking                  @SC86316 07612000
*                                                                       07613000
RECRJC   LA    8,RECZNST     Now accept only EOF pkt           @SC86316 07614000
         L     9,ASDATA      Output buffer                     @SC86316 07615000
         MVI   0(9),C'N'     Mark it rejected                  @SC86316 07616000
         S     6,F2          Back up to attribute code         @SC86316 07617000
         MVC   1(1,9),0(6)   Copy to output                    @SC86316 07618000
         TR    0(2,9),ETOA   ASCIIify                          @SC86316 07619000
         UNCHR 0,1(9),REASON                                   @SC86316 07620000
         OI    RFLG,RRJC     Mark it rejected                  @SC86316 07621000
         MVC   DATL,F2       Data = 'N' + code                 @SC86316 07622000
         BAL   2,SENDACKL    Acknowledge                       @SC86316 07623000
         B     RECDAT        And wait for EOF                  @SC86316 07624000
*                                                                       07625000
RECEOF   CLC   DATL,F1                                                  07626000
         BNE   RECWR                 One piece of data                  07627000
         L     1,ARDATA                                        @SC86190 07628000
         CLI   0(1),AD                                         @SC86190 07629000
         BNE   RECWR                 Go if not discard                  07630000
         CLOSF FILPTR        Close the file                    @SC86135 07631000
         TM    FL3,APPN      Appending to old file?            @SC86225 07632000
         BO    RECKEP        Yes, keep what we got             @SC86225 07633000
         TM    FL5,KEEP                                        @SC86225 07634000
         BO    RECKEP        Don't delete it anyway            @SC86225 07635000
         ERASF FILNAM        And delete it                     @SC86295 07636000
RECKEP   MVI   ERRNUM,ERRTRC Receive cancelled                 @SC86225 07637000
         OI    RFLG,RTRC     Remember that                     @SC86295 07638000
         B     RECACK                Pick up later on                   07639000
* If data left in buffer when we get EOF, write remaining data.         07640000
RECWR    CLC   WBUFL,F0                                                 07641000
         BE    RECCLO                No data in WBUF, send Ack          07642000
         KCALL OUTBUF,E=RECABR Write out buffer                         07643000
RECCLO   CLOSF FILPTR        Close it                          @SC86135 07644000
RECACK   BAL   2,SENDACK             Send an ACK                        07645000
         BAL   14,INCRSEQ                                               07646000
         NI    FL1,255-ROVR          Only change first file             07647000
         B     RECFIL                                                   07648000
*                                                                       07649000
RECBRK   TM    FL2,SRV       Server will read another command  @SC87343 07650000
         BO    *+8            so don't zap write/read flag     @SC87343 07651000
         MVI   WRRD,0        No read for Ack'ing BRK pkt       @SC87343 07652000
         BAL   2,SENDACK             Send an ACK                        07653000
         MVI   ERRNUM,ERRNOE Reset error                       @SC86156 07654000
         TM    RFLG,RTRC+RRJC                                  @SC86295 07655000
         BZ    RECRET        OK                                @SC86295 07656000
         MVI   ERRNUM,ERRTRC Receive cancelled                 @SC86156 07657000
         B     RECABR                                                   07658000
*                                                                       07659000
RECBAD   MVI   ERRNUM,ERRFNE Illegal filename                  @SC86156 07660000
         B     RECABR                                                   07661000
*                                                                       07662000
RECRER   ERRF  ,             Cannot write. Analyze error       @SC87338 07663000
RECABR   CLOSF FILPTR        Close open file                   @SC86135 07664000
         KCALL ERPACK        Send error packet                 @SC86316 07665000
RECRET   ICM   0,15,RECTRC   Any records truncated?            @SC87268 07666000
         BZ    RETSNRC       None                              @SC87268 07667000
         CLI   ERRNUM,0                                        @SC87268 07668000
         BNE   *+8           Already got some (worse) error    @SC87268 07669000
         MVI   ERRNUM,ERRRTR Indicate error                    @SC87268 07670000
         B     RETSNRC       Close statistics and return       @SC87268 07671000
* Receive mode Rpack interpret input tables                             07672000
RECINST  DC    AL1(AS),AL3(0)        Micro sent parm                    07673000
         DC    AL1(00),AL3(RECABR)   Error routine                      07674000
RECFNST  DC    AL1(AF),AL3(0)        Micro sent a filename              07675000
         DC    AL1(AX),AL3(0)        Micro sent a filename     @SC86155 07676000
         DC    AL1(AB),AL3(RECBRK)   Micro sent end of transaction      07677000
         DC    AL1(00),AL3(RECABR)   Error return                       07678000
RECANST  DC    AL1(AA),AL3(RECCKA)   Micro sent A-packet       @SC86316 07679000
RECDNST  DC    AL1(AD),AL3(0)        Micro sent data                    07680000
RECZNST  DC    AL1(AZ),AL3(RECEOF)   Micro sent EOF            @SC86316 07681000
         DC    AL1(00),AL3(RECABR)   Error return                       07682000
         LOCALS ,                                              @SC86295 07683000
RFLG     DS    X             Local flags                       @SC86295 07684000
RTRC     EQU   X'80'         Other side cancelled              @SC86295 07685000
RRJC     EQU   X'40'         I cancelled                       @SC86316 07686000
RECEIV   EXIT                                                           07687000
         TITLE 'SPAR Routine - use parms from other host in DATA'       07688000
SPAR     ENTER                                                          07689000
         L     7,DATL        Data length                       @SC86120 07690000
         L     5,ARDATA      Point to data                     @SC86190 07691000
         LA    8,DEFPARM                                       @SC86190 07692000
         SR    8,5           Set up offset for defaults        @SC86190 07693000
         BCTR  5,0           Point one before data             @SC86190 07694000
         LA    6,1           Set up BXH                        @SC86120 07695000
         AR    7,5           Point to last data char           @SC86120 07696000
         BAL   14,SPARFTCH   Get a char                        @SC86120 07697000
         UNCHR 4             Max send packet size              @SC86120 07698000
         C     4,AKMIN       Less than min Kermit size?        @SC86295 07699000
         BNL   SPARSPM               No, it's OK                        07700000
         LA    4,KMIN                Else, use the min value            07701000
SPARSPM  C     4,AKMAX       More than max Kermit size?        @SC86295 07702000
         BNH   SPARSPS               No, it's OK                        07703000
         LA    4,KMAX                                                   07704000
SPARSPS  ST    4,SPSIZ               Save max send packet size          07705000
         BAL   14,SPARFTCH   Get a char                        @SC86120 07706000
         UNCHR 4,,TIMOUT     Timeout micro wants us to do      @SC86120 07707000
         BAL   14,SPARFTCH   Get a char                        @SC86120 07708000
         UNCHR 4,,SPADN      Pad count micro wants             @SC86120 07709000
         BAL   14,SPARFTCH                                     @SC86120 07710000
         CTL   4,,SPADC      Pad char micro wants              @SC86120 07711000
         BAL   14,SPARFTCH                                     @SC86120 07712000
         UNCHR 4,,SEOL       EOL char we have to use           @SC86120 07713000
         CLC   SEOL,SMARK                                               07714000
         BE    SPARCR                Use CR if EOL=MARK char            07715000
         CLI   SEOL,ABL                                                 07716000
         BL    SPAREOL2      OK if within ctl range            @SC87274 07717000
SPARCR   MVI   SEOL,CR               Send a CR to that crazy micro      07718000
SPAREOL2 MVC   S1EOL,SEOL    Make extra copy                   @SC87274 07719000
SPARCTL  BAL   14,SPARFTCH                                     @SC86120 07720000
         NOTQR *+8           Go if not 33-62 or 96-126         @SC86120 07721000
          LA   4,A#          Default ctl-quote                 @SC86120 07722000
         STC   4,RCTLQ       Save ctl-quote micro's using      @SC86120 07723000
         BAL   14,SPARFTCH                                     @SC86120 07724000
         CLI   EBQC,0                                          @SC87008 07725000
         BE    SPARNB        8-bit is off                      @SC87008 07726000
         CLM   4,1,=AL1(AY)                                    @SC86120 07727000
         BNE   *+8                                             @SC86120 07728000
         IC    4,EBQC        Micro agrees                      @SC86120 07729000
         BAL   14,SPARCKQX                                     @SC86120 07730000
          B    SPARNB        Micro says no 8-bit quoting       @SC86120 07731000
         CLI   EBQ,0                                                    07732000
         BE    SPAREBQ               Use it if we agree                 07733000
         CLM   4,1,EBQ                                         @SC86120 07734000
         BE    SPAREBQ               Or we match                        07735000
SPARNB   SR    4,4                   Otherwise cannot do it             07736000
SPAREBQ  STC   4,EBQ                 Set 8-bit-quoting char/flag        07737000
         BAL   14,SPARFTCH                                     @SC86120 07738000
         S     4,=A(A0)                                        @SC86120 07739000
         BNP   SPARBCD       Go if less than 1, use 1          @SC86120 07740000
         C     4,F3                                            @SC86295 07741000
         BH    SPARBCD               Go if over 3, use 1                07742000
         CLM   4,B'0001',BCTR        Requested and our BCT same?        07743000
         BE    SPARBCT               Yes, they are the same             07744000
         CLI   BCTR,0                                                   07745000
         BE    SPARBCT               We'll accept anything              07746000
SPARBCD  LA    4,1                   We don't match, use 1              07747000
SPARBCT  STC   4,BCTR                Micro's chksum length              07748000
         BAL   14,SPARFTCH                                     @SC86120 07749000
         BAL   14,SPARCKQX   See if valid                      @SC86120 07750000
          B    SPARNR        No good                           @SC86120 07751000
         CLM   4,1,EBQ                                         @SC86120 07752000
         BE    SPARNR                Go if same prefix                  07753000
         CLI   RPTQ,0                                                   07754000
         BE    SPARRQ                We can use anything                07755000
         CLM   4,1,RPTQ                                        @SC86120 07756000
         BE    SPARRQ                We match                           07757000
SPARNR   SR    4,4                   No repeat quoting                  07758000
SPARRQ   STC   4,RPTQ                Use negotiated repeat quote        07759000
         BAL   14,SPARFTCH   Get capabilities                  @SC86149 07760000
         UNCHR 4,,RCAPA                                        @SC86149 07761000
         TM    RCAPA,LONGP   Test for long packet bit          @TB86196 07762000
         BZ    SPARNX        No extended packets               @TB86196 07763000
         MVC   TMP,RCAPA                                       @SC86202 07764000
SPARNS1  TM    TMP,MORCAPAS  Test for more CAPAS bytes         @SC86202 07765000
         BZ    SPARNS2       No more                           @TB86196 07766000
         BAL   14,SPARFTCH   Get capabilities                  @TB86196 07767000
         UNCHR 4,,TMP                                          @TB86196 07768000
         B     SPARNS1                                         @TB86196 07769000
SPARNS2  BAL   14,SPARFTCH   Skip window byte                  @SC86202 07770000
         BAL   14,SPARFTCH   Get next header byte              @TB86196 07771000
         LR    1,4                                             @TB86196 07772000
         UNCHR 1             MAXLX1 byte                       @TB86196 07773000
         MH    1,XLFCT+2     Times the factor                  @SC86202 07774000
         BAL   14,SPARFTCH   Get next header byte              @TB86196 07775000
         UNCHR 4             MAXLX2 byte                       @TB86196 07776000
         AR    1,4           Compute total length              @TB86196 07777000
         BNP   SPARNX        If zero, use default              @TB86196 07778000
         ST    1,SPSIZ       New SPSIZ for extended            @TB86196 07779000
SPARNX   DS    0H                                              @TB86196 07780000
* Now compute MAXSIZ                                                    07781000
         L     5,SPSIZ               Maximum send packet size           07782000
         C     5,AKMAX       Check max packet size             @TB86196 07783000
         BNH   SPARNY        Not long                          @TB86196 07784000
         S     5,F3          Extended header length            @TB86196 07785000
         CLI   TRMTP,C'T'                                      @SC87166 07786000
         BNE   SPARNY        Not TTY ==> not limited           @SC87166 07787000
         C     5,AMAXWT                                        @SC86205 07788000
         BNH   *+8                                             @SC86205 07789000
         L     5,AMAXWT      Biggest we can send               @SC86205 07790000
SPARNY   DS    0H                                              @SC86205 07791000
         S     5,F5                  Minus control information          07792000
         IC    4,BCTR                Get user's negotiated BCT          07793000
         SR    5,4                   Minus checksum length              07794000
         CLI   EBQ,0                                                    07795000
         BE    SPARNEBQ              Go if no 8-Bit quoting             07796000
         BCTR  5,0                   Another one for 8-bit quoting      07797000
SPARNEBQ CLI   RPTQ,0                                                   07798000
         BE    SPARNRQ               Go if no repeat char quoting       07799000
         BCTR  5,0                                                      07800000
         BCTR  5,0                   Minus two for repeat prefix        07801000
SPARNRQ  ST    5,MAXSIZ              Save max length for data field     07802000
         ST    5,MAXSIZ+4    Static extra copy (for tuning)             07803000
SPARBAK  RET                                                   @SC86152 07804000
SPARCKQX CLM   4,1,RCTLQ                                       @SC86120 07805000
         BER   14            Cannot use same prefix            @SC86120 07806000
         CLM   4,1,SCTLQ                                       @SC86120 07807000
         BER   14                                              @SC86120 07808000
         B     CHKQR         Test if 33-62 or 96-126           @SC86120 07809000
SPARFTCH L     4,SPACE       Default                           @SC86120 07810000
         BXH   5,6,*+8       Check for more data               @SC86120 07811000
         IC    4,0(5)        OK, use it                        @SC86120 07812000
         C     4,SPACE       Default?                          @SC86120 07813000
         BNER  14                                              @SC86120 07814000
         IC    4,0(5,8)      Yes, get default value            @SC86190 07815000
         BR    14                                              @SC86120 07816000
*                                                                       07817000
*        SPARSET Routine - set up for exchange (SPAR 1st)      @SC86152 07818000
*                                                                       07819000
SPARSET  ENTER ALT                                             @SC86152 07820000
         MVI   BCTR,0        Use whatever micro wants          @SC86152 07821000
         MVI   EBQ,0                                           @SC86152 07822000
         MVI   RPTQ,0                                          @SC86152 07823000
         MVI   BCTU,1        Must start at 1                   @SC86295 07824000
         B     SPARBAK                                         @SC86152 07825000
         LOCALS ,                                              @SC86295 07826000
SPAR     EXIT                                                           07827000
         TITLE 'RPAR Routine - sets up parms to send to other host'     07828000
RPAR     ENTER                                                          07829000
         OI    FL3,PXCH      Parameters exchanged now          @SC87012 07830000
         L     9,ASDATA                                        @SC86295 07831000
         TOCHR 5,RPSIZ+3,0(9)  Receive packet size limit       @SC86295 07832000
         TOCHR 5,RTIMO,1(9)  Time limit for micro to wait      @SC86295 07833000
         TOCHR 5,RPADN,2(9)  Number of padding chars.          @SC86295 07834000
         CTL   5,RPADC,3(9)  Pad character                     @SC86295 07835000
         TOCHR 5,REOL,4(9)   EOL char I need                   @SC86295 07836000
         MVC   5(1,9),SCTLQ                                    @SC86295 07837000
         MVC   6(1,9),EBQ                                      @SC86295 07838000
         CLI   EBQ,0                                                    07839000
         BNE   RPARBCT               It's OK if not null                07840000
         MVI   6(9),AN       Else, use an N                    @SC86295 07841000
RPARBCT  MVC   7(1,9),BCTR   Negotiated checksum               @SC86295 07842000
         OI    7(9),A0       Make into a real digit            @SC86295 07843000
         MVC   8(1,9),RPTQ                                     @SC86295 07844000
         CLI   RPTQ,0                                                   07845000
         BNE   *+8           It's ok if not null               @SC86149 07846000
         MVI   8(9),ABL      Else, use a blank                 @SC86295 07847000
         LA    0,10          Size of data                      @SC86149 07848000
         NI    SCAPA,255-LONGP No long packets                 @TB86196 07849000
         LA    5,KMAX        Largest old KERMIT size           @TB86196 07850000
         C     5,RPSIZ       Check max packet size             @TB86196 07851000
         BNL   RPARNEX       KMAX >= RPSIZ                     @TB86196 07852000
         TOCHR 5,,0(9)       Set largest packet size           @SC86295 07853000
         OI    SCAPA,LONGP   Long packets                      @TB86196 07854000
         MVI   10(9),ABL     Window size is blank              @SC86295 07855000
         L     5,RPSIZ       Packet size                       @SC86205 07856000
         CLI   TRMTP,C'T'                                      @SC87166 07857000
         BNE   RPARS1        Not TTY ==> not limited           @SC87166 07858000
         C     5,AMAXRT                                        @SC86205 07859000
         BNH   *+8                                             @SC86205 07860000
         L     5,AMAXRT      Biggest we can send               @SC86205 07861000
RPARS1   SR    4,4                                             @SC86205 07862000
         D     4,XLFCT       Compute extended size bytes       @TB86196 07863000
         TOCHR 5,,11(9)      Extended size 1                   @SC86295 07864000
         TOCHR 4,,12(9)      Extended size 2                   @SC86295 07865000
         LA    0,13          Size of data                      @TB86196 07866000
RPARNEX  DS    0H                                              @TB86196 07867000
         TOCHR 5,SCAPA,9(9)  Capabilities                      @SC86295 07868000
         ST    0,DATL        Return it                         @SC86149 07869000
         LA    0,3           Reset function                    @SC86295 07870000
         CLI   TRMTP,C'F'                                      @SC87300 07871000
         BE    RPARSTT       3708/fullscreen                   @SC87300 07872000
         CLI   TRMTP,C'T'                                      @SC87166 07873000
         BE    RPARSTT       TTY                               @SC87166 07874000
         KCALL SCRNIO                                          @SC86295 07875000
         B     RPARBAK                                         @SC86295 07876000
RPARSTT  KCALL TERMIO                                          @SC86295 07877000
RPARBAK  RET                                                   @SC86152 07878000
*                                                                       07879000
*        RPARSET Routine - set up for exchange (RPAR 1st)      @SC86152 07880000
*                                                                       07881000
RPARSET  ENTER ALT                                             @SC86152 07882000
         MVI   BCTU,1        Must start at 1                   @SC86295 07883000
         TM    FL2,SRV       Possible I-packet exchange?       @SC87169 07884000
         BZ    RPSCLR        Not in Server mode                @SC87169 07885000
         TM    FL3,PXCH      Any exchange since last SET?      @SC87169 07886000
         BO    RPARBAK       Yes, keep latest settings         @SC87169 07887000
RPSCLR   MVC   BCTR,BCTC     Use what user set                 @SC87169 07888000
         MVC   EBQ,EBQC      Set what we want otherwise        @SC86152 07889000
RPSEBQ   CLI   RPTQ,0                                          @SC86152 07890000
         BNE   RPARBAK       If RPTQ is set leave it alone     @SC86152 07891000
         MVC   RPTQ,RPTQC    Set what we want otherwise        @SC86152 07892000
         B     RPARBAK                                         @SC86152 07893000
         LOCALS ,                                              @SC86295 07894000
RPAR     EXIT                                                           07895000
         TITLE 'ENCODE Routine - encode pkts from RBUF into DATA'       07896000
ENCODE   ENTER                                                          07897000
         L     6,MAXSIZ                                        @SC86295 07898000
         L     9,ASDATA      Pointer to data to fill           @SC86190 07899000
         AR    6,9           Limit on output                   @SC86295 07900000
ENCAGAIN L     8,RBUFP               Index of next char in RBUF         07901000
         L     5,RBUFL       Data length in RBUF               @SC86163 07902000
         L     1,RBUF                Point to start of buffer           07903000
         AR    5,1                   Point to char after last one       07904000
         AR    8,1           Point to char to encode           @SC86163 07905000
ENCNXT   CR    8,5           Are we past the last char?        @SC86163 07906000
         BL    ENCPKT        No, not exhausted RBUF yet        @SC86163 07907000
         TM    FL1,NAME                                        @SC86163 07908000
         BO    ENCEMPT       No more disk read if file name    @SC86163 07909000
         KCALL INBUF,E=ENCRET                                  @SC86163 07910000
         B     ENCAGAIN                                        @SC86163 07911000
ENCPKT   CLI   RPTQ,0                                                   07912000
         BE    ENCEBQ                Go if no repeat quoting            07913000
         LA    14,3(8)       Point to 3 chars past current     @SC86163 07914000
         CR    14,5          Is this past the last char?       @SC86163 07915000
         BNL   ENCEBQ                Yes, not enough to use repeat      07916000
         CLC   0(2,8),1(8)   At least 3 of these?              @SC86163 07917000
         BNE   ENCEBQ        No, not enough                    @SC86163 07918000
         LR    2,8           Start of string                   @SC86163 07919000
         LA    3,KMAX(8)     Max allowed by notation           @SC86163 07920000
         CR    3,5           Watch for end of data             @SC86163 07921000
         BNH   *+6                                             @SC86163 07922000
         LR    3,5           Truncate at max                   @SC86163 07923000
         LR    15,3          Same limit                        @SC86163 07924000
         SR    3,2           Get lengths                       @SC86163 07925000
         SR    15,14         Length of shorter string          @SC86163 07926000
         ICM   15,8,0(8)     Use starting char for fill        @SC86163 07927000
         CLCL  2,14          Find end of match                 @SC86163 07928000
         SR    14,8          Get repeat count                  @SC86163 07929000
         AR    8,14          Advance ptr to                    @SC86163 07930000
         BCTR  8,0             last matching char              @SC86163 07931000
         MVC   0(1,9),RPTQ   Put repeat quote into DATA        @SC86163 07932000
         TOCHR 14,,1(9)                                        @SC86163 07933000
         LA    9,2(9)        Count 2 for RPTQ and rpt count    @SC86295 07934000
ENCEBQ   TM    0(8),128                                        @SC86163 07935000
         BZ    ENCCTL                no 8th bit                         07936000
         CLI   EBQ,0                                                    07937000
         BE    ENCCTL                cannot use 8bit quoting            07938000
         NI    0(8),127      Get rid of 8th bit                @SC86163 07939000
         MVC   0(1,9),EBQ            Move EBQ into DATA                 07940000
         LA    9,1(9)        Count for it                      @SC86295 07941000
ENCCTL   IC    7,0(8)        Load desired char                 @SC86163 07942000
         CLI   0(8),ABL                                        @SC86163 07943000
         BL    ENCSCTL               within control range               07944000
         CLI   0(8),ADEL                                       @SC86163 07945000
         BNE   ENCNCTL               not a control char                 07946000
ENCSCTL  CTL   7             Convert to non-control            @SC86163 07947000
         B     ENCMVCTL                                                 07948000
*                                                                       07949000
ENCNCTL  CLM   7,1,SCTLQ                                       @SC86163 07950000
         BE    ENCMVCTL              send prefix if ctl quote char      07951000
         CLM   7,1,EBQ                                         @SC86163 07952000
         BE    ENCMVCTL              ditto if 8bit quote                07953000
         CLM   7,1,RPTQ                                        @SC86163 07954000
         BNE   ENCNOCTL              not so if not repeat quote         07955000
ENCMVCTL MVC   0(1,9),SCTLQ          Move a ctl quote                   07956000
         LA    9,1(9)                incr for it                        07957000
ENCNOCTL STC   7,0(9)        Move the char, finally!           @SC86163 07958000
         LA    9,1(9)                incr for it                        07959000
         LA    8,1(8)        Incr RBUF pointer                 @SC86163 07960000
         CR    9,6           Did we reach max pkt size?        @SC86295 07961000
         BL    ENCNXT        Test for more data                @SC86295 07962000
*                                                                       07963000
ENCFULL  CR    8,5           Are we past the last char?        @SC86163 07964000
         BL    ENCGOOD       No, not exhausted RBUF data yet   @SC86163 07965000
ENCEMPT  XC    RBUFL,RBUFL   Zap data length for next time     @SC86163 07966000
ENCGOOD  SR    15,15                                                    07967000
         S     8,RBUF        Get current index                 @SC86163 07968000
         ST    8,RBUFP               Save RBUF index                    07969000
ENCRET   S     9,ASDATA      Get length                        @SC86295 07970000
         ST    9,DATL        Save encoded DATA length          @SC86295 07971000
         RET   ,                                               @SC86295 07972000
         LOCALS ,                                              @SC86295 07973000
ENCODE   EXIT                                                           07974000
         TITLE 'NPREAD Routine - copy from RBUF to SDATA'      @HF86150 07975000
NPREAD   ENTER                                                 @HF86150 07976000
         L     6,SPSIZ       Max packet length                 @SC86295 07977000
         LR    4,6           Save                              @SC86295 07978000
         L     9,ASPKT       Fill pointer (includes header)    @SC86165 07979000
         SR    7,7                                             @SC86165 07980000
         IC    7,TCTLQ       Fetch control quote               @SC86165 07981000
NPRAGAIN L     8,RBUFP       Index of next char in RBUF        @SC86165 07982000
         L     5,RBUFL       Data length in RBUF               @SC86165 07983000
         L     1,RBUF        Start of buffer                   @SC86165 07984000
         AR    5,1           Point to char after last one      @SC86165 07985000
         AR    8,1           Point to char to encode           @SC86165 07986000
NPRNXT   CR    8,5           Are we past the last char?        @SC86165 07987000
         BL    NPRTCT        No, not exhausted RBUF yet        @SC86165 07988000
NPRRD    KCALL INBUF,E=NPRRET                                  @HF86150 07989000
         B     NPRAGAIN                                        @SC86165 07990000
NPRTCT   LTR   7,7           Test for quoting                  @SC86165 07991000
         BZ    NPRNOCTL      Not enabled                       @HF86150 07992000
         CLM   7,1,0(8)      Is it a quote character?          @HF86150 07993000
         BNE   NPRNOCTL      No, copy it                       @HF86150 07994000
         LA    8,1(8)        Check next                        @HF86150 07995000
         CR    8,5                                             @HF86150 07996000
         BNL   NPRRD         Ran out of data, ignore the quote @HF86150 07997000
         CLM   7,1,0(8)      If repeat of quote character      @HF86150 07998000
         BE    NPRNOCTL       send that character              @HF86150 07999000
         NI    0(8),X'1F'    Make control character            @HF86150 08000000
NPRNOCTL MVC   0(1,9),0(8)   Copy the char                     @HF86150 08001000
         LA    9,1(9)        Incr for it                       @HF86150 08002000
         LA    8,1(8)        Incr RBUF pointer                 @HF86150 08003000
         BCT   6,NPRNXT      Get next character if any room    @SC86295 08004000
*                                                                       08005000
NPRGOOD  SR    15,15                                           @HF86150 08006000
         S     8,RBUF        Convert to index                  @SC86165 08007000
         ST    8,RBUFP       Save it                           @SC86165 08008000
NPRRET   SR    4,6           Get DATA length                   @SC86295 08009000
         ST    4,SNDPKL      Save it                           @HF86150 08010000
         RET                                                   @HF86150 08011000
         LOCALS ,                                              @SC86295 08012000
NPREAD   EXIT                                                  @HF86150 08013000
         TITLE 'DECODE Routine - decode pkts from DATA to WBUF'         08014000
DECODE   ENTER                                                          08015000
         ICM   5,B'1111',DATL        Data length to decode              08016000
         BNP   RTRN1         No data to decode                 @SC86295 08017000
         TM    FL1,EOF                                                  08018000
         BO    DECNULL               Ignore if ctl-z caused EOF         08019000
         L     1,WBUF                Point to output buffer             08020000
         L     9,WBUFL               Number of chars in it              08021000
         AR    1,9                   Point to next spot to fill         08022000
         L     8,ARDATA      Data to be decoded                @SC86190 08023000
         AR    5,8           Point one past the last char               08024000
DECLOOP  LA    3,1           Repeat count                      @SC86316 08025000
         CLI   RPTQ,0                                                   08026000
         BE    DECEBQ                Not doing repeats                  08027000
         CLC   RPTQ,0(8)                                                08028000
         BNE   DECEBQ                Not the repeat quote               08029000
         UNCHR 3,1(8)        Get number of repeats             @SC86316 08030000
         LA    8,2(8)                skip to char to decode             08031000
DECEBQ   MVI   CUR,0                 No 8th bit yet                     08032000
         CLI   EBQ,0                                                    08033000
         BE    DECCTL                Not doing 8bit quoting             08034000
         CLC   EBQ,0(8)                                                 08035000
         BNE   DECCTL                Not the 8bit quote                 08036000
         LA    8,1(8)                point to char to decode            08037000
         MVI   CUR,128               8th bit seen                       08038000
DECCTL   CLC   RCTLQ,0(8)                                               08039000
         BNE   DECCHR                not the ctl quote                  08040000
         LA    8,1(8)                point to char to decode            08041000
         CLI   0(8),63                                                  08042000
         BL    DECCHR                skip if not in ctl range           08043000
         CLI   0(8),95                                                  08044000
         BH    DECCHR                skip if not in ctl range           08045000
         CTL   4,0(8),0(8)           Ctl it                             08046000
DECCHR   OC    0(1,8),CUR            put in the parity                  08047000
         MVC   CUR,0(8)              move it here also                  08048000
         TR    CUR,ATOE              keep the EBCDIC version here       08049000
DECRLOOP TM    FL1,NAME                                                 08050000
         BO    DECPUT                skip if not writing to disk        08051000
         LTR   7,9           Started yet?                      @SC86316 08052000
         BZ    DECTFUL       No                                @SC86151 08053000
         C     9,RDWLEN                                        @SC86151 08054000
         BNE   DECTFUL                                         @SC86151 08055000
         L     6,WBUF        Just finished RDW                 @SC86316 08056000
         SR    14,14                                           @SC86151 08057000
         ICM   14,3,0(6)     Get expected length               @SC86316 08058000
         C     9,F2          Short?                            @SC86262 08059000
         BE    DECVLEN       Yes, we got it                    @SC86262 08060000
         TR    0(5,6),ATOE   No, must be 5-byte ASCII prefix   @SC86316 08061000
         MVI   ERRNUM,ERRBPC Look out for bad field            @SC86262 08062000
         BAL   14,GETNUM     Read length field                 @SC86316 08063000
          B    RTRN1         Bad                               @SC86316 08064000
         LR    14,0                                            @SC86316 08065000
DECVLEN  DS    0H                                              @SC86262 08066000
         AR    14,9               + RDW length                 @SC86151 08067000
         ST    14,MAXOUT     Reset byte limit                  @SC86151 08068000
DECTFUL  C     9,MAXOUT      Max write buffer size reached?    @SC86151 08069000
         BNL   DECWRT                Yes, write the buffer              08070000
DECMORE  TM    FL1,BINF                                                 08071000
         BO    DECPUT                No special test in binary mode     08072000
         CLI   CUR,CR                                                   08073000
         BE    DECWRT                A cr means end of record           08074000
         CLI   CUR,LF                                                   08075000
         BNE   DECTAB                Not an LF                          08076000
         CLI   PREV,CR                                                  08077000
         BE    DECIGN                A cr/lf together = ignre the LF    08078000
DECWRT   ST    9,WBUFL               Buffer length to write             08079000
         KCALL OUTBUF,E=RTRN1 Dump it                          @SC86295 08080000
         SR    9,9                   Reset length to resume decoding    08081000
         L     1,WBUF                Reset pointer also                 08082000
         CLC   WBUFL,MAXOUT                                             08083000
         BNL   DECMORE               Resume decoding if max             08084000
         B     DECIGN                                                   08085000
*                                                                       08086000
DECTAB   TM    FL2,TABS                                                 08087000
         BZ    DECCTLZ               Skip if not expanding tabs         08088000
         CLI   CUR,TAB                                                  08089000
         BNE   DECCTLZ               Not a tab                          08090000
         LR    0,1           Save output ptr                   @SC86355 08091000
         LH    2,TABCNT      Get count of tabs that are set    @TS86100 08092000
         LTR   2,2           Any?                              @SC86355 08093000
         BZ    DECTL8        No, use every 8 cols              @SC86355 08094000
         LA    7,TABTBL      Yes, point to table of tabs       @TS86100 08095000
         SR    1,1                                             @TS86100 08096000
DECTLP   IC    1,0(7)        Get tab column from table         @TS86100 08097000
         BCTR  1,0           Adjust for displacement compare   @TS86100 08098000
         CR    1,9           Where is this tab compared to buf @TS86100 08099000
         BH    DECTLX        Above buffer position             @TS86100 08100000
         LA    7,1(7)        Point to next tab position        @TS86100 08101000
         BCT   2,DECTLP      Continue with next tab            @TS86100 08102000
DECTL8   DS    0H                                              @SC86355 08103000
         LA    1,8(9)        Buffer pointer + 8                @SC86355 08104000
         SRL   1,3                                             @SC86355 08105000
         SLL   1,3           Round up to multiple of 8         @SC86355 08106000
DECTLX   C     1,MAXLRC                                        @SC86355 08107000
         BL    *+8                                             @SC86355 08108000
         L     1,MAXLRC      Don't go past end of buffer       @SC86355 08109000
         SR    1,9           Number of blanks to add           @SC86355 08110000
         AR    9,1           Advance the count                 @SC86355 08111000
         LA    15,ABL                                          @SC86355 08112000
         SLL   15,24         Set for ASCII blank fill          @SC86355 08113000
         MVCL  0,14          Jump to tab stop                  @SC86355 08114000
         LR    1,0           Restore output ptr                @SC86355 08115000
         B     DECIGN                skip to the end of this            08116000
*                                                                       08117000
DECCTLZ  TM    FL2,EOFZ                                                 08118000
         BZ    DECPUT                Skip if EOF is off                 08119000
         CLI   CUR,SUB                                                  08120000
         BNE   DECPUT                Skip if not a ctl-z                08121000
         OI    FL1,EOF               Fake an end-of-file                08122000
         B     DECEOF                all done                           08123000
*                                                                       08124000
DECPUT   C     9,MAXLRC      Still within disk buffer?         @SC86355 08125000
         BNL   *+10          No, don't copy                    @SC86355 08126000
         MVC   0(1,1),0(8)   Yes, put the data in buffer       @SC86355 08127000
         LA    9,1(9)                Increment count                    08128000
         LA    1,1(1)                Increment pointer                  08129000
DECIGN   MVC   PREV,CUR              copy the decoded char              08130000
         BCT   3,DECRLOOP    Repeat it repeat count times      @SC86316 08131000
         LA    8,1(8)                Increment decoded data pointer     08132000
         CR    8,5                   Did we reach end of DATA?          08133000
         BL    DECLOOP               No, More data left to decode       08134000
DECEOF   ST    9,WBUFL               Save buffer length                 08135000
DECNULL  B     RTRN0         Good return code                  @SC86295 08136000
         LOCALS ,                                              @SC86295 08137000
CUR      DS    C             Char being decoded                @SC86295 08138000
DECODE   EXIT                                                           08139000
         TITLE 'ERPACK Routine - send error packet with errnum'         08140000
ERPACK   ENTER                                                          08141000
         CLI   ERRNUM,ERRABO                                   @SC86295 08142000
         BE    RTRN0         Skip it if the micro died         @SC86295 08143000
         CLI   ERRNUM,ERRTRC                                   @SC86295 08144000
         BE    RTRN0         Skip it if other cancelled        @SC86295 08145000
         MVI   STYPE,AE              Error packet                       08146000
         MVC   SEQ,RSN               Synch packet numbers               08147000
         SR    5,5                                                      08148000
         IC    5,ERRNUM              Get right message number           08149000
         SLL   5,2           Pointer offset = ERRNUM * 4       @SC86156 08150000
         A     5,AERRTAB     Pointer address                   @SC86156 08151000
         L     3,0(5)        Msg ptr                           @SC86156 08152000
         SR    4,4                                             @SC86156 08153000
         IC    4,0(5)        Msg length                        @SC86156 08154000
         TM    FL2,PROTO                                       @SC87300 08155000
         BZ    RTRN0         Skip packet if never started      @SC87300 08156000
         TM    FL2,SRV       Server will read another command  @SC87343 08157000
         BO    *+8            so don't zap write/read flag     @SC87343 08158000
         MVI   WRRD,0        No read ncessary for Err pkt      @SC87300 08159000
         ST    4,RBUFL       Save length to encode             @SC86156 08160000
         L     1,RBUF                                                   08161000
         MVC   0(50,1),0(3)  Put data in RBUF (and some extra) @SC86156 08162000
         TR    0(50,1),ETOA  Ascii it                          @SC86156 08163000
         BAL   9,ENCODEN                                       @SC86295 08164000
         KCALL SPACK         Send error packet                 @SC86135 08165000
         RET                                                            08166000
         LOCALS ,                                              @SC86295 08167000
ERPACK   EXIT                                                           08168000
         TITLE 'SPACK Routine - sends DATA buffer'                      08169000
SPACK    ENTER                                                          08170000
         SR    3,3                   Zero out IC register               08171000
         L     8,AASPKT      SNDPKT address                    @SC86295 08172000
SPKNX3   LA    8,3(8)        Remove LX1, LX2, HCHECK from hdr  @SC86295 08173000
         L     9,DATL                Data size                          08174000
         IC    3,BCTU                CHK len                            08175000
         LA    9,2(3,9)              Data, CHK, SEQ, TYP lengths        08176000
         LA    1,3(9)        Plus SOH, LEN, EOL lengths        @SC86202 08177000
         C     9,AKMAX       Check packet length byte          @SC86202 08178000
         BNH   SPKNXDL1      No extended data len              @SC86202 08179000
         LA    1,3(1)        Plus LX1,LX2,HCHECK for ext. hdr  @SC86202 08180000
         SR    9,9           Set 'Type 0' extended hdr         @SC86202 08181000
         SH    8,SPKNX3+2    Remove LX1, LX2, HCHECK from hdr  @SC86295 08182000
SPKNXDL1 ST    1,SNDPKL      SNDPKT length                     @SC86202 08183000
         LM    14,15,TOUTOT  Update send count                 @SC86295 08184000
         ALR   15,1                                            @SC86295 08185000
         BNO   *+8                                             @SC86295 08186000
         AL    14,F1                                           @SC86295 08187000
         STM   14,15,TOUTOT  Save new count                    @SC86295 08188000
         ST    8,ASPKT       Ptr to buffer                     @SC86295 08189000
         MVC   0(1,8),SMARK  Add mark to packet                @SC86295 08190000
         TOCHR 9,,1(8)       Add it to packet                  @SC86295 08191000
         TOCHR 4,SEQ,2(8)    Get packet number                 @SC86295 08192000
         AR    9,4                   And add to checksum                08193000
         IC    3,STYPE               Type                               08194000
         STC   3,3(8)        Store in buffer                   @SC86295 08195000
         AR    9,3                   Add to checksum                    08196000
         CLI   1(8),ABL      Chk 'Type 0' extended hdr         @SC86295 08197000
         BNE   SPKNXDL3      No extended data len              @TB86196 08198000
         L     7,DATL        Data size                         @TB86196 08199000
         IC    3,BCTU        CHK len                           @TB86196 08200000
         AR    7,3           Sum = extended length             @TB86196 08201000
         SR    6,6                                             @TB86196 08202000
         D     6,XLFCT       Get two parts                     @TB86196 08203000
         TOCHR 7,,4(8)       Add LENX1 to packet               @SC86295 08204000
         AR    9,7           And add to checksum               @TB86196 08205000
         TOCHR 6,,5(8)       Add LENX2 to packet               @SC86295 08206000
         AR    9,6           And add to checksum               @TB86196 08207000
         LR    6,9           Chksum thru LENX2 byte            @TB86196 08208000
         SRL   6,6           High 2 bits of total              @TB86196 08209000
         N     6,F3          Get just 2 bits                   @SC86295 08210000
         AR    6,9           Get type-1 check value            @TB86196 08211000
         N     6,MOD64                                         @TB86196 08212000
         TOCHR 6,,6(8)       Make printable                    @SC86295 08213000
         AR    9,6           And add to checksum               @TB86196 08214000
SPKNXDL3 DS    0H                                              @TB86196 08215000
         L     8,ASDATA                                        @SC86295 08216000
         BCTR  8,0           Ptr one before data               @SC86295 08217000
         ICM   6,B'1111',DATL        Data length                        08218000
         BZ    SPKCHK                Go if no data                      08219000
         LR    5,6                                             @SC86135 08220000
SPKCHAR  IC    3,0(5,8)      Pick up char                      @SC86295 08221000
         AR    9,3                   Add to checksum                    08222000
         BCT   5,SPKCHAR     Yes, there's more data            @SC86135 08223000
SPKCHK   LA    6,1(6,8)      Point to where chksum goes        @SC86295 08224000
         LR    7,9                   Need copy of chksum                08225000
         CLI   BCTU,2                                                   08226000
         BE    SPKCHK2               Go if 2 char chksum                08227000
         BH    SPKCHK3               Go if 3 char CRC                   08228000
         SRL   9,6                   High 2 bits of total               08229000
         N     9,F3          Get just 2 bits                   @SC86295 08230000
         AR    7,9                   Add the two values                 08231000
         B     SPKCHK1               Go add chksum to data              08232000
*                                                                       08233000
SPKCHK3  L     5,ASPKT                                         @SC86190 08234000
         LA    5,1(5)        Where checksum starts             @SC86190 08235000
         KCALL CRCCLC        Calculate the CRC                          08236000
         LR    7,15                  Keep in here                       08237000
         SRL   15,12                 High 4 bits of high byte           08238000
         TOCHR 15,,0(6)              Make char printable                08239000
         LA    6,1(6)                Bump output pointer                08240000
SPKCHK2  LR    15,7                  total                              08241000
         SRL   15,6          Next 6 bits of total              @SC86295 08242000
         N     15,MOD64      Get just 6 bits                   @SC86295 08243000
         TOCHR 15,,0(6)              Make char printable                08244000
         LA    6,1(6)                Bump pointer                       08245000
SPKCHK1  N     7,MOD64               Get low order 6 bits               08246000
         TOCHR 7,,0(6)               Make printable                     08247000
SPKEOL   MVC   1(2,6),S1EOL  Add micro's EOL char + handshake  @SC87274 08248000
         KCALL SIO           Write the SNDPKT                  @SC86135 08249000
         RET   ,             Return with SIO's rc              @SC86295 08250000
         LOCALS ,                                              @SC86295 08251000
SPACK    EXIT                                                           08252000
         TITLE 'RPACK Routine - Reads data into DATA buffer'            08253000
RPACK    ENTER                                                          08254000
         KCALL RIO,E=RPKNAK                                             08255000
         L     7,RCVPKL              Length of data read                08256000
         LM    14,15,TINTOT  Update recv count                 @SC86295 08257000
         ALR   15,7                                            @SC86295 08258000
         BNO   *+8                                             @SC86295 08259000
         AL    14,F1                                           @SC86295 08260000
         STM   14,15,TINTOT  Save new count                    @SC86295 08261000
         L     14,ARPKT      Point to recv buffer              @SC86295 08262000
         L     8,APKT        Point to PKT                      @SC86190 08263000
         MVI   RTYPE,AT      In case of time-out               @SC87012 08264000
         C     7,F1          Time-out signal is ASCII T        @SC87012 08265000
         BNE   *+12                                            @SC87012 08266000
         CLI   0(8),AT                                         @SC87012 08267000
         BE    RTRN          Yes, timed out                    @SC87012 08268000
         AR    7,8           Point past last char                       08269000
RPKBEG   SR    3,3                   Use this for IC's                  08270000
RPKLOOP  CLC   RMARK,0(8)                                               08271000
         LA    8,1(8)        Try next character                @SC86135 08272000
         BE    RPKSOH                Go if a Control-A                  08273000
         CR    8,7                   Are we within the received pkt?    08274000
         BL    RPKLOOP               Yes, keep on looking for SOH       08275000
         B     RPKERR                                                   08276000
*                                                                       08277000
RPKSOH   LA    9,4(14)       Skip over usual header            @SC86295 08278000
         MVC   1(3,14),0(8)  Copy usual header to RCVPKT       @SC86295 08279000
         UNCHR 3,0(8)                Length                             08280000
         BM    RPKBEG        Invalid length, try again         @SC86153 08281000
         LA    5,ABL(3)              Chksum accumulator                 08282000
         LR    4,3                   Keep length to compute DATA len    08283000
         LA    15,0(3,8)             pkt len + beg                      08284000
         CR    15,7                  Is it within received pkt?         08285000
         BNL   RPKBEG                too long, look for another SOH     08286000
         IC    3,2(8)        Pick up packet type               @SC86153 08287000
         STC   3,RTYPE       Save value here                   @SC86153 08288000
         AR    5,3           Add to checksum                   @SC86153 08289000
         BCTR  4,0                   -1 for Seq #                       08290000
         BCTR  4,0                   -1 for Type                        08291000
         UNCHR 3,1(8)        Pick up packet number             @SC86153 08292000
         BM    RPKBEG        Invalid char                      @SC86153 08293000
         LA    5,ABL(3,5)            Add to checksum                    08294000
         STC   3,RSN         Received packet number            @SC86135 08295000
         LA    8,3(8)        Go to putative data               @SC86153 08296000
         CLI   1(14),ABL     Is this an extended pkt?          @SC86295 08297000
         BNE   RPKEXT2       No                                @TB86196 08298000
         LA    15,3(8)       Past LENX1,LENX2,HCHECK           @TB86196 08299000
         CR    15,7          Is it within rcvd pkt?            @TB86196 08300000
         BNL   RPKBEG        Too long, try for another SOH     @TB86196 08301000
         MVC   4(3,14),0(8)  Copy extended pkt hdr             @SC86295 08302000
         UNCHR 1,0(8)        Pick up LENX1 byte                @TB86196 08303000
         LA    5,ABL(1,5)    Add to check                      @SC86202 08304000
         MH    1,XLFCT+2     High digit of size                @SC86202 08305000
         UNCHR 3,1(8)        Pick up LENX2 byte                @TB86196 08306000
         LA    5,ABL(3,5)    Add to chksum                     @SC86202 08307000
         AR    1,3           Total extended pkt size           @TB86196 08308000
         UNCHR 3,2(8)        Pick up HCHECK byte               @TB86196 08309000
         LR    6,5           Keep chksum copy here             @TB86196 08310000
         SRL   6,6           High 2 bits of total              @TB86196 08311000
         N     6,F3          Get just 2 bits                   @SC86295 08312000
         AR    6,5           Add the two values                @TB86196 08313000
         N     6,MOD64       Get low order 6 bits              @TB86196 08314000
         CR    6,3           Chk computed vs received          @TB86196 08315000
         BNE   RPKERR        Err if chksums no match           @TB86196 08316000
         LA    5,ABL(3,5)    Add HCHECK to chksum              @SC86202 08317000
         LA    8,3(8)        Update input+output ptrs          @SC86202 08318000
         LA    9,3(9)        Past LX1,LX2,HCHECK               @SC86202 08319000
         LR    4,1           Save length of data+check         @SC86202 08320000
         AR    1,8           Expected end of packet            @SC86202 08321000
         CR    1,7           Is it within pkt?                 @SC86202 08322000
         BH    RPKBEG        Too long, chk for SOH             @SC86202 08323000
RPKEXT2  DS    0H                                              @SC86202 08324000
         IC    3,BCTU        Chksum length                     @SC86202 08325000
         SR    4,3           Minus chksum length               @SC86202 08326000
         BM    RPKBEG        Can't have negative data length   @SC86202 08327000
         ST    4,DATL        Save data length                  @SC86202 08328000
         ST    9,ARDATA      Save ptr                          @SC86202 08329000
         LTR   4,4                   Any data to send?                  08330000
         BZ    RPKCHK                Nope                               08331000
RPKCHAR  IC    3,0(8)                Get next data char                 08332000
         STC   3,0(9)                Move it to DATA                    08333000
         AR    5,3                   Add to checksum                    08334000
         LA    8,1(8)                Bump input buffer pointer          08335000
         LA    9,1(9)                Bump output buffer pointer         08336000
         BCT   4,RPKCHAR             Decrement amount of input          08337000
RPKCHK   UNCHR 3,0(8)                Get checksum                       08338000
         LR    6,9           CRC calc ends here                @SC86135 08339000
         LA    8,1(8)                Bump input pointer                 08340000
         LR    4,5                   Keep chksum copy here              08341000
         CLI   BCTU,2                                                   08342000
         BE    RPKCHK2               Go if using 2 char chksum          08343000
         BH    RPKCHK3               Three character CRC                08344000
         SRL   5,6                   High 2 bits of total               08345000
         N     5,F3          Get just 2 bits                   @SC86295 08346000
         AR    4,5                   Add the two values                 08347000
         B     RPKCHK1               compare it                         08348000
*                                                                       08349000
RPKCHK3  LA    5,1(14)       Start of data for CRC             @SC86295 08350000
         KCALL CRCCLC        Calculate the CRC                          08351000
         LR    4,15                  Keep computed value here also      08352000
         SRL   15,12                 High 4 bits of high byte           08353000
         CR    15,3                  compare computed and received      08354000
         BNE   RPKERR                skip if chksums don't match        08355000
         UNCHR 3,0(8)                Get next char of checksum          08356000
         LA    8,1(8)                Bump input pointer                 08357000
RPKCHK2  LR    15,4                  Get back the CRC                   08358000
         SRL   15,6          Next 6 bits of total              @SC86295 08359000
         N     15,MOD64      Get just 6 bits                   @SC86295 08360000
         CR    15,3                  compare computed and received      08361000
         BNE   RPKERR                skip if chksums don't match        08362000
         UNCHR 3,0(8)                Get checksum                       08363000
         LA    8,1(8)                Bump input pointer                 08364000
RPKCHK1  N     4,MOD64               Get low order 6 bits               08365000
         CR    4,3                   Compare computed and received      08366000
         BE    RPKRET                skip if chksums match              08367000
         TM    FL1,TSTF                                        @SC86295 08368000
         BO    RPKRET        Just testing, anything goes       @SC86295 08369000
RPKERR   MVI   ERRNUM,ERRBPC Rpack error                       @SC86156 08370000
         CR    8,7                                             @BS86001 08371000
         BL    RPKBEG        More stuff, see if it's a packet  @BS86001 08372000
RPKNAK   MVI   RTYPE,AQ              Return a Q pkt                     08373000
RPKRET   RET                                                            08374000
         LOCALS ,                                              @SC86295 08375000
RPACK    EXIT                                                           08376000
         TITLE 'CRCCLC Routine - calculates CRC'                        08377000
* Calculate the CRC and return it in R15.  Expects R5 to point to the   08378000
* start of the data on which the CRC is calculated, and R6 to the       08379000
* char after the last one.                                              08380000
*                                                                       08381000
CRCCLC   ENTER                                                          08382000
         SR    15,15                 Initial CRC value is zero          08383000
CRCLUP   IC    4,0(5)        Get the next character            @SC86295 08384000
         XR    4,15          XOR char and CRC low byte         @SC86295 08385000
         LR    7,4                   same as above                      08386000
         SRL   7,4                   High 4 bits of low byte            08387000
         N     4,F                   Low 4 bits of low byte             08388000
         N     7,F           High 4 bits of low byte           @SC86295 08389000
         ALR   4,4                   Double to get index into table     08390000
         LH    4,CRCTAB2(4)          CRC for low 4 bits                 08391000
         ALR   7,7                   Double to get another index        08392000
         LH    7,CRCTAB1(7)          CRC for high 4 bits                08393000
         XR    4,7                   XOR the two                        08394000
         SRL   15,8                  Shift prev CRC 8 bits to right     08395000
         XR    15,4                  XOR current char's CRC into it     08396000
         N     15,=XL4'FFFF' Drop negative stuff               @SC86295 08397000
         LA    5,1(5)                Bump input pointer                 08398000
         CR    5,6                   Did we reach the end?              08399000
         BL    CRCLUP                Nope, loop for whole pkt           08400000
CRCRET   RET                                                            08401000
* Table to use for CRC calculation                                      08402000
CRCTAB1  DC    X'00,00,10,81,21,02,31,83,42,04,52,85,63,06,73,87'       08403000
         DC    X'84,08,94,89,A5,0A,B5,8B,C6,0C,D6,8D,E7,0E,F7,8F'       08404000
*                                                                       08405000
CRCTAB2  DC    X'00,00,11,89,23,12,32,9B,46,24,57,AD,65,36,74,BF'       08406000
         DC    X'8C,48,9D,C1,AF,5A,BE,D3,CA,6C,DB,E5,E9,7E,F8,F7'       08407000
*                                                                       08408000
         LOCALS ,                                              @SC86295 08409000
CRCCLC   EXIT                                                           08410000
         TITLE 'RIO Routine - Read packet into RCVPKT'                  08411000
RIO      ENTER                                                          08412000
         MVI   SIORIO,C'R'   Set type                          @SC86316 08413000
         L     7,APKT        Ptr to data                       @SC86316 08414000
         L     15,RIOC       Previous read count               @SC86295 08415000
         MVI   RIOC,X'80'    Nothing left in read buffer       @SC86295 08416000
         CLI   TRMTP,C'T'                                      @SC87166 08417000
         BE    RIOTTY        Go if not a S/1?                  @SC87166 08418000
         CLI   TRMTP,C'F'                                      @SC87300 08419000
         BE    RIOTTY        Go if not a S/1?                  @SC87300 08420000
         LA    5,OFF80       Turn off all X'80' bits           @SC86316 08421000
         TM    FL2,DAT8      Unless 8-bit line                 @SC86316 08422000
         BZ    *+6           Not 8-bit                         @SC86316 08423000
         SR    5,5           Yes, use all bits                 @SC86316 08424000
         LTR   15,15         Any previous?                     @SC86295 08425000
         BNM   RIOCOM        Yes, use it                       @SC86295 08426000
         CLI   TRMTP,C'G'                                      @SC87215 08427000
         BE    RIOS1R        Skip prompt if graphics mode      @SC87215 08428000
         LA    0,4           Write                             @SC86295 08429000
         KCALL SCRNIO,S1XOPL,E=(RIOER,M) Send a prompt         @SC86295 08430000
RIOS1R   DS    0H                                              @SC87215 08431000
         LA    0,5           Read                              @SC86295 08432000
         KCALL SCRNIO,S1RDPL,E=(RIOER,M) perform read          @SC86295 08433000
         BP    RIOCOM                                          @SC86355 08434000
RIOER    MVI   ERRNUM,ERRTIE Terminal I/O error                @SC86156 08435000
         B     RTRN1         Error, return to caller           @SC86295 08436000
*                                                                       08437000
RIOTTY   LA    5,ETOA        Translate to ASCII                @SC86316 08438000
         TM    FL4,TTAB      Using separate terminal tables?   @SC87117 08439000
         BZ    *+8           No                                @SC87117 08440000
         LA    5,TETOA       Yes                               @SC87117 08441000
         LTR   15,15         Any previous data?                @SC86295 08442000
         BNM   RIOCOM        Yes, use it                       @SC86295 08443000
         LA    0,5           No, read some now                 @SC86295 08444000
         KCALL TERMIO,TYRDPL,E=(RIOER,M)                       @SC86295 08445000
RIOCOM   LR    6,15          Copy byte count                   @SC86295 08446000
         ST    6,RCVPKL      Save                                       08447000
         BAL   9,RIORAW      Log raw data                      @SC86316 08448000
         LR    2,7                                             @SC86316 08449000
         LR    3,6           Length                            @SC86202 08450000
         LTR   15,5          Copy table ptr                    @SC86316 08451000
         BZ    *+8           Don't translate after all         @SC86316 08452000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08453000
         BAL   9,RIOLOG      Write to log                      @SC86190 08454000
         B     RTRN0                                           @SC86295 08455000
*  Write record to log buffer, R7->data, R6=length             @SC87286 08456000
*  Clobbers R0,R1,R2,R3,R8,R14,R15, return to (R9)             @SC87286 08457000
RIORAW   SR    3,3           Write raw data                    @SC86316 08458000
         B     RIOLG1                                          @SC86316 08459000
RIOLOG   LA    3,ATOE        Write data in EBCDIC              @SC86316 08460000
RIOLG1   C     3,DBGTYP      Correct type?                     @SC86316 08461000
         BNER  9             No, skip this one                 @SC86316 08462000
         TM    FL1,DEBUG                                       @SC86316 08463000
         BZR   9             Skip if no debugging              @SC86190 08464000
         LA    8,2(6)        Two extra for R:, etc.            @SC87286 08465000
         L     2,LOGBUF      LOG buffer                        @SC86316 08466000
         MVC   0(1,2),SIORIO Indicate log type                 @SC86316 08467000
         LA    2,2(2)        Skip over prefix                  @SC86190 08468000
         LR    0,2           Buffer ptr                        @SC86190 08469000
         LR    1,8           Data length                       @SC86316 08470000
         LR    14,7          Data ptr                          @SC86316 08471000
         LR    15,8                                            @SC86316 08472000
         MVCL  0,14          Copy to log buffer                @SC86316 08473000
         LTR   15,3          Check if translation needed       @SC86316 08474000
         BZ    *+10          No                                @SC86316 08475000
         LR    3,8           Data length                       @SC86316 08476000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08477000
         WRITF LOGPTR,BSIZE=(8),E=RIOLQU                       @SC87034 08478000
         BR    9             Done                              @SC86190 08479000
RIOLQU   CLOSF LOGPTR        Turn off DEBUG, it fails          @SC86355 08480000
         NI    FL1,255-DEBUG                                   @SC86355 08481000
         BR    9                                               @SC86355 08482000
         TITLE 'SIO Routine - Send packet in SNDPKT'                    08483000
SIO      ENTER ALT                                             @SC86190 08484000
         MVI   SIORIO,C'S'   Set type                          @SC86316 08485000
         MVI   RIOC,X'80'    Set no read count                 @SC86295 08486000
         L     6,SNDPKL              Length of SNDPKT to be sent        08487000
         TM    FL4,NPS       Non-protocol?                     @SC86239 08488000
         BO    SIOPLEN       Yes, no handshake at all          @LP87272 08489000
         CLI   WRRD,0        Only writing?                     @LP87272 08490000
*        BE    SIOPLEN       Yes, handshake done next Read     @LP87272 08491000
         CLI   S1HND,0       Handshake desired at all?         @SC87275 08492000
         BE    SIOPLEN       No, skip it                       @SC87275 08493000
         LA    6,1(6)        Allow for handshake character     @LP87272 08494000
SIOPLEN  DS    0H                                              @SC86239 08495000
         L     7,ASPKT       Ptr to send data                  @SC86316 08496000
         BAL   9,RIOLOG      Write to log                      @SC86190 08497000
         L     2,S1WRPL      Final output buffer               @SC86154 08498000
         LR    1,2           Save start                        @SC86154 08499000
         SR    3,3                                             @SC86154 08500000
         TM    FL4,NPS       Non-protocol?                     @SC86191 08501000
         BO    *+8           Yes, skip padding                 @SC86191 08502000
         IC    3,SPADN       Pad count                         @SC86154 08503000
         LA    4,S1DATA                                        @SC86154 08504000
         LA    5,S1ORDL      Length of Series/1 stuff          @SC86154 08505000
         CLI   TRMTP,C'G'    Graphics?                         @SC87215 08506000
         BNE   SIOPAD                                          @SC87215 08507000
         LA    4,GRDATA      Yes, use separate command         @SC87215 08508000
         LA    5,GRDL                                          @SC87215 08509000
SIOPAD   DS    0H                                              @SC87215 08510000
         AR    3,5           Total padding + Series/1          @SC86154 08511000
         ICM   5,8,SPADC     Get padding character             @SC86154 08512000
         MVCL  2,4           Copy to buffer with padding       @SC86154 08513000
         LR    3,6           Packet length                     @SC86154 08514000
         LR    5,6                                             @SC86154 08515000
         LR    4,7           Ptr to packet                     @SC86316 08516000
         MVCL  2,4           Copy packet to buffer             @SC86154 08517000
         CLI   TRMTP,C'T'                                      @SC87166 08518000
         BE    SIOTTY        Go if not S/1?                    @SC87166 08519000
         CLI   TRMTP,C'F'                                      @SC87300 08520000
         BE    SIOTTY        Go if not S/1?                    @SC87300 08521000
         SR    2,1           Total length                      @SC86154 08522000
         ST    2,S1WRPL+4    Store len in CCW                  @SC86154 08523000
         L     4,ASCRNIO     I/O routine for fullscreen        @SC87275 08524000
         LA    5,S1WRPL      1st plist                         @SC87275 08525000
SIOGO    LM    7,8,0(5)                                        @SC87275 08526000
         BAL   9,RIORAW      Log it                            @SC86316 08527000
         LA    0,4           Write                             @SC86295 08528000
         KCALL (4),(5),E=(RIOER,M)                             @SC87275 08529000
         CLI   TRMTP,C'G'                                      @SC87215 08530000
         BE    SIOGOOD       No immediate answer if graphics   @SC87215 08531000
         LA    0,5                                             @SC86295 08532000
         KCALL (4),8(5),E=(RIOER,M) Read it now                @SC87275 08533000
         CLI   WRRD,0        Write/read?                       @SC86301 08534000
         BE    SIOGOOD       No, ignore bare status            @SC86301 08535000
         LTR   15,15                                           @TB87009 08536000
         BP    SIOCOM                                          @TB87009 08537000
         CLI   TRMTP,C'T'                                      @SC87275 08538000
         BE    SIOCOM        No problem if TTY                 @SC87275 08539000
         CLI   TRMTP,C'F'                                      @SC87300 08540000
         BE    SIOCOM        No problem if TTY                 @SC87300 08541000
* If only 3 bytes (AID and cursor) come in, VTAM has caused    @TB87009 08542000
* the S/1 to discard its transparent data. Fill the screen and @TB87009 08543000
* read it back in protocol conversion mode to cause VTAM       @TB87009 08544000
* to put up a longer READ MODIFIED CCW at its next read.       @TB87009 08545000
         LA    0,6           Message (Leave Transparent Mode)  @TB87009 08546000
         KCALL SCRNIO,SIORTPL,E=(SIORTY,M)                     @TB87009 08547000
         LA    0,5                                             @TB87009 08548000
         KCALL SCRNIO,S1RDPL,E=(RIOER,M) Rdmod to prime VTAM.  @TB87009 08549000
SIORTY   SR    15,15         No data actually seen.            @TB87009 08550000
SIOCOM   DS    0H                                              @TB87009 08551000
         ST    15,RIOC               save residual byte count           08552000
SIOGOOD  NI    FL1,255-NAK0  Something sent now                @SC86295 08553000
         B     RTRN0                                           @SC86295 08554000
*                                                                       08555000
SIOTTY   L     1,TYWRPL      Skip S/1 stuff                    @SC86295 08556000
         SR    2,1           Length to write                   @SC86154 08557000
         ST    2,TYWRPL+4    Length                            @SC86295 08558000
         LA    15,ATOE       Send in EBCDIC                    @SC86202 08559000
         TM    FL4,TTAB      Using separate terminal tables?   @SC87117 08560000
         BZ    *+8           No                                @SC87117 08561000
         LA    15,TATOE      Yes                               @SC87117 08562000
         LR    3,2           Length                            @SC87281 08563000
         LR    2,1                                             @SC86202 08564000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08565000
         L     4,ATERMIO     I/O routine for TTY               @SC87275 08566000
         LA    5,TYWRPL      1st plist                         @SC87275 08567000
         B     SIOGO         Now do it                         @SC87275 08568000
*                                                              @TB87009 08569000
SIORTPL  DC    A(SIOMSGXX,SIOMSL)                              @TB87009 08570000
* Greetings for ERROR mode                                     @TB87009 08571000
SIOMSGXX DC    X'&S1CMD',AL1(SBA),X'4040'                      @TB87009 08572000
         DC    C'S/1 VTAM Error Recovery '                     @TB87009 08573000
         DC    X'3C5D7F40'   Repeat blanks to end of screen    @TB87009 08574000
SIOMSL   EQU   *-SIOMSGXX                                      @TB87009 08575000
         LOCALS ,                                              @SC86295 08576000
SIORIO   DS    C             Operation code                    @SC86316 08577000
SIO      EXIT                                                           08578000
         TITLE 'INTINI Routine - Initialize console for protocol'       08579000
* If R1 is 0, reset the traps unless in Server mode.                    08580000
* If R1 is positive, set up console traps for protocol:                 08581000
*  1 for SERVER, 2 for SEND, 3 for RECEIVE, 4 for short msg    @SC86184 08582000
* R15 = 0 on return if ok                                               08583000
*                                                                       08584000
INTINI   ENTER                                                          08585000
         MVI   WRRD,5        Reset w/r flag                    @SC86184 08586000
         TM    FL2,SRV                                                  08587000
         BO    INTINIR               Return if server running           08588000
         LTR   3,1           Call type: 0 or 1-5               @HF86232 08589000
         BZ    INTINICL              If R1 is 0 clear traps             08590000
         OI    FL2,PROTO     Line open for transfer            @SC86295 08591000
         ICM   5,15,LCLDLY   No delay?                         @HF86232 08592000
         BNZ   INTINIDL                                        @HF86232 08593000
         LA    1,5           Yes, use no message               @HF86232 08594000
INTINIDL C     1,F5          No delay or non-protocol send?    @HF86232 08595000
         BE    INTINIMS      Yes                               @HF86232 08596000
         BCT   5,INTINIMS    Short delay?                      @HF86232 08597000
         LA    1,4           Yes, use short message anyway     @SC86184 08598000
INTINIMS SLL   1,3           8-byte indexing                   @HF86232 08599000
         LA    5,INTCCWSR-8(1)  Get ptr to correct CCW         @SC86184 08600000
         MVC   SVHND,S1HND   Save handshake character          @SC87343 08601000
         KCALL SETMSG,2,E=INTINERR Prepare line for transfer   @SC87300 08602000
         LA    0,2                                             @SC87309 08603000
         SR    0,3                                             @SC87309 08604000
         LPR   0,0           Get ABS(code-2)                   @SC87309 08605000
         BCT   0,*+8         Test for Serve or Rec codes (1,3) @SC87309 08606000
         OI    FL1,NAK0      Send NAK during retry, if any     @SC87309 08607000
         MVI   RIOC,X'80'    Clr any prev byte count           @SC86295 08608000
         CLI   TRMTP,C'T'                                      @SC87166 08609000
         BE    INTINITY      Go if TTY                         @SC87166 08610000
         CLI   TRMTP,C'F'                                      @SC87300 08611000
         BE    INTINITY      Go if TTY                         @SC87300 08612000
         LA    0,1           Open screen                       @SC86295 08613000
         KCALL SCRNIO                                          @SC86295 08614000
         LA    0,6           Simple write                      @SC86316 08615000
         KCALL SCRNIO,(5),E=(INTINIR,M)  Message               @SC86295 08616000
         C     3,F2          Was this SEND?                    @SC86184 08617000
         BE    INTINIR               SEND does sleep anyway             08618000
         ICM   0,15,LCLDLY   See if speed wanted               @SC87253 08619000
         BZ    INTINIP       Yes, no greetings anyway          @SC87309 08620000
         LA    0,1           Wait 1 sec                        @SC86295 08621000
         KCALL SUPFNC,9      This seems essential              @SC86295 08622000
INTINIP  CLI   TRMTP,C'G'    Graphics terminal?                @SC87309 08623000
         BNE   INTINIR       No, go ahead                      @SC87309 08624000
         TM    FL1,NAK0      Will we receive?                  @SC87309 08625000
         BZ    *+8           No, fine                          @SC87309 08626000
         BAL   2,SENDNAK     Yes, must prompt hardware         @SC87309 08627000
         B     INTINIR                                                  08628000
*                                                                       08629000
INTINITY L     1,0(5)        Text address from ccw             @SC86184 08630000
         LH    4,6(5)        Get total length                  @SC86184 08631000
         LA    3,INTPRL(1)   Skip over WCC and SBA             @SC86184 08632000
         SH    4,*-2          and deduct that from length      @SC86184 08633000
         C     4,F64                                           @SC86184 08634000
         BL    INTINIT2      Just one (short) line             @SC86184 08635000
         LA    4,80                  Length to type                     08636000
         WTEXT (3),(4)                                                  08637000
         LA    3,80(3)               Next line                          08638000
INTINIT2 WTEXT (3),(4)                                         @SC86184 08639000
         LA    0,1                                             @SC86295 08640000
         KCALL TERMIO        Open line                         @SC86295 08641000
         B     INTINIR                                                  08642000
*                                                                       08643000
INTINICL TM    FL2,PROTO     Was line open?                    @SC86295 08644000
         BZ    INTINIR       No                                @SC86295 08645000
         LA    0,2                                             @SC86295 08646000
         L     15,ATERMIO                                      @SC87300 08647000
         CLI   TRMTP,C'T'                                      @SC87300 08648000
         BE    INTINIK       Go if TTY                         @SC87300 08649000
         CLI   TRMTP,C'F'                                      @SC87300 08650000
         BE    INTINIK       Go if 3708/fullscreen             @SC87300 08651000
         L     15,ASCRNIO                                      @SC87300 08652000
INTINIK  KCALL (15)          Release line                      @SC87300 08653000
         KCALL SETMSG,3                                        @SC86316 08654000
         MVC   S1HND,SVHND   Restore handshake character       @SC87343 08655000
INTINIR  B     RTRN0                                           @SC87300 08656000
*                                                                       08657000
INTINERR NI    FL2,255-PROTO Turn off protocol mode            @SC87300 08658000
         MVI   ERRNUM,ERRCOM Bad comm line                     @SC87300 08659000
         B     RTRN1                                           @SC87300 08660000
*                                                                       08661000
         DS    0D                                                       08662000
INTCCWSR DC    A(INTMSGSR,INTPRL+80+80)                        @SC86295 08663000
INTCCWSN DC    A(INTMSGSN,INTPRL+80+80)                        @SC86295 08664000
INTCCWRC DC    A(INTMSGRC,INTPRL+80+80)                        @SC86295 08665000
INTCCWQU DC    A(INTMSGQU,INTQL)                               @SC86295 08666000
INTCCWNL DC    A(INTMSGQU,INTPRL)                              @SC86295 08667000
* Short greetings                                              @SC86184 08668000
INTMSGQU DC    X'&S1CMD',AL1(SBA),X'4040'                      @SC86295 08669000
INTPRL   EQU   *-INTMSGQU    Length of prefix                  @SC86295 08670000
INTMSGQ2 DC    C'Kermit-&KSYS....'                             @SC86268 08671000
INTQL    EQU   *-INTMSGQU                                      @SC86184 08672000
* Greetings for RECEIVE mode                                            08673000
INTMSGRC DC    X'&S1CMD',AL1(SBA),X'4040'                      @SC86295 08674000
 DC CL80'Kermit-&KSYS ready to receive.'                       @SC86268 08675000
 DC CL80'Please escape to local Kermit now to SEND the file(s).'        08676000
* Greetings for SEND mode                                               08677000
INTMSGSN DC    X'&S1CMD',AL1(SBA),X'4040'                      @SC86295 08678000
 DC CL80'Kermit-&KSYS ready to send.'                          @SC86268 08679000
 DC CL80'Please escape to local Kermit now to RECEIVE the file(s).'     08680000
* Greetings for SERVER mode                                             08681000
INTMSGSR DC    X'&S1CMD',AL1(SBA),X'4040'                      @SC86295 08682000
 DC CL80'Entering server mode.  Please escape to local Kermit now.'     08683000
 DC CL80'To terminate the server use the BYE or FINISH commands.'       08684000
*                                                                       08685000
         LOCALS ,                                              @SC86295 08686000
INTINI   EXIT                                                           08687000
         TITLE 'INBUF Routine - read next disk record into WBUF'        08688000
* Exit: R15=0 if ok, -1 if EOF, 1 if read error (ERRNUM set)            08689000
INBUF    ENTER                                                          08690000
         TM    FL1,EOF                                                  08691000
         BO    RTRNM1        Go if hit eof already             @SC86295 08692000
         SR    15,15         In case reading from memory       @SC86158 08693000
         ST    15,RBUFP      Clear read buffer pointer         @SC86158 08694000
         ST    15,RBUFL      Clear read buffer length          @SC86158 08695000
         L     9,RBUF        Read into this buffer             @SC86158 08696000
         TM    FL4,SFM       Source is memory?                 @SC86158 08697000
         BZ    IBFDSK        No, read disk                     @SC86158 08698000
         LM    4,5,TXTPTR    Yes, copy to buffer               @SC86158 08699000
         CR    4,5           Any left?                         @SC86158 08700000
         BNL   IBFEOF        No, quit                          @SC86158 08701000
         XC    CMD,CMD                                         @SC86158 08702000
         MVI   CMD+X'15',1   Set up TRT                        @SC86158 08703000
         MVC   0(256,9),0(4) Copy one line or so               @SC86158 08704000
         LA    1,256(4)      In case no NL                     @SC86158 08705000
         TRT   0(256,4),CMD  Scan for NL                       @SC86158 08706000
         CR    1,5           No X'15'?                         @SC86158 08707000
         BNH   *+6           OK                                @SC86158 08708000
         LR    1,5           Limit is end of data              @SC86158 08709000
         SR    1,4           Length of line                    @SC86158 08710000
         LA    4,1(1,4)                                        @SC86158 08711000
         ST    4,TXTPTR      Update ptr                        @SC86158 08712000
         LR    0,1           Save length                       @SC86158 08713000
         B     IBFXLAT       Go change to ASCII                @SC86158 08714000
IBFDSK   DS    0H                                              @SC86158 08715000
         ICM   2,15,RDWLEN   Special format?                   @SC86151 08716000
         BZ    *+6           No                                @SC86151 08717000
         AR    9,2           Space over record descriptor      @SC86151 08718000
         READF FILPTR,BUFFER=(9),E=IBFERR                      @SC87034 08719000
         LM    14,15,DSKTOT  Update disk count                 @SC86295 08720000
         ALR   15,0                                            @SC86295 08721000
         BNO   *+8                                             @SC86295 08722000
         AL    14,F1                                           @SC86295 08723000
         STM   14,15,DSKTOT  Save new count                    @SC86295 08724000
         LTR   2,2           Special format?                   @SC86151 08725000
         BZ    IBFNRM        No                                @SC86151 08726000
         SR    9,2           Back up to start of buffer        @SC86151 08727000
         STCM  0,3,0(9)      Store length                      @SC86151 08728000
         C     2,F2          Short?                            @SC86262 08729000
         BE    IBFVLEN       Yes                               @SC86262 08730000
         CVD   0,TMPDW       No, use 5-byte ASCII              @SC86262 08731000
         OI    TMPDW+7,15                                      @SC86262 08732000
         UNPK  0(5,9),TMPDW                                    @SC86262 08733000
         TR    0(5,9),ETOA                                     @SC86262 08734000
IBFVLEN  DS    0H                                              @SC86262 08735000
         AR    0,2                                             @SC86151 08736000
         B     IBFLEN        Must be binary                    @SC86151 08737000
IBFNRM   DS    0H                                              @SC86151 08738000
         TM    FL1,BINF                                                 08739000
         BO    IBFLEN                No trans for binary file           08740000
         ICM   1,15,RMARG    Text file: check margins          @SC87253 08741000
         BZ    IBFCKLM       No right margin specified         @SC87253 08742000
         CR    0,1                                             @SC87253 08743000
         BNH   IBFCKLM       Record is shorter than margin     @SC87253 08744000
         LR    0,1           Truncate record at margin         @SC87253 08745000
IBFCKLM  L     1,LMARG                                         @SC87253 08746000
         S     1,F1                                            @SC87253 08747000
         BNP   IBFXLAT       No left margin, or start in col 1 @SC87253 08748000
         SR    0,1           See if record is long enough      @SC87253 08749000
         BNP   IBFEMPT       Too short, make empty record      @SC87253 08750000
         LR    2,9           Ptr to record                     @SC87253 08751000
         LR    3,0           Shortened length                  @SC87253 08752000
         LA    4,0(1,2)                                        @SC87253 08753000
         LR    5,3                                             @SC87253 08754000
         MVCL  2,4           Eliminate stuff before margin     @SC87253 08755000
IBFXLAT  LA    15,ETOA       Change to ASCII                   @SC86202 08756000
         LR    2,9           Address                           @SC86202 08757000
         LR    3,0           Length                            @SC86202 08758000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08759000
         AR    9,0           Point one past last char                   08760000
IBFTRUNC BCTR  9,0                   Back up one                        08761000
         CLI   0(9),ABL                                                 08762000
         BNE   IBFLCHAR              Found non-blank                    08763000
         BCT   0,IBFTRUNC            FIND LAST CHAR                     08764000
IBFEMPT  SR    0,0           Record is empty                   @SC87253 08765000
         BCTR  9,0           Empty record                      @SC86119 08766000
IBFLCHAR MVI   1(9),CR       Add CR                            @SC86135 08767000
         MVI   2(9),ALF      Add LF                            @SC86135 08768000
         A     0,F2                  Two extra bytes of data            08769000
IBFLEN   ST    0,RBUFL               LRECL or LRECL + 2 (FOR CRLF)      08770000
         B     RTRN0                                                    08771000
*                                                                       08772000
IBFEOF   OI    FL1,EOF                                                  08773000
         B     RTRNM1                                          @SC86295 08774000
*                                                                       08775000
IBFERR   C     15,F12                EOF code?                          08776000
         BE    IBFEOF                Yes                                08777000
         ERRF  ,             Disk read error, analyze it       @SC87338 08778000
         CLOSF FILPTR        Close file                        @SC86295 08779000
         B     RTRN1                                           @SC86295 08780000
         LOCALS ,                                              @SC86295 08781000
INBUF    EXIT                                                           08782000
         TITLE 'OUTBUF Routine - write WBUF to a disk file'             08783000
OUTBUF   ENTER                                                          08784000
         L     9,WBUFL               Amount of data to write            08785000
         SR    6,6                                             @SC86295 08786000
         ICM   6,3,LRECL     Use to hold lrecl                 @SC86295 08787000
         L     7,WBUF                Address of buffer                  08788000
         ICM   2,15,RDWLEN                                     @SC86151 08789000
         BZ    OBFNRM                                          @SC86151 08790000
         SR    1,1           Special format                    @SC86151 08791000
         ICM   1,3,0(7)      Get true record length            @SC86151 08792000
         C     2,F2          Short?                            @SC86262 08793000
         BE    OBFVLEN       Yes                               @SC86262 08794000
         PACK  TMPDW,0(5,7)  No, must be 5-byte ASCII          @SC86262 08795000
         OI    TMPDW+7,15    Get + sign                        @SC86262 08796000
         CVB   1,TMPDW       Convert back to binary            @SC86262 08797000
OBFVLEN  DS    0H                                              @SC86262 08798000
         AR    7,2           Skip over descriptor              @SC86151 08799000
         SR    9,2           Correct length                    @SC86151 08800000
         L     15,FILPTR     Ptr to disk FAB                   @SC87351 08801000
         MVC   FABCOMM-FABD(8,15),=CL8'Binary'                 @SC87351 08802000
         LA    15,15         Suitable disk error               @SC86151 08803000
         CR    1,9           Match?                            @SC86151 08804000
         BNZ   OBFERR        No, give up                       @SC86151 08805000
         B     OBFLEN        Do it                             @SC87351 08806000
OBFNRM   DS    0H                                              @SC86151 08807000
         TM    FL1,BINF                                                 08808000
         BO    OBFLEN                Go if binary data file             08809000
         LTR   9,9                   Any data to write?                 08810000
         BNZ   OBFTR                 Yes, there's data                  08811000
         MVI   0(7),ABL              Make first char a space            08812000
         LA    9,1                   Length of one                      08813000
OBFTR    LA    15,ATOE       Change to EBCDIC                  @SC86202 08814000
         LR    2,7                                             @SC86202 08815000
         LR    3,9           Length                            @SC86202 08816000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08817000
OBFLEN   CLI   FRECF,C'F'                                      @SC87012 08818000
         BNE   OBFWRT        Go if variable format             @SC87012 08819000
         TM    FL3,APPN      Appending to old file?            @SC86203 08820000
         BZ    *+8           No, use LRECL                     @SC86203 08821000
         L     6,FSIZE       Yes, use old size                 @SC86203 08822000
         CR    9,6                   Compare data length and lrecl      08823000
         BE    OBFWRT        Go if lrecl exactly               @SC87268 08824000
         BH    OBFTRNC       Go if must truncate               @SC87268 08825000
         LR    1,6                   Else, get lrecl size               08826000
         SR    1,9                   Pad with this many spaces          08827000
         LA    0,0(9,7)              Where to start padding             08828000
         SR    15,15                                           @SC86295 08829000
         TM    FL1,BINF                                        @SC86295 08830000
         BO    *+8                                             @SC86295 08831000
         ICM   15,8,BLANK    Pad with spaces                   @SC86295 08832000
         MVCL  0,14                  Do it                              08833000
         B     OBFLRECL      And note new length               @SC87268 08834000
OBFTRNC  LA    0,1                                             @SC87268 08835000
         A     0,RECTRC                                        @SC87268 08836000
         ST    0,RECTRC      Increment count of truncations    @SC87268 08837000
OBFLRECL LR    9,6                   Length has to be this size         08838000
OBFWRT   LM    14,15,DSKTOT  Update disk count                 @SC86295 08839000
         ALR   15,9                                            @SC86295 08840000
         BNO   *+8                                             @SC86295 08841000
         AL    14,F1                                           @SC86295 08842000
         STM   14,15,DSKTOT  Save new count                    @SC86295 08843000
         WRITF FILPTR,BUFFER=(7),BSIZE=(9)                     @SC87034 08844000
         LTR   15,15                 Any disk write errors?             08845000
         BZ    OBFRET                Nope, all OK                       08846000
         MVI   ERRNUM,ERRFUL Maybe disk is full                @SC86345 08847000
         CLM   15,1,ERRNUM   Is it?                            @SC86345 08848000
         BE    OBFRET        Yes, too bad                      @SC86345 08849000
OBFERR   ERRF  ,             General write error, analyze it   @SC87338 08850000
OBFRET   RET                                                            08851000
         LOCALS ,                                              @SC86295 08852000
OUTBUF   EXIT                                                           08853000
         END   KERMIT                                                   08854000
