*COPY                                                 IK0PRO            07500000
         CHECKVER IK0PRO,4.3                                   @SC90072 07500500
         TITLE 'SERVER Routine - performs Server mode functions'        07501000
* Exit: ERRNUM set appropriately.                                       07501500
SERVER   ENTER                                                          07502000
         LA    0,SRVKFIN                                       @SC86295 07502500
         L     1,=A(SRVKCMD)                                   @SC87012 07503000
         BAL   14,LOOPS      Set up command loop               @SC86295 07503500
         KCALL INTINI,1,E=SRVXIT Initialize for server         @SC87300 07504000
         OI    FL2,SRV               Server is on                       07504500
         MVI   ERRNUM,ERRNOE No errors yet                     @SC86156 07505000
         XC    SRVIOS,SRVIOS Clear error count                 @SC90289 07505500
         BAL   8,SRVLUP      Set state table                   @SC86135 07506000
* Server mode Rpack interpret input table                      @SC86135 07506500
         DC    AL1(AS),AL3(SRVREC)  Micro wants to send a file @SC86135 07507000
         DC    AL1(AC),AL3(SRVHST)  A host command             @SC86171 07507500
         DC    AL1(AI),AL3(0)       Micro sent parms           @SC86135 07508000
         DC    AL1(AG),AL3(SRVGEN)  A generic command          @SC86135 07508500
         DC    AL1(AK),AL3(SRVKRM)  A KERMIT command           @SC86158 07509000
         DC    AL1(AR),AL3(SRVSND)  Micro wants to get a file  @SC86135 07509500
         DC    XL1'FF',AL3(SRVSTP)  Stop                       @SC88074 07510000
         DC    AL1(00),AL3(SRVILL)  Error routine              @SC86355 07510500
SRVLUP   MVI   SEQ,0         Reset packet number               @SC86135 07511000
         TM    FL3,ZPRO      Must stop?                        @SC88074 07511500
         BO    SRVXIT        Yes, return immediately           @SC88074 07512000
         OI    FL5,NAK0      Resend NAK during retry           @SC90037 07512500
         MVC   SRVTIM,TIMOUT Save time-out limit               @SC86355 07513000
         MVC   TIMOUT,TIMOSRV Set for server mode              @SC90045 07513500
         MVC   LIMTRY,F5     Error loop 5 times for command    @SC86355 07514000
         MVC   OLDERR,ERRNUM Save for STATUS                   @SC86158 07514500
         MVC   SRVIOE,SRVIOS Current error count               @SC90289 07515000
         XC    SRVIOS,SRVIOS Clear count in case no new error  @SC90289 07515500
         BAL   9,INPUT       Read a packet and interpret       @SC86295 07516000
         MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07516500
         KCALL SPARSET       Set up for exchange               @SC86152 07517000
         KCALL SPAR          Interpret I packet from other              07517500
         KCALL RPAR          Reply to the I packet                      07518000
         BAL   2,SENDACKL            Send an ACK, length set            07518500
         MVC   ERRNUM(2),OLDERR Restore previous error code    @SC90059 07519000
         B     SRVLUP        Loop again no matter what                  07519500
*                                                                       07520000
SRVREC   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07520500
         XC    SCANPTR,SCANPTR                                 @SC86295 07521000
         LA    0,FFRCF                                         @SC86295 07521500
         KCALL FSPEC,FILNAM  Get filespec                      @SC86295 07522000
         KCALL INTINI,3,E=SRVXIT                               @SC87300 07522500
         KCALL RECEIV        Get the file                               07523000
         B     SRVLUP                End of file protocol               07523500
*                                                                       07524000
SRVSND   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07524500
         BAL   9,DECODEN     Decode the file name              @SC86295 07525000
         ICM   0,B'1111',WBUFL       decoded name length                07525500
         BNP   SRVMOP                                          @SC88323 07526000
         L     1,WBUF                Decoded data                       07526500
SRVSNT   STM   0,1,SCANPTR                                     @SC86295 07527000
         LA    0,FFSND                                         @SC86295 07527500
         KCALL FSPEC,IFILE,E=SRVERP   Get filespec             @SC86295 07528000
         XC    SCANPTR,SCANPTR                                 @SC86295 07528500
         LA    0,FFSND+FFRCF                                   @SC86295 07529000
         KCALL FSPEC,JFSPEC,E=SRVERP  Get filespec             @SC86295 07529500
SRVSNC   MVC   MSNDPTR,MSNDBUF No extra files                  @SC88306 07530000
         KCALL SEND,0                                          @SC90239 07530500
         B     SRVLUP                Go around again                    07531000
*                                                                       07531500
SRVGEN   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07532000
         BAL   9,DECODEN     Decode the command                @SC86295 07532500
         ICM   0,15,WBUFL    Decoded command length            @SC86158 07533000
         BNP   SRVMOP                                          @SC88323 07533500
         MVI   ERRNUM,ERRNOE OK so far                         @SC86171 07534000
         BCTR  0,0           Remove command from data length   @SC86158 07534500
         L     1,WBUF        Decoded data                      @SC86158 07535000
         IC    4,0(1)                                          @SC86158 07535500
         BAL   2,CLKP        Dispatch on command               @SC86158 07536000
         DC    AL1(AC),AL3(SRVCWD)  cwd                        @SC86158 07536500
         DC    AL1(AD),AL3(SRVDIR)  directory                  @SC86158 07537000
         DC    AL1(AE),AL3(SRVDEL)  erase                      @SC86158 07537500
         DC    AL1(AF),AL3(SRVFIN)  finish                     @SC86158 07538000
         DC    AL1(AH),AL3(SRVHLP)  help                       @SC86158 07538500
         DC    AL1(AK),AL3(SRVCPY)  copy                       @SC86158 07539000
         DC    AL1(AL),AL3(SRVFIN)  bye                        @SC86158 07539500
         DC    AL1(AR),AL3(SRVREN)  rename                     @SC86158 07540000
         DC    AL1(AT),AL3(SRVTYP)  type                       @SC86158 07540500
         DC    AL1(AU),AL3(SRVQDS)  space                      @SC86158 07541000
         DC    AL1(00),AL3(SRVERS)  Unknown command            @SC86158 07541500
*                                                                       07542000
SRVILL   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07542500
         CLI   ERRNUM,ERRTIE Terminal I/O?                     @SC90289 07543000
         BE    SRVERP        Yes, not just bad command         @SC90289 07543500
SRVERS   MVI   ERRNUM,ERRUSC Unknown Server command            @SC86156 07544000
SRVERP   KCALL SUPFNC,5                                        @SC86158 07544500
         KCALL ERPACK        Send an error packet              @SC86158 07545000
         LA    0,1                                             @SC90289 07545500
         AL    0,SRVIOE      Old I/O error count               @SC90289 07546000
         ST    0,SRVIOS      New count                         @SC90289 07546500
         CL    0,F5          Lots of consecutive errors?       @SC86158 07547000
         BL    SRVLUP        Not yet, OK                       @SC86158 07547500
         B     SRVXIT        Yes, give up now                  @SC86158 07548000
*                                                                       07548500
SRVMOP   MVI   ERRNUM,ERRMOP Missing operand                   @SC88323 07549000
         B     SRVERP                                          @SC86158 07549500
*                                                                       07550000
SRVHST   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07550500
         BAL   9,DECODEN     Get command for host              @SC86171 07551000
         BAL   9,SRVGPRW     To EBCDIC, start interception     @SC86295 07551500
         B     LUPHST        Do it                             @SC86295 07552000
*                                                                       07552500
SRVKRM   MVC   TIMOUT,SRVTIM Restore timeout setting           @SC86355 07553000
         BAL   9,DECODEN     Get command for Kermit            @SC86295 07553500
         BAL   9,SRVGPRW     To EBCDIC, start interception     @SC86295 07554000
         B     LUPTOK        Parse command                     @SC87012 07554500
*                                                                       07555000
SRVKF0   MVI   ERRNUM,ERRNOE No errors                         @SC86295 07555500
SRVKFIN  MVC   OLDERR,ERRNUM Save error code                   @SC86295 07556000
         KCALL SUPFNC,2      Clean up after interception       @SC86295 07556500
SRVKFTX  LM    4,5,TXTPTR                                      @SC86158 07557000
         SR    5,4           Any?                              @SC86158 07557500
         LA    2,SRVLUP      Return adr                        @SC86158 07558000
         BNP   SENDACK       No, just ACK command              @SC86158 07558500
         LA    3,1023(5)     Round up                          @SC86158 07559000
         SRA   3,10          Convert to kbytes                 @SC86158 07559500
         ST    3,KBYTES                                        @SC86158 07560000
         OI    FL4,SFM+TXT                                     @SC86158 07560500
         XC    FLNOPTS(LFOPTS),FLNOPTS                         @SC91116 07561000
         MVC   MSNDPTR,MSNDBUF No extra files                  @SC88306 07561500
         KCALL SEND,0        Send all                          @SC90239 07562000
         CLI   ERRNUM,ERRNOE Problem with SEND?                @SC86295 07562500
         BNE   SRVLUP        Yes, remember that                @SC86295 07563000
         MVC   ERRNUM(2),OLDERR No, use code from commands     @SC90033 07563500
         B     SRVLUP        Get another command               @SC86158 07564000
*                                                                       07564500
SRVTYP   OI    FL4,TXT       Send disk file to remote display  @SC86158 07565000
         BAL   9,SRVGSTR     Get file-spec                     @SC86295 07565500
          B    SRVMOP        None, error                       @SC88323 07566000
         B     SRVSNT                                          @SC86158 07566500
*                                                                       07567000
*        Send remote help message to other system              @SC86158 07567500
SRVHLP   LA    4,RMHTXT      Where to copy HELP TEXT from      @SC86158 07568000
         LA    5,RMHTXTZ     End of text                       @SC86158 07568500
         STM   4,5,TXTPTR                                      @SC86158 07569000
         B     SRVKFTX                                         @SC86158 07569500
*                                                                       07570000
SRVDIR   BAL   3,SRVUTL                                        @SC86295 07570500
         DC    AL1(13,4+1)   Wild matches                      @SC86295 07571000
*                                                                       07571500
SRVDEL   BAL   3,SRVUTL                                        @SC86295 07572000
         DC    AL1(14,0+1)   No wild matches                   @SC86295 07572500
*                                                                       07573000
SRVREN   BAL   3,SRVUTL                                        @SC86295 07573500
         DC    AL1(15,4+2)   Wild matches                      @SC86295 07574000
*                                                                       07574500
SRVCPY   BAL   3,SRVUTL                                        @SC86295 07575000
         DC    AL1(16,0+2)   No wild matches                   @SC86295 07575500
*                                                                       07576000
SRVCWD   BAL   9,SRVGSTR     Get operand                       @SC86295 07576500
          B    SRVMOP                                          @SC88323 07577000
         BAL   9,SRVGPRM     Convert to plist                  @SC86295 07577500
         MVI   ERRNUM,ERRFNF In case of error                  @SC86158 07578000
         KCALL CWDSET,E=SRVERP                                 @SC86158 07578500
         B     SRVKF0        No errors                         @SC86295 07579000
*                                                                       07579500
SRVQDS   BAL   9,SRVGSTR     Extract letter                    @SC86295 07580000
          LA   0,0           None, use default                 @SC86158 07580500
         BAL   9,SRVGPRM                                       @SC86295 07581000
         B     LUPSPA                                          @SC86295 07581500
* Generate command PLIST: R3-> parms                           @SC86158 07582000
SRVUTL   LA    2,FILNAM      1st or only filespec              @SC86295 07582500
         LH    4,0(3)                                          @SC86295 07583000
         N     4,F3          Get number of names               @SC86295 07583500
SRVUTLP  XC    SCANPTR,SCANPTR                                 @SC86295 07584000
         BAL   9,SRVGSTR     Extract file-spec                 @SC86295 07584500
          B    SRVUT1        None, check if wildcard allowed   @SC86158 07585000
         STM   0,1,SCANPTR                                     @SC86295 07585500
SRVUT1   LA    0,FFUTL                                         @SC86295 07586000
         TM    1(3),4        Test flag                         @SC86295 07586500
         BZ    *+8                                             @SC86295 07587000
         LA    0,FFUTL+FFWLD Wild match if part omitted        @SC86295 07587500
         KCALL FSPEC,(2),E=SRVERP  Get filespec into command   @SC86295 07588000
         LR    0,6           Length remaining                  @SC86158 07588500
         LR    1,7           Next field                        @SC86158 07589000
         LA    2,IFILE       2nd ptr                           @SC86158 07589500
         BCT   4,SRVUTLP     Loop over file-specs              @SC86158 07590000
         KCALL SUPFNC,1      Start interception                @SC86158 07590500
         MVI   ERRNUM,ERRFNF File not found if error here      @SC90264 07591000
         CLC   0(1,3),SRVDIR+4                                 @SC86158 07591500
         BE    SRVUT6        Don't issue STATE if DIR cmd      @SC86158 07592000
         OPENF V,FILNAM,E=SRVERP Verify its existence          @SC91269 07592500
         MVI   ERRNUM,ERRKCE In case of any other problem      @SC90264 07593000
SRVUT6   LA    1,FILNAM      1st or only filespec              @SC86295 07593500
         LA    2,IFILE       Possible 2nd                      @SC86295 07594000
         XR    0,0                                             @SC86295 07594500
         IC    0,0(3)                                          @SC86295 07595000
         KCALL DISKIO,E=SRVERP                                 @SC90264 07595500
         MVI   ERRNUM,ERRNOE No problem                        @SC90264 07596000
         B     SRVKFIN                                         @SC86295 07596500
* Get substring from Generic command                           @SC86158 07597000
* R0= no. of chars left in packet excluding substr count byte  @SC86158 07597500
* R1-> one before count byte                                   @SC86158 07598000
SRVGSTR  MVI   ERRNUM,ERRIPS Assume missing operand            @SC88323 07598500
         BCTR  0,0           Remove operand length field       @SC86158 07599000
         LA    7,1(1)        ditto                             @SC86158 07599500
         LTR   6,0           If no operands                    @SC86158 07600000
         BNPR  9              then return error                @SC86295 07600500
         UNCHR 0,1(1)        Operand size                      @SC86158 07601000
         BZR   9             Error if zero length field        @SC86295 07601500
         BM    SRVERP        Really bad                        @SC88323 07602000
         LA    1,2(1)        Location of operand               @SC86158 07602500
         AR    7,0           Get ptr to next field             @SC86158 07603000
         SR    6,0           Length remaining                  @SC86158 07603500
         BM    SRVERP        Inconsistant                      @SC88323 07604000
         B     4(9)                                            @SC86295 07604500
* Set up copy                                                           07605000
SRVGPRW  ICM   0,15,WBUFL                                      @SC86171 07605500
         BNP   SRVMOP        No text                           @SC88323 07606000
         L     1,WBUF        Ptr to text                       @SC86171 07606500
* Copy parameter at (R1), length in R0 and set up interception @SC86158 07607000
SRVGPRM  LTR   15,0          Any chars?                        @SC86171 07607500
         BNP   SRVGPS        No                                @SC86171 07608000
         BCTR  15,0          Yes, translate                    @SC86171 07608500
         LA    14,ATOE        Current A-to-E                   @SC91284 07609000
         CLC   =C'&TRANSPA',TRNALF                             @SC91284 07609500
         BNE   *+8                                             @SC91284 07610000
          LA   14,ATOED      Use default if "transparent"      @SC91284 07610500
         EX    15,SRVGPTRA                                     @SC91284 07611000
         EX    15,TRUPCAS                                      @SC86171 07611500
SRVGPS   STM   0,1,SCANPTR   Save string ptrs                  @SC86158 07612000
         KCALL SUPFNC,1      Start intercepting                @SC86158 07612500
         BR    9                                               @SC86295 07613000
SRVGPTRA TR    0(,1),0(14)                                     @SC91284 07613500
*                                                                       07614000
SRVFIN   MVI   WRRD,0                Just write (no read) when ending   07614500
         MVI   AEAFLG,X'80'  ditto                             @SC90173 07615000
         MVC   S1HND,SVHND   Always use requested handshake    @SC87343 07615500
         BAL   2,SENDACK             Send an ACK                        07616000
         L     1,WBUF        Ptr to decoded data               @SC86190 07616500
         CLI   0(1),AL                                         @SC86190 07617000
         BNE   SRVNOLOG      Skip logging out                  @SC86295 07617500
         CLOSF LOGPTR        Close debug-log                   @SC86135 07618000
         KCALL SUPFNC,8      Log out                           @SC86295 07618500
SRVNOLOG DS    0H            (or fall through just in case)    @SC86295 07619000
         MVC   ERRNUM(2),OLDERR Copy back error number         @SC90033 07619500
SRVXIT   NI    FL2,255-SRV   Turn off SERVER mode              @SC86158 07620000
         KCALL INTINI,0      Clear interrupt trapping                   07620500
         RET                                                            07621000
*                                                                       07621500
SRVSTP   MVC   TIMOUT,SRVTIM Restore timeout                   @SC88074 07622000
         B     SRVXIT                                          @SC88074 07622500
*                                                                       07623000
RMHTXT   EQU   *                                               @SC92300 07623500
** BEGIN LANGUAGE-SPECIFIC DATA **                             @SC92300 07624000
         DC    C'Kermit-&KSYS. Server handles the following:'  @SC86268 07624500
         DC    X'1515'                                         @SC86158 07625000
         DC C'Function          Standard command',X'15'        @SC86158 07625500
         DC C'--------          ----------------',X'1515'      @SC86158 07626000
         DC C'Send a file       SEND file',X'15'               @SC86158 07626500
         DC C'Retrieve a file   GET file',X'15'                @SC86158 07627000
         DC C'Log off system    BYE or LOGOUT',X'15'           @SC86158 07627500
         DC C'Exit from server  FINISH',X'15'                  @SC86158 07628000
         DC C'Issue Kermit cmd  REMOTE KERMIT cmd',X'15'       @SC86158 07628500
         DC C'Issue system cmd  REMOTE HOST [CP] cmd',X'15'    @SC86268 07629000
         DC C'List directory    REMOTE DIRECTORY file',X'15'   @SC86158 07629500
         DC C'Type a file       REMOTE TYPE file',X'15'        @SC86158 07630000
         DC C'Copy a file       REMOTE COPY f1 f2',X'15'       @SC86158 07630500
         DC C'Rename a file     REMOTE RENAME f1 f2',X'15'     @SC86158 07631000
         DC C'Erase a file      REMOTE DELETE file',X'15'      @SC86158 07631500
         DC C'Print a file      REMOTE PRINT file',X'15'       @SC91198 07632000
         DC C'Change disk area  REMOTE CWD area',X'15'         @SC86158 07632500
         DC C'Show disk space   REMOTE SPACE area',X'15'       @SC86158 07633000
** END LANGUAGE-SPECIFIC DATA **                               @SC92300 07633500
RMHTXTZ  EQU   *                                               @SC86158 07634000
         LOCALS ,                                              @SC86295 07634500
RETADR   DS    A             Return adr if no more TAKE stuff  @SC86295 07635000
CMDPTR   DS    A             Adr of command table              @SC86295 07635500
TAKLEV   DS    F             Take file level                   @SC86121 07636000
TAKTAB   DS    (TAKMAX)F     Tickets for I/O                   @SC86295 07636500
SRVTIM   DS    X             Saved timeout limit               @SC86355 07637000
SRVIOE   DS    F             Current terminal I/O error count  @SC90289 07637500
SRVIOS   DS    F             Saved terminal I/O error count    @SC90289 07638000
SERVER   EXIT                                                           07638500
         TITLE 'SEND Routine - sends a file'                            07639000
* Send file(s) and set ERRNUM appropriately                             07639500
* Entry: filespec pattern in IFILE, Disp code (if any) in R1   @SC90239 07640000
SEND     ENTER                                                          07640500
         STC   1,SNDDSP      Save code                         @SC90239 07641000
         XC    NSENTAC(LSTATS),NSENTAC Clear statistics        @SC90179 07641500
         KCALL SUPFNC,10                                       @SC86295 07642000
         ST    15,SECTOT     Save start time                   @SC86295 07642500
         ST    15,TINSV+12   Also for length tuning            @SC88325 07643000
         ST    15,TINSV+28                                     @SC88325 07643500
         ST    15,TINSV+44                                     @SC88325 07644000
         TM    FL4,SFM                                         @SC86295 07644500
         BO    *+10          From memory: keep old file list   @SC86295 07645000
         XC    NSENT,NSENT           Number of files sent               07645500
         MVI   SNFLG,FIRST   Haven't started yet               @SC86295 07646000
         XC    FDATE,FDATE   Clear file date                   @SC86295 07646500
         LA    0,TUNECT      Time to tune up                   @SC88349 07647000
         STH   0,SNPKCT                                        @SC86345 07647500
         MVI   REASON,0      Not rejected yet                  @SC86316 07648000
         MVI   SEQ,0         Reset packet number               @SC86135 07648500
         TM    FL4,SFM                                         @SC88100 07649000
         BO    SNDS8         Just sending from memory          @SC88100 07649500
SNDSET   OI    SNFLG,NEWGRP  Haven't started yet               @SC88306 07650000
       NXTFSET IFILE,E=SNDNON Init for NXTFST call             @SC87012 07650500
SNDS8    LA    8,SNDST       Set state table                   @SC89263 07651000
SNDNXT   CLI   CXZ,AZ                                                   07651500
         BE    SNDBRK        Stop file group send                       07652000
         MVI   FRECF,C'F'    Just in case                      @SC86151 07652500
         TM    FL4,SFM                                         @SC86158 07653000
         BO    SNDNOW        Just sending from memory          @SC86158 07653500
         NXTF  E=SNDNON      Get next/first file               @SC86295 07654000
         MVI   CXZ,0                 In case aborted last file          07654500
         MVI   REASON,0      Not rejected yet                  @SC86316 07655000
         MVC   FLNOPTS(LFOPTS),IFOPTS Copy file options        @SC89218 07655500
         L     5,TSENT       Table of files sent (transactions)@SC90179 07656000
         ICM   4,15,NSENT    Number of files sent              @SC90179 07656500
         AIF   ('&KSYS' NE 'CMS').SOPN                         @SC86295 07657000
         BZ    SNDOPN        Go if none sent yet               @SC86295 07657500
         NI    SNFLG,255-NEWGRP Not first of this group        @SC92300 07658000
SNDTBL   CLC   0(16,5),FILNAM                                  @SC86295 07658500
         BE    SNDNXT                Go if sent already                 07659000
         A     5,FLFID1      Next filespec                     @SC88092 07659500
         BCT   4,SNDTBL                                                 07660000
.SOPN    ANOP                                                           07660500
SNDOPN   OPENF I,FILNAM,FILFDB,FILPTR,E=SNDFNF                 @SC87012 07661000
         USING FDBD,1                                          @SC86295 07661500
         MVC   FRECF,FDBRCF  Save format and file size         @SC86295 07662000
         MVC   KBYTES,FDBSIZE                                  @SC86295 07662500
         MVC   FDATE,FDBDATE Save file date                    @SC86295 07663000
         DROP  1                                               @SC86295 07663500
         KCALL ACCTST,FILNAM Copy name to table                @SC90179 07664000
         POINTF FILPTR,FLNOPTS,E=SNDSHRT Skip, if requested    @SC89218 07664500
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07665000
         BE    SNDNOW        No, be quiet                      @SC87300 07665500
         INITSTR '&SENDING',CMD,REG=7 Yes, display message     @SC92300 07666000
         LA    1,FILNAM                                        @SC87300 07666500
         BAL   2,STAFSP      Format name and show it           @SC87300 07667000
SNDNOW   NI    SNFLG,255-NEWGRP Not first of this group        @SC88306 07667500
         TM    SNFLG,FIRST                                     @SC86295 07668000
         BZ    SNDFIL                Go if not first file               07668500
         NI    SNFLG,255-FIRST No first file flag              @SC86295 07669000
         MVC   LIMTRY,MAXTNT Limit for INIT retries            @SC86345 07669500
         TM    FL4,NPS       Non-protocol?                     @HF86232 07670000
         BZ    SNDPRO        No, normal send message           @HF86232 07670500
         KCALL INTINI,5,E=SNDRET  Initialize for non-protocol  @SC87300 07671000
         B     SNDATZ        Skip protocol stuff               @HF86232 07671500
SNDPRO   KCALL INTINI,2,E=SNDRET  Initialize for send          @SC87300 07672000
         TM    FL2,SRV                                                  07672500
         BO    SNDINI                Go if Server mode                  07673000
         L     0,LCLDLY      Time to wait                      @SC86164 07673500
         KCALL SUPFNC,9                                        @SC86295 07674000
SNDINI   DS    0H                                              @SC86152 07674500
         KCALL RPARSET       Set up for exchange               @SC86152 07675000
         KCALL RPAR          Our S packet to send              @SC86152 07675500
         MVI   STYPE,AS              PACKET TYPE = SEND INITIATE        07676000
         MVC   RTYPPRV,RTYPE Set up in case S packet gets lost @SC89263 07676500
         BAL   9,INPUTSPK    Send RPAR and Interpret response  @SC86295 07677000
         KCALL SPAR          Interpret reply to our S packet            07677500
         MVC   BCTU,BCTR     Switch chk,flg to negotiated one  @SC92085 07678000
         CLI   BCTR,AA       Blank suppression?                @SC92085 07678500
         BL    *+8           No, flag was off already          @SC92085 07679000
          MVI  BCTOFF+3,1    Yes, turn it on                   @SC92085 07679500
         NI    BCTU,15       Use just length here              @SC92085 07680000
         MVC   LIMTRY,MAXTRY Reset limit                       @SC86164 07680500
         BAL   14,INCRSEQ                                               07681000
         CLI   SNDDSP,0      Any special disposition?          @SC90239 07681500
         BE    SNDFIL        No, skip it                       @SC90239 07682000
         TM    RCAPA,8       Yes -- can we send attributes?    @SC90239 07682500
         BZ    SNDCMDER      No.  Give up                      @SC90239 07683000
SNDFIL   MVI   STYPE,AX      Text transmission?                @SC86158 07683500
         TM    FL4,TXT                                         @SC86158 07684000
         BO    *+8           Yes                               @SC86158 07684500
         MVI   STYPE,AF      Packet type = file header         @SC86158 07685000
         XC    DATL,DATL     Null file spec.                   @SC86158 07685500
         TM    FL4,SFM                                         @SC86158 07686000
         BNZ   SNDCNTH       From memory, no file name         @SC86158 07686500
         BAL   9,PAKFIL      Compress to buffer with appends   @HF86223 07687000
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07687500
         BE    SNDFIL2       No, be quiet                      @SC87300 07688000
         INITSTR '&AAAAAAS',CMD  Yes, display message          @SC92300 07688500
         L     1,RBUF        Ptr to name in ASCII              @SC87300 07689000
         MVC   0(250,15),0(1)                                  @SC87300 07689500
         TR    0(250,15),ATOED Back to EBCDIC                  @SC89301 07690000
         AR    15,7          End of msg + name                 @SC87300 07690500
         BAL   2,STAPM15     Show sending name                 @SC87300 07691000
SNDFIL2  DS    0H                                              @SC87300 07691500
SNDCNT   BAL   9,ENCODEN     Encode fn                         @SC86295 07692000
SNDCNTH  BAL   9,INPUTSPK    Send name and interpret response  @SC86295 07692500
         BAL   14,INCRSEQ                                               07693000
         MVC   TMP,SCAPA     Copy my flags                     @SC86149 07693500
         NI    TMP,8         Attributes                        @SC86149 07694000
         NC    TMP,RCAPA     Check if both on                  @SC86149 07694500
         BZ    SNDATZ        No, skip it                       @SC86149 07695000
         L     5,ASDATA                                        @SC86295 07695500
         BAL   2,SNDPKLC     Check length of attribute info    @SC90037 07696000
         ICM   4,15,KBYTES   File length known?                @SC86295 07696500
         BZ    SNDAT0        No, skip it                       @SC86316 07697000
         TM    ATFLG,ATFLNG  Length attribute desired?         @SC90037 07697500
         BZ    SNDAT0        No, skip it                       @SC90037 07698000
         MVI   0(5),AEXCL    Yes, ASCII ! => size              @SC88273 07698500
         LA    15,2(5)                                         @SC86295 07699000
         BAL   2,EDDEC       Format it                         @SC86295 07699500
         TR    2(9,5),ETOAD  Convert plenty to ASCII           @SC88273 07700000
         SR    15,5                                            @SC86295 07700500
         LA    4,ABL-2(15)   Number of digits (printably)      @SC88273 07701000
         STC   4,1(5)                                          @SC86295 07701500
         AR    5,15          End of string                     @SC86295 07702000
SNDAT0   TM    ATFL2,ATFORG  Origin wanted?                    @SC90037 07702500
         BZ    SNDAT0B       No, skip it                       @SC90037 07703000
         BAL   2,SNDPKLC     Check length of attribute info    @SC90037 07703500
         MVC   0(LSYSATR,5),SYSATR                             @SC90037 07704000
         LA    5,LSYSATR(5) System code                        @SC88273 07704500
SNDAT0B  TM    ATFLG,ATFTYP  Type wanted?                      @SC90037 07705000
         BZ    SNDAT1Z       No, skip it and encoding too      @SC90037 07705500
         BAL   2,SNDPKLC     Check length of attribute info    @SC90037 07706000
         MVC   0(3,5),=AL1(ABL+2,ABL+1,AB) "!B - it's binary   @SC88273 07706500
         TM    FL4,SFM       Sending from memory buffer?       @SC90016 07707000
         BO    *+12          Yes, always text file             @SC90016 07707500
         TM    FL1,BINF      Binary file?                      @SC86149 07708000
         BO    SNDAT1        Yes                               @SC86316 07708500
         MVC   2(4,5),=AL1(AA,ABL+10,ABL+1,AA) A*!A - ASCII    @SC88273 07709000
         TM    ATFL2,ATFENC  Encoding wanted?                  @SC90037 07709500
         BZ    SNDAT1        No, skip it                       @SC90037 07710000
         LA    5,3(5)        Advance over extra item           @SC86316 07710500
         ICM   2,15,CDESPTR                                    @SC90040 07711000
         BZ    SNDAT1                                          @SC90040 07711500
         MVI   2(5),AC       Level-1 syntax                    @SC90040 07712000
         SR    1,1                                             @SC90040 07712500
         IC    1,4(,2)       Get length of designator          @SC90040 07713000
         LA    0,ABL+1(,1)   Modified length of ENC attribute  @SC90040 07713500
         STC   0,1(,5)                                         @SC90040 07714000
         MVC   3(11,5),5(2)  Copy plenty of text               @SC90040 07714500
         AR    5,1           Account for extra stuff           @SC90040 07715000
SNDAT1   LA    5,3(5)                                          @SC86316 07715500
SNDAT1Z  TM    ATFL2,ATFFMT  Format wanted?                    @SC90037 07716000
         BZ    SNDAT3        No, skip it                       @SC90037 07716500
         BAL   2,SNDPKLC     Check length of attribute info    @SC90037 07717000
         IC    4,TYPFIL      Specific file type                @SC86295 07717500
         BAL   2,CLKP        Dispatch via table                @SC86295 07718000
         DC    C'T',AL3(SNDATT)  Text                          @SC86295 07718500
         DC    C'D',AL3(SNDATD)  D-binary                      @SC86295 07719000
         DC    C'V',AL3(SNDATV)  V-binary                      @SC86295 07719500
         DC    X'0',AL3(SNDAT3)  Must be Binary                @SC86295 07720000
SNDATT   BAL   2,SNDAT2                                        @SC86295 07720500
         DC    AL1(ABL+3,AA,AM,AJ) #AMJ Delimited              @SC88273 07721000
SNDATD   BAL   2,SNDAT2                                        @SC86295 07721500
         DC    AL1(ABL+2,AD,A5)    "D5  Undelimited 5-byte pref@SC90037 07722000
SNDATV   BAL   2,SNDAT2                                        @SC86295 07722500
         DC    AL1(ABL+2,AV,A2)    "V2  2-byte bin. pref.      @SC90037 07723000
SNDAT2   MVI   0(5),ABL+15   ASCII / => Format                 @SC88273 07723500
         MVC   1(9,5),0(2)   Copy string                       @SC86295 07724000
         UNCHR 4,0(2)        Get length                        @SC88273 07724500
         LA    5,2(4,5)      Update string ptr                 @SC86295 07725000
SNDAT3   CLI   FDATE,0       File date defined?                @SC86295 07725500
         BE    SNDAT5        No, skip it                       @SC90037 07726000
         TM    ATFLG,ATFDAT  Date wanted?                      @SC90037 07726500
         BZ    SNDAT5        No, skip it                       @SC90037 07727000
         BAL   2,SNDPKLC     Check length of attribute info    @SC90037 07727500
         MVC   0(2,5),=AL1(A#,ABL+8) Yes, yyyymmdd (ASCII #)   @SC88273 07728000
         UNPK  2(9,5),FDATE(5) Insert zones                    @SC86295 07728500
         LA    4,10(5)       End of date                       @SC88273 07729000
         CLC   FDATE+4(3),F0 Time defined too?                 @SC88235 07729500
         BE    SNDAT4        No, just use date                 @SC88235 07730000
         MVI   1(5),ABL+17   Yes, add string length - hh:mm:ss @SC88273 07730500
         MVC   10(9,5),TIMPLT and edit time                    @SC88235 07731000
         ED    10(9,5),FDATE+4                                 @SC88235 07731500
         CLI   11(5),C' '                                      @SC88235 07732000
         BNE   *+8                                             @SC88235 07732500
         MVI   11(5),C'0'    Insist on leading zeroes          @SC88235 07733000
         LA    4,9(4)        Advance over time                 @SC88273 07733500
SNDAT4   TR    2(17,5),ETOAD Convert date/time to ASCII        @SC88273 07734000
         LR    5,4           New ptr in either case            @SC88273 07734500
SNDAT5   TM    ATFL2,ATFDSP  Disposition wanted?               @SC90239 07735000
         BZ    SNDAT6        No                                @SC90239 07735500
         CLI   SNDDSP,0                                        @SC90239 07736000
         BE    SNDAT6        No special disposition            @SC90239 07736500
         BAL   2,SNDPKLC     Check length of attribute info    @SC90239 07737000
         MVI   0(5),APLUS    Disposition attribute             @SC90239 07737500
         MVC   2(,5),SNDDSP  Selected code                     @SC90239 07738000
         LM    6,7,LEN       Any options?                      @SC90239 07738500
         LTR   6,6                                             @SC90239 07739000
         BZ    SNDAT5B       No                                @SC90239 07739500
         MVC   3(80,5),0(7)  Yes, allow up to 80 bytes         @SC90239 07740000
         TR    3(80,5),ETOAD Convert to ASCII                  @SC90239 07740500
SNDAT5B  LA    2,1(,6)       Length of code + options          @SC90239 07741000
         TOCHR 2,,1(,5)      Save in packet                    @SC90239 07741500
         LA    5,3(6,5)      Advance ptr                       @SC90239 07742000
SNDAT6   DS    0H                                              @SC90239 07742500
         TM    ATFL4,ATFEND  End-signal wanted?                @SC91109 07743000
         BZ    SNDATY        No                                @SC91109 07743500
         BAL   2,SNDPKLC     Check length of attribute info    @SC90037 07744000
         MVC   0(2,5),=AL1(A@,ABL)  Zero-length attribute      @SC91109 07744500
         LA    5,2(,5)       Advance ptr                       @SC91109 07745000
SNDATY   BAL   2,SNDPKLC     Check length of attribute info    @SC91109 07745500
         SR    8,8           Unconditionally send all          @SC90037 07746000
         LA    2,SNDATZ      Place to go when done             @SC90037 07746500
         ST    2,SNDPKLR                                       @SC90037 07747000
         B     SNDAT9                                          @SC90037 07747500
* Send A-packet if buffer full.  Use last version that fit.    @SC90037 07748000
SNDPKLC  L     8,MAXSIZ      Set limit for packet              @SC90037 07748500
SNDAT9   L     15,ASDATA                                       @SC86295 07749000
         SR    5,15                                            @SC86295 07749500
         BNP   SNDPKLZ                                         @SC90037 07750000
         CR    5,8           Full yet?                         @SC90037 07750500
         BNH   SNDPKLZ       No, go back for more              @SC90037 07751000
         ICM   8,15,SNDPKLN  Length from last time through     @SC90239 07751500
         BZ    *+6           None. Must be one big attribute   @SC90239 07752000
          LR   5,8           Ok, use it                        @SC90239 07752500
         ST    5,DATL        Set length                        @SC86295 07753000
         LA    8,SNDST       Restore state ptr                 @SC89263 07753500
         MVI   STYPE,AA                                        @SC86149 07754000
         BAL   9,INPUTSPK    Send it                           @SC86295 07754500
         BAL   14,INCRSEQ                                      @SC86149 07755000
         CLC   DATL,F0       Any objections?                   @SC86149 07755500
         BE    SNDPKLX       Ok                                @SC90037 07756000
         L     1,ARDATA                                        @SC86316 07756500
         CLI   0(1),AN       Refused?                          @SC86149 07757000
         BE    SNDCAN        Sigh                              @SC86149 07757500
SNDPKLX  SR    5,5           Clear length to send              @SC90037 07758000
         L     2,SNDPKLR     Will have to redo                 @SC90037 07758500
SNDPKLZ  ST    5,SNDPKLN     Save length available             @SC90037 07759000
         A     5,ASDATA      Restore as ptr into buffer        @SC90037 07759500
         ST    2,SNDPKLR     Where to go if need to redo       @SC90037 07760000
         BR    2                                               @SC90037 07760500
*                                                              @SC90037 07761000
SNDATZ   DS    0H                                              @SC86149 07761500
         NI    FL1,255-EOF           Not end of file yet                07762000
         BAL   14,RDWSET     Check for special format          @SC86151 07762500
         MVI   LCKOLD,0      Start at normal state             @SC91275 07763000
         XC    RBUFL,RBUFL           No data in input buffer            07763500
         MVI   CARCTL,0      Initialize flag, if CC            @SC91116 07764000
         TM    FL4,NPS       Non-protocol?                     @SC86165 07764500
         BO    SNDNPS        Yes, do it                        @SC86165 07765000
SNDENC   KCALL ENCODE,E=SNDENX Encode the data and more                 07765500
SNDDAT   MVI   STYPE,AD              PACKET TYPE = DATA                 07766000
         BAL   9,INPUTSPK    Send data and interpret reply     @SC86295 07766500
         BAL   14,INCRSEQ                                               07767000
         LH    15,SNPKCT                                       @SC86345 07767500
         BCT   15,SNDTUNZ    No tuning yet                     @SC86345 07768000
         CLC   MAXSIZ+4,AKMAX Long packets selected?           @SC86345 07768500
         BNP   SNDTUNY       No                                @SC86345 07769000
         KCALL SUPFNC,10     Get time                          @SC88325 07769500
         ST    15,CSECTOT    Save                              @SC88325 07770000
         KCALL OPTPKT        Calculate optimum size            @SC88325 07770500
         LTR   15,15         Valid?                            @SC86345 07771000
         BNP   SNDTUNY       No                                @SC86345 07771500
         C     15,MAXSIZ+4   Other Kermit's limit              @SC86345 07772000
         BNH   *+8                                             @SC86345 07772500
         L     15,MAXSIZ+4                                     @SC86345 07773000
         C     15,AKMAX                                        @SC86345 07773500
         BNL   *+8                                             @SC86345 07774000
         L     15,AKMAX      Don't get too small               @SC86345 07774500
         ST    15,MAXSIZ     Set send limit                    @SC86345 07775000
SNDTUNY  LA    15,TUNECT     Repeat target                     @SC88349 07775500
SNDTUNZ  STH   15,SNPKCT                                       @SC86345 07776000
         CLC   DATL,F1                                                  07776500
         BNE   SNDENC                Go if no Data in ack               07777000
         L     1,ARDATA                                        @SC86190 07777500
         CLI   0(1),AX                                         @SC86190 07778000
         BE    SNDCAN                Go if Abort sending file           07778500
         CLI   0(1),AZ                                         @SC86190 07779000
         BNE   SNDENC                Go if not Abort sending grp        07779500
SNDCAN   MVC   CXZ,0(1)      Pick up data                      @SC86190 07780000
         MVI   ERRNUM,ERRTRC Send cancelled                    @SC86156 07780500
         CLC   DATL,F2       Any reason given (if A-pkt)       @SC86316 07781000
         BL    SNDEOF        None                              @SC86316 07781500
         UNCHR 2,1(1),REASON Yes, save it                      @SC86316 07782000
SNDEOF   BAL   9,SNDCLS      Close file                        @SC86295 07782500
         KCALL ACCTNG        Save code in table                @SC88092 07783000
         MVI   STYPE,AZ              PACKET TYPE = EOF                  07783500
         XC    DATL,DATL                                                07784000
         L     9,ASDATA                                        @SC86295 07784500
         MVI   0(9),AD       In case of discard                @SC86295 07785000
         CLI   CXZ,0         Aborting this file?               @SC86125 07785500
         BE    *+8           No, ok                            @SC86125 07786000
         MVI   DATL+3,1      Yes, send 'D'                     @SC86125 07786500
         BAL   9,INPUTSPK    Send EOF and Interpret response   @SC86295 07787000
         BAL   14,INCRSEQ                                               07787500
         TM    FL4,SFM                                         @SC86158 07788000
         BO    SNDBRK        Memory has only one 'file'        @SC86158 07788500
         B     SNDNXT                else GET-NEXT-FILE                 07789000
*                                                                       07789500
SNDNPS   MVI   WRRD,0        Set for send only                 @SC86165 07790000
         MVI   AEAFLG,X'80'  ditto                             @SC90173 07790500
SNDNPSL  KCALL NPREAD,E=(SNDABR,P)                             @SC86165 07791000
         CLC   SNDPKL,F0     OK, any data?                     @SC86165 07791500
         BE    SNDNPZ        No, must be done                  @SC86165 07792000
         KCALL SIO,E=SNDABR  Send what we got                  @SC86165 07792500
         TM    FL1,EOF       Any more?                         @SC86165 07793000
         BZ    SNDNPSL       Yes, get it                       @SC86165 07793500
SNDNPZ   BAL   9,SNDCLS      Reached end                       @SC86295 07794000
         MVI   ERRNUM,ERRNOE Set code = no errors              @SC90179 07794500
         KCALL ACCTNG        Save code in table                @SC90179 07795000
         TM    FL4,SFM       Internal file?                    @SC90179 07795500
         BZ    SNDNXT        If not, on to next file (if any)  @SC90179 07796000
         B     SNDBR2        All done                          @SC86165 07796500
*                                                                       07797000
SNDENX   LTR   15,15                 Positive or negative error?        07797500
         BP    SNDABR                Pos: error from ENCODE, not EOF    07798000
         MVI   ERRNUM,ERRNOE No error yet                      @SC88092 07798500
         CLC   DATL,F0                                                  07799000
         BE    SNDEOF                No more data to send               07799500
         B     SNDDAT                Send last chunk                    07800000
*                                                                       07800500
SNDNON   TM    SNFLG,NEWGRP                                    @SC88306 07801000
         BZ    SNDMNXT       Filespec wasn't totally missing   @SC89218 07801500
SNDFNF   MVI   ERRNUM,ERRFNF Not found                         @SC87012 07802000
         KCALL ACCTST,IFILE  Copy name to table                @SC88306 07802500
SNDACT   KCALL ACCTNG        Set error number                  @SC89218 07803000
SNDMNXT  DS    0H                                              @SC89218 07803500
         CLC   MSNDPTR,MSNDBUF Any more filespecs pending?     @SC88306 07804000
         BNH   SNDBRK        No, all done                      @SC88306 07804500
         L     1,MSNDPTR                                       @SC88306 07805000
         SH    1,=Y(LFSTF)   Back up to next filespec          @SC89218 07805500
         ST    1,MSNDPTR     And save new ptr                  @SC88306 07806000
         MVC   IFILE(LFSTF),0(1) Copy out names                @SC89218 07806500
         B     SNDSET        Start all over again              @SC88306 07807000
*                                                                       07807500
SNDBRK   MVC   ERRNUM(2),ERRLAST Last error code+reason code   @SC89218 07808000
         CLI   ERRNUM,ERRNOE Last transfer ok?                 @SC89218 07808500
         BE    SNDBRKP       Yes                               @SC89218 07809000
         TM    SNFLG,FIRST                                     @SC88306 07809500
         BZ    SNDAB2        Send E-packet: transfer started   @SC89218 07810000
         TM    FL2,SRV                                                  07810500
         BO    SNDAB2        Go if server                      @SC89218 07811000
         B     SNDRET                                          @SC86295 07811500
*                                                                       07812000
SNDSHRT  BAL   9,SNDCLS      Close input file                  @SC89218 07812500
         NI    SNFLG,255-NEWGRP Not first of the group anymore @SC89218 07813000
         MVI   ERRNUM,ERRFTS File too short for request        @SC89218 07813500
         B     SNDACT        On to next file, if any           @SC89218 07814000
*                                                                       07814500
SNDBRKP  TM    SNFLG,FIRST   See if actually started           @SC89218 07815000
         BO    SNDRET        No, just quit                     @SC89218 07815500
         TM    FL4,NPS       Non-protocol?                     @SC90292 07816000
         BO    SNDBR2        Yes, skip break packet            @SC90292 07816500
         MVI   STYPE,AB      Packet type = BREAK               @SC89218 07817000
         XC    DATL,DATL                                                07817500
         BAL   9,INPUTSPK    Send BRK and Interpret response   @SC86295 07818000
SNDBR2   DS    0H                                              @SC86165 07818500
         MVC   ERRNUM(2),ERRLAST Reset error+reason            @SC89218 07819000
         B     SNDRET        Done                              @SC89218 07819500
*                                                                       07820000
SNDCMDER MVI   ERRNUM,ERRDSP Say can't dispose of file         @SC90239 07820500
*                                                                       07821000
SNDABR   BAL   9,SNDCLS      Close disk file                   @SC86295 07821500
         KCALL ACCTNG        Save code in table                @SC88092 07822000
SNDAB2   DS    0H                                              @SC89218 07822500
         TM    FL4,NPS       Non-protocol?                     @SC86165 07823000
         BO    SNDRET        Yes, skip error packet            @SC86165 07823500
         KCALL ERPACK        Send error packet                          07824000
SNDRET   NI    FL4,255-NPS-SFM-TXT                             @SC86165 07824500
         LA    0,0           Indicate return from SEND         @AB89191 07825000
         B     RETSNRC       Close statistics and return       @SC86295 07825500
*                                                                       07826000
SNDCLS   TM    FL4,SFM       Text xmit?                        @SC86158 07826500
         BOR   9             Yes, no disk file                 @SC86295 07827000
         CLOSF FILPTR        Close it                          @SC86158 07827500
         BR    9                                               @SC86295 07828000
*                                                                       07828500
TIMPLT   DC    C' ',X'2120',C':',2X'20',C':',2X'20'  Time edit @SC88235 07829000
         LOCALS ,                                              @SC86295 07829500
SNPKCT   DS    H             Cyclic counter for tuning         @SC86345 07830000
CXZ      DS    X             Flag for aborted transmission     @SC86295 07830500
SNFLG    DS    X             More local flags                  @SC86295 07831000
FIRST    EQU   X'80'         File is the first one             @SC86295 07831500
NEWGRP   EQU   X'40'         File is the first of a new group  @SC88306 07832000
SNDPKLR  DS    A             Saved return adr for attribute    @SC90037 07832500
SNDPKLN  DS    F             Length of attributes composed     @SC90037 07833000
SNDDSP   DS    X             Saved code for disposition        @SC90239 07833500
SEND     EXIT                                                           07834000
         TITLE 'RECEIV Routine - receives a file'                       07834500
* Receive file(s) and set ERRNUM appropriately                          07835000
* Entry: filespec in FILNAM if ROVR is set                              07835500
RECEIV   ENTER                                                          07836000
         XC    NSENTAC(LSTATS),NSENTAC Clear statistics        @SC90179 07836500
         XC    NSENT,NSENT   Clear count of files              @SC88092 07837000
         MVC   FL1SV,FL1     Save file attribute defaults:     @SC90037 07837500
         MVC   TYPFSV,TYPFIL File type...                      @SC90037 07838000
         MVC   RCFSV,FILRCF  Format                            @SC90037 07838500
         MVC   LRCSV,FILLRC  Record length...                  @SC90037 07839000
         KCALL SUPFNC,10                                       @SC86295 07839500
         ST    15,SECTOT     Save start time                   @SC86295 07840000
         CLI   RTYPE,AF      Starting with file header packet? @SC88074 07840500
         BE    RECFHD        Yes, skip INIT stuff              @SC88074 07841000
         CLI   RTYPE,AX                                        @SC88074 07841500
         BE    RECFHD        Yes, skip INIT stuff              @SC88074 07842000
         KCALL SPARSET       Set up for exchange               @SC86152 07842500
         LA    8,RECINST             Next state table for RECEIVE I     07843000
         MVC   LIMTRY,MAXTNT Limit for INIT retries            @SC86345 07843500
         CLI   RTYPE,0                                         @SC88074 07844000
         BNE   RECSRV        Skip read if already got packet   @SC88074 07844500
         MVI   SEQ,0         Reset packet number               @SC88074 07845000
         KCALL RPACK         Get init info                              07845500
RECSRV   SR    3,3                   Clear retry counter for INPUTLUP   07846000
         BAL   9,INPUTINR    Interpret response to RPAC        @SC86295 07846500
         KCALL SPAR          Interpret his S packet                     07847000
         KCALL RPAR          Reply to the S packet                      07847500
         BAL   2,SENDACKL            Send an ACK, length set            07848000
         MVC   BCTU,BCTR     Switch to negotiated chksum/flag  @SC92085 07848500
         CLI   BCTR,AA       Blank suppression?                @SC92085 07849000
         BL    *+8           No, flag was off already          @SC92085 07849500
          MVI  BCTOFF+3,1    Yes, turn it on                   @SC92085 07850000
         NI    BCTU,15       Use just length here              @SC92085 07850500
         MVC   LIMTRY,MAXTRY Set retry limit                   @SC86164 07851000
         BAL   14,INCRSEQ                                               07851500
RECFIL   KCALL RPACK         Get header packet                 @SC88074 07852000
RECFHD   LA    8,RECFNST     Next state table for RECEIVE F    @SC88074 07852500
         SR    3,3           Clear retry counter for INPUTLUP  @SC88074 07853000
         BAL   9,INPUTINR    Interpret header packet           @SC88074 07853500
         NI    RFLG,255-RTRC-RRJC Clear each time              @SC86316 07854000
         MVI   REASON,0                                                 07854500
         NI    FL1,255-EOF           Turn of EOF = no ctl-z seen        07855000
         MVC   FILFSIZ,F0    Clear expected size in Kbytes     @SC90037 07855500
         XC    FDATE,FDATE   Clear file date/time              @SC91094 07856000
         TM    FL1,ROVR                                                 07856500
         BO    RECOVR                Overwrite the name sent?           07857000
         BAL   9,DECODEN     Decode the input                  @SC86295 07857500
         L     1,WBUF                Start of data                      07858000
         L     0,WBUFL               Data length decoded                07858500
         TR    0(256,1),ATOED Convert to std EBCDIC            @SC89301 07859000
         STM   0,1,SCANPTR   Set up scan                       @SC86295 07859500
         MVC   CMD+&MSGFILL.(255-&MSGFILL),0(1)  Extra copy    @SC92300 07860000
         LA    0,FFHDR                                         @SC86295 07860500
         KCALL FSPEC,FILNAM,E=RECNER  Invalid, somehow?        @SC91017 07861000
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07861500
         BE    RECOVR        No, be quiet                      @SC87300 07862000
         MVC   CMD(&MSGFILL),=C'&MSGFILE' Yes, display message @SC92300 07862500
         LA    0,CMD+&MSGFILL                                  @SC87300 07863000
         A     0,WBUFL                                         @SC87300 07863500
         BAL   2,STAPMSG     Show name                         @SC87300 07864000
RECOVR   LA    3,FILNAM              Point to fn                        07864500
         TM    FL3,APPN      Appending to old files?           @SC86203 07865000
         BO    RECOPN        Yes, just do it                   @SC86295 07865500
         TM    FL1,REN                                                  07866000
         BZ    RECOPN        No, just do it                    @SC86295 07866500
         LA    0,FFNEW                                         @SC86295 07867000
         KCALL FSPEC,FILNAM,E=RECNER Check collisions          @SC88053 07867500
         TM    FL4,NMCHNG                                      @SC90033 07868000
         BZ    RECCMSG                                         @SC90033 07868500
         CLI   CLSNFL,C'B'                                     @SC90033 07869000
         BNE   RECCTSTD                                        @SC90033 07869500
         LA    2,FILNAM      Must back up original file        @SC90033 07870000
         LA    0,15          Rename it to unique new name      @SC90033 07870500
         KCALL DISKIO,XFILE,E=RECNER Give up if rename fails   @SC90264 07871000
         CLI   TRMLIN,C' '   Alt. line?                        @SC90033 07871500
         BE    RECCBZ        No, be quiet                      @SC90033 07872000
         INITSTR '&BACKDUP',CMD,REG=7                          @SC92300 07872500
         LA    1,FILNAM                                        @SC90033 07873000
         BAL   2,STAFSP      Format backup name and show it    @SC90033 07873500
RECCBZ   MVC   FILNAM,XFILE  Now, just use intended name       @SC90033 07874000
         B     RECCMSG                                         @SC90033 07874500
RECCTSTD CLI   CLSNFL,C'D'                                     @SC90033 07875000
         BNE   RECCMSG       Other case is just "rename"       @SC90033 07875500
RECNER   DS    0H            Invalid name, cancel the transfer @SC91017 07876000
         OI    RFLG,RRJC     Reject file                       @SC90033 07876500
         MVI   REASON,STACNCLS Reason was file collision       @SC90033 07877000
         CLI   TRMLIN,C' '   Alt. line?                        @SC90033 07877500
         BE    RECOPN        No, be quiet                      @SC90033 07878000
         WTEXT '&DSCARDD'                                      @SC90033 07878500
         B     RECOPN                                          @SC90033 07879000
RECCMSG  DS    0H                                              @SC90033 07879500
         CLI   TRMLIN,C' '   Alt. line?                        @SC87300 07880000
         BE    RECOPN        No, be quiet                      @SC87300 07880500
         INITSTR '&RECVDAS',CMD,REG=7  Yes, display message    @SC92300 07881000
         LA    1,FILNAM                                        @SC87300 07881500
         BAL   2,STAFSP      Format name and show it           @SC87300 07882000
RECOPN   XC    FILFLGS,FL3   Set flag for DISP                 @SC86295 07882500
         NI    FILFLGS,255-APPN-SVATT                          @SC90033 07883000
         XC    FILFLGS,FL3                                     @SC86295 07883500
         XC    RECRCNT,RECRCNT Count of packets after rejection@SC91165 07884000
         KCALL ACCTST,FILNAM Copy name to table                @SC88306 07884500
         L     7,RBUF        Ptr to input buffer               @SC88264 07885000
         LA    0,FFDSP                                         @SC88264 07885500
         KCALL FSPEC,FILNAM  Copy chosen name into buffer      @SC88264 07886000
         L     2,RBUF                                          @SC88264 07886500
         LR    3,15          End of string                     @SC88264 07887000
         SR    3,2           Get length of string              @SC88264 07887500
         ST    3,RBUFL                                         @SC88264 07888000
         LA    15,ETOAD      Standard table                    @SC89301 07888500
         BAL   14,TRANSLAT   Convert to ASCII                  @SC88264 07889000
         BAL   9,ENCODEN     Copy into packet buffer           @SC88264 07889500
         BAL   2,SENDACKL                                      @SC88264 07890000
         XC    WBUFL,WBUFL           Data length in WBUF                07890500
         MVI   LCKOLD,0      Start at normal state             @SC91275 07891000
         MVI   DECESCP,0                                       @SC91275 07891500
         MVI   PREV,0                Char previously decoded            07892000
         LA    8,RECANST     State table: REC D or A           @SC86149 07892500
RECDAT   BAL   14,INCRSEQ                                      @SC86316 07893000
         BAL   9,INPUT       Read a packet and interpret       @SC86295 07893500
         LA    9,RECDNST     From now on accept D only         @SC90037 07894000
         CR    8,9           Already seen a D packet?          @SC90037 07894500
         BE    RECDATN       Yes, handle routinely             @SC90037 07895000
         LR    8,9           No, 1st open file                 @SC90037 07895500
         TM    RFLG,RRJC     File rejected?                    @SC90037 07896000
         BO    RECRJX        Yes, ignore all data              @SC90037 07896500
         OPENF O,FILNAM,FILFDB,FILPTR,E=RECOER                 @SC91017 07897000
         USING FDBD,1                                          @SC86295 07897500
         L     2,FABLRTR     Get effective record length       @SC88120 07898000
         ST    2,FSIZE       Copy LRECL                        @SC86295 07898500
         MVC   FRECF,FDBRCF  Save info                         @SC86295 07899000
         DROP  1                                               @SC86295 07899500
         TM    FL1,BINF                                        @SC88120 07900000
         BO    RECMAXO       Binary, just fold at LRECL        @SC88120 07900500
         CLI   TRNCFL,C'H'   Test: F, H, or T                  @SC88120 07901000
         BL    RECMAXO       F => fold at LRECL                @SC88120 07901500
         LA    2,1(2)        Assume H => abort at LRECL+1      @SC88120 07902000
         BE    RECMAXO                                         @SC88120 07902500
         ICM   2,8,LOBIT+3   T => fold at "infinity", but trunc@SC88120 07903000
RECMAXO  ST    2,MAXOUT                                        @SC88120 07903500
         BAL   14,RDWSET     Check for special format          @SC86295 07904000
         ICM   0,15,FILFSIZ  Expected size, if known           @SC90037 07904500
         BZ    RECDATN       Not known, proceed                @SC90037 07905000
         OPENF S,FILNAM,FILFDB,FILPTR,E=RECRJL Check disk space@SC90037 07905500
RECDATN  DS    0H                                              @SC90037 07906000
         TM    RFLG,RRJC     File rejected?                    @SC89218 07906500
         BO    RECRJX        Yes, ignore all data              @SC90033 07907000
         KCALL DECODE,E=RECABR Decode and write to file        @SC86316 07907500
RECDAK   BAL   2,SENDACK     Send an ack                       @SC86149 07908000
         B     RECDAT                                                   07908500
*                                                                       07909000
RECSCN   LR    7,6           Start one before number           @SC90037 07909500
RECSCL   CLI   0(7),ACOM     Look for comma                    @SC90037 07910000
         BER   14            Found one                         @SC90037 07910500
         CR    7,5                                             @SC90037 07911000
         BNLR  14            Already at end of string          @SC90037 07911500
         LA    7,1(,7)                                         @SC90037 07912000
         B     RECSCL        Keep looking                      @SC90037 07912500
*                                                                       07913000
RECALKP  LTR   7,7                                             @SC90037 07913500
         BNP   RECRJC        No value at all.  Give up         @SC90037 07914000
         IC    4,0(,6)       Get value code                    @SC90037 07914500
         LA    6,1(,6)       Advance scan ptr over code char   @SC90037 07915000
         BCTR  7,0           Length of stuff left              @SC90037 07915500
         B     CLKP          Dispatch on value, table at (2)   @SC90037 07916000
*                                                                       07916500
RECAMJ   NI    FL1,255-BINF  Set it Text                       @SC90037 07917000
         MVI   TYPFIL,C'T'                                     @SC90037 07917500
         LTR   7,7           Any more stuff?                   @SC90037 07918000
         BZR   14            No, assume AMJ                    @SC90037 07918500
         C     7,F2          Yes, had better be AMJ!           @SC90037 07919000
         BNE   RECRJC        Isn't AMJ, give up                @SC90037 07919500
         CLC   0(2,6),=AL1(AM,AJ)                              @SC90037 07920000
         BNE   RECRJC        Isn't AMJ, give up                @SC90037 07920500
         BR    14            Ok                                @SC90037 07921000
*                                                                       07921500
RECTRTD  TRT   0(,6),TRTDIG  Scan for invalid data bytes       @SC91094 07922000
RECTRTB  TRT   0(,6),TRTBL   Scan for a blank                  @SC91094 07922500
RECMVTM  MVC   FDATE+4(0),TMPDW+4 Copy to output field         @SC91094 07923000
TRTDIG   DC    (C' ')X'1',X'0'         Detect space            @SC91094 07923500
         DC    (C':'-C' '-1)X'1',X'0'   and colon              @SC91094 07924000
         DC    (C'0'-C':'-1)X'1',10X'0',(255-C'9')X'1'  digits @SC91094 07924500
*                                                                       07925000
RECADT   BCTR  7,0                                             @SC91094 07925500
         EX    7,RECTRAT     Convert to EBCDIC                 @SC91094 07926000
         EX    7,RECTRTD     Check if valid data               @SC91094 07926500
         BNZ   RECRJC        Invalid, reject                   @SC91094 07927000
         LA    1,1(,7)       Total length                      @SC91094 07927500
         EX    7,RECTRTB                                       @SC91094 07928000
         BZ    *+6                                             @SC91094 07928500
          SR   1,6           Length of data alone              @SC91094 07929000
         PACK  FDATE(5),0(9,6)                                 @SC91094 07929500
         C     1,F8          Full yyyymmdd?                    @SC91094 07930000
         BH    RECRJC        Too big, kill it                  @SC91094 07930500
         BE    RECADT1       Ok                                @SC91094 07931000
         CH    1,=H'6'       Just yymmdd?                      @SC91094 07931500
         BNE   RECRJC        No, illegal                       @SC91094 07932000
         PACK  FDATE+1(4),0(7,6) Leave room for century        @SC91094 07932500
         MVI   FDATE,X'19'   Assume 20th                       @SC91094 07933000
         CLI   FDATE+1,X'50' Unless yy<50                      @SC91094 07933500
         BNL   RECADT1                                         @SC91094 07934000
         MVI   FDATE,X'20'   Must be 21st                      @SC91094 07934500
RECADT1  MVI   FDATE+4,0     Repair damage                     @SC91094 07935000
         LA    1,1(,1)       Account for separator             @SC91094 07935500
         SR    7,1           See if time also present          @SC91094 07936000
         BNP   RECCKL        No, all done                      @SC91094 07936500
         AR    6,1           Ok, advance ptr                   @SC91094 07937000
         MVC   TMPDW(6),=AL1(0,1,3,4,6,7)                      @SC91094 07937500
         TR    TMPDW(6),0(6) Compress out colons               @SC91094 07938000
         PACK  TMPDW+4(4),TMPDW(7)                             @SC91094 07938500
         CH    7,=H'4'       Just hh:mm?                       @SC91094 07939000
         BE    *+12          Ok                                @SC91094 07939500
          CH   7,=H'7'       hh:mm:ss?                         @SC91094 07940000
          BNE  RECRJC        No, error                         @SC91094 07940500
         SRL   7,1                                             @SC91094 07941000
         BCTR  7,0                                             @SC91094 07941500
         EX    7,RECMVTM     Move to FDATE: 2 or 3 bytes       @SC91094 07942000
         B     RECCKL                                          @SC91094 07942500
*                                                                       07943000
RECCKA   L     5,ARDATA      Attributes                        @SC88273 07943500
         L     3,DATL        Get length                        @SC86316 07944000
         AR    3,5           Ptr to end                        @SC88273 07944500
         MVI   ERRNUM,ERRIPS In case of error                  @SC86316 07945000
RECCKL   CR    5,3           Another attribute?                @SC86316 07945500
         BNL   RECDAK        No, done                          @SC86316 07946000
         TM    RFLG,RRJC     File rejected?                    @SC90033 07946500
         BO    RECDAK        Yes, ignore further attributes    @SC90033 07947000
         UNCHR 4,0(5),REASON Get code                          @SC90037 07947500
         BNP   RECABR        Invalid: code must be >0          @SC90037 07948000
         UNCHR 7,1(5)        Get length of value               @SC88273 07948500
         BM    RECABR        Invalid: length was <0            @SC86316 07949000
         LA    6,2(5)        Space over code+length            @SC88273 07949500
         LA    5,0(7,6)      Next field                        @SC86316 07950000
         CR    5,3           Does it match?                    @SC86316 07950500
         BH    RECABR        Overflows data                    @SC86316 07951000
         LR    14,4                                            @SC90037 07951500
         BCTR  14,0          Bit index for this attribute      @SC90037 07952000
         SRDL  14,3          Get byte index                    @SC90037 07952500
         SRL   15,29         And bit remainder                 @SC90037 07953000
         LA    1,X'80'                                         @SC90037 07953500
         SRL   1,0(15)       Convert to bit mask               @SC90037 07954000
         IC    15,ATFLG(14)  Load attribute flags              @SC90037 07954500
         NR    15,1          Honor this attribute?             @SC90037 07955000
         BZ    RECCKL        No, just ignore it                @SC90037 07955500
         BAL   2,CLKP                                          @SC86316 07956000
RECLNCOD DC    AL1(01),AL3(RECALN) ! - File length             @SC90037 07956500
         DC    AL1(02),AL3(RECATP) " - Type                    @SC90037 07957000
         DC    AL1(03),AL3(RECADT) # - Date                    @SC91094 07957500
         DC    AL1(09),AL3(RECAAC) ) - Access                  @SC90037 07958000
         DC    AL1(10),AL3(RECAEN) * - Encoding                @SC90037 07958500
         DC    AL1(11),AL3(RECADI) + - Disposition             @SC90037 07959000
         DC    AL1(15),AL3(RECAFM) / - Format                  @SC90037 07959500
         DC    AL1(32),AL3(RECAZZ) @ - End                     @SC91109 07960000
         DC    X'0',AL3(RECCKL) Other                          @SC86316 07960500
*          Access attribute                                    @SC90037 07961000
RECAAC   BAL   2,RECALKP                                       @SC90037 07961500
         DC    AL1(AA),AL3(RECAAA) Append                      @SC90037 07962000
         DC    AL1(AN),AL3(RECCKL) Normal (obey user)          @SC90037 07962500
         DC    AL1(AS),AL3(RECAAS) Supersede                   @SC90037 07963000
         DC    AL1(00),AL3(RECRJC) unknown, reject             @SC90037 07963500
RECAAA   OI    FILFLGS,APPN  Append                            @SC90037 07964000
         B     RECCKL                                          @SC90037 07964500
RECAAS   NI    FILFLGS,255-APPN Don't append                   @SC90037 07965000
         B     RECCKL                                          @SC90037 07965500
*          Format attribute                                    @SC90037 07966000
RECAFM   BAL   14,RECSCN     Check for comma                   @SC90037 07966500
         SR    7,6           Length of extra stuff             @SC90037 07967000
         BAL   2,RECALKP                                       @SC90037 07967500
         DC    AL1(AA),AL3(RECAFA) ASCII                       @SC90037 07968000
         DC    AL1(AD),AL3(RECAFD) D (binary)                  @SC90037 07968500
         DC    AL1(AF),AL3(RECAFF) Fixed (binary)              @SC90037 07969000
         DC    AL1(AM),AL3(RECLRC) LRECL                       @SC90037 07969500
         DC    AL1(AV),AL3(RECAFD) V (binary)                  @SC90037 07970000
         DC    AL1(00),AL3(RECRJC) ?                           @SC90037 07970500
RECAFA   BAL   14,RECAMJ     Set it Text                       @SC90037 07971000
         B     RECALP                                          @SC90037 07971500
RECAFF   LA    4,AB          Plain old Binary                  @SC90037 07972000
RECAFD   OI    FL1,BINF      Binary selected                   @SC90037 07972500
         IC    4,ATOED(4)    Ok, set file type as well         @SC90037 07973000
         STC   4,TYPFIL                                        @SC90037 07973500
RECALP   BAL   14,RECSCN     Look for comma                    @SC90037 07974000
         LA    6,1(,7)       Skip over comma for next piece    @SC90037 07974500
         CR    6,5                                             @SC90037 07975000
         BNL   RECCKL        Ran out of attribute stuff        @SC90037 07975500
         B     RECAFM        Do next piece                     @SC90037 07976000
RECLRC   BAL   14,RECSCN     Look for comma                    @SC90037 07976500
         SR    7,6           Length of number string           @SC90037 07977000
         LR    14,7          Convert number to EBCDIC          @SC90037 07977500
         BNP   RECRJC        Impossible, reject it             @SC90037 07978000
         BCTR  14,0                                            @SC90037 07978500
         EX    14,RECTRAT                                      @SC90037 07979000
         BAL   14,GETNUM     Get number                        @SC90037 07979500
          B    RECRJC        Not proper numeric string         @SC90037 07980000
         LTR   0,0           Validate LRECL                    @SC90037 07980500
         BNP   RECRJC        No good                           @SC90037 07981000
         STCM  0,3,FILLRC    Ok, use it                        @SC90037 07981500
         B     RECALP        Look for another subattribute     @SC90037 07982000
*          Length attribute                                    @SC90037 07982500
RECALN   LTR   14,7          Copy length                       @SC88273 07983000
         BNP   RECRJC        No good                           @SC88273 07983500
         BCTR  14,0                                            @SC88273 07984000
         EX    14,RECTRAT                                      @SC88273 07984500
         BAL   14,GETNUM     Get file length                   @SC88273 07985000
          B    RECRJC                                          @SC88273 07985500
         ST    0,FILFSIZ     Save expected size                @SC90037 07986000
         OPENF S,FILNAM,FILFDB,FILPTR,E=RECRJC Check disk space@SC90037 07986500
         B     RECCKL        Ok, keep looking                  @SC86316 07987000
RECTRAT  TR    0(,6),ATOED   Convert to EBCDIC for decoding    @SC88273 07987500
*          Type attribute                                      @SC90037 07988000
RECATP   BAL   2,RECALKP                                       @SC90037 07988500
         DC    AL1(AA),AL3(RECATA) ASCII                       @SC90037 07989000
         DC    AL1(AB),AL3(RECATB) Binary                      @SC90037 07989500
         DC    AL1(00),AL3(RECRJC) Don't allow any other       @SC90037 07990000
RECATA   BAL   14,RECAMJ     Set it Text                       @SC90037 07990500
         B     RECCKL        Ok                                @SC90037 07991000
RECATB   TM    FL1,BINF      Already binary?                   @SC90037 07991500
         BO    RECCKL        Yes, that's fine                  @SC90037 07992000
         OI    FL1,BINF      No, set it binary                 @SC90037 07992500
         MVI   TYPFIL,C'B'   And choose simple binary          @SC90037 07993000
         B     RECCKL                                          @SC90037 07993500
*          Disposition attribute                               @SC90037 07994000
RECADI   BAL   2,RECALKP                                       @SC90037 07994500
         DC    AL1(AA),AL3(RECCKL) Archive (not implemented)   @SC90037 07995000
         DC    AL1(AM),AL3(RECADM) Mail                        @SC90037 07995500
         DC    AL1(AP),AL3(RECADP) Print                       @SC90037 07996000
         DC    AL1(AS),AL3(RECADS) Submit as batch job         @SC90037 07996500
         DC    AL1(00),AL3(RECRJC) unknown, reject             @SC90037 07997000
*                                                                       07997500
RECADM   LTR   7,7           Any recipients given?             @SC90037 07998000
         BNP   RECRJC        No, that's bad                    @SC90037 07998500
         BAL   2,RECAD1                                        @SC90037 07999000
         DC    AL4(KMAIL1),AL2(L'KMAIL1,L'KMAIL2,L'KMAIL3)     @SC90037 07999500
RECADP   BAL   2,RECAD1                                        @SC90037 08000000
         DC    AL4(KPRNT1),AL2(L'KPRNT1,L'KPRNT2,L'KPRNT3)     @SC90037 08000500
RECADS   BAL   2,RECAD1                                        @SC90037 08001000
         DC    AL4(KSUBM1),AL2(L'KSUBM1,L'KSUBM2,L'KSUBM3)     @SC90037 08001500
RECAD1   ICM   0,15,0(2)     Get prototype ptr                 @SC90037 08002000
         LH    1,4(,2)       Get length of 1st piece           @SC90037 08002500
         LA    14,CMD                                          @SC90037 08003000
         ST    14,ADR        Save ptr to command buffer        @SC90037 08003500
         LA    4,1(,1)       Leave room for null name          @SC92120 08004000
         ST    4,LEN         Save length of 1st piece + '.'    @SC92120 08004500
         LR    15,1                                            @SC90037 08005000
         MVCL  14,0          Copy first piece to buffer        @SC90037 08005500
         ST    0,RECDSPTR    Save ptr to 2nd piece             @SC90037 08006000
         LR    4,7           Save length of options            @SC90037 08006500
         LA    0,FFDSP                                         @SC90037 08007000
         LR    7,14          Feed output ptr to FSPEC          @SC90037 08007500
         KCALL FSPEC,FILNAM  Copy filespec to buffer           @SC90037 08008000
         LR    14,15         New output ptr                    @SC90037 08008500
         LR    7,4           Retrieve option length            @SC90037 08009000
         L     0,RECDSPTR    Get ptr to 2nd piece              @SC90037 08009500
         LH    1,6(,2)       Get length of 2nd piece           @SC90037 08010000
         LR    15,1                                            @SC90037 08010500
         MVCL  14,0          Copy 2nd piece to buffer          @SC90037 08011000
         LR    4,14          Save ptr to insert                @SC90037 08011500
         LR    15,7                                            @SC90037 08012000
         MVCL  14,6          Copy attribute stuff to buffer    @SC90037 08012500
         TR    0(94,4),ATOED Convert to EBCDIC                 @SC90037 08013000
         LH    1,8(,2)       Get length of 3rd piece           @SC90037 08013500
         LR    15,1                                            @SC90037 08014000
         MVCL  14,0          Copy 3nd piece to buffer          @SC90037 08014500
         ST    14,RECDSPTR   Save ptr to end of command        @SC90037 08015000
         LA    7,CMD-1                                         @SC92120 08015500
         A     7,LEN                                           @SC92120 08016000
         IC    4,0(,7)                                         @SC92120 08016500
         MVI   0(7),C'.'     Use null name for 1st call        @SC92120 08017000
         OI    FL4,UCMD                                        @SC90037 08017500
         KCALL SUPFNC,3,E=RECRJC Test if facility exists       @SC90037 08018000
         STC   4,0(,7)       Restore name                      @SC92120 08018500
         B     RECCKL                                          @SC90037 08019000
*                                                                       08019500
*          Encoding attribute                                  @SC90037 08020000
RECAEN   BAL   2,RECALKP                                       @SC90037 08020500
         DC    AL1(AA),AL3(RECCKL) ASCII                       @SC90037 08021000
         DC    AL1(AC),AL3(RECAEC) Special character set       @SC90040 08021500
         DC    AL1(AE),AL3(RECATB) Binary                      @SC90037 08022000
         DC    AL1(00),AL3(RECRJC) Don't allow any other       @SC90037 08022500
*                                                                       08023000
RECAEC   LTR   7,7                                             @SC90040 08023500
         BNP   RECCKL        Character set not specified       @SC90040 08024000
         KCALL TBLATT,E=RECRJC                                 @SC90040 08024500
         B     RECCKL                                          @SC90040 08025000
*                                                                       08025500
RECAZZ   CR    5,3           End of attributes, must be last   @SC91109 08026000
         BNE   RECRJC        No, reject                        @SC91109 08026500
         B     RECCKL                                          @SC91109 08027000
*                                                                       08027500
RECRJL   MVC   REASON,RECLNCOD Because of length               @SC90037 08028000
RECRJX   L     9,ASDATA      Output buffer                     @SC90037 08028500
         MVI   0(9),AX       Reject this file                  @SC90033 08029000
         MVC   DATL,F1                                         @SC90033 08029500
         LA    2,1           Count up cancel packets           @SC91165 08030000
         AH    2,RECRCNT                                       @SC91165 08030500
         STH   2,RECRCNT                                       @SC91165 08031000
         CH    2,=H'10'      Other Kermit too persistent?      @SC91165 08031500
         BNL   RECECNCL      Yes, call a halt                  @SC91165 08032000
         B     RECRJ2        Now accept only EOF pkt           @SC90033 08032500
RECRJC   L     9,ASDATA      Output buffer                     @SC86316 08033000
         MVI   0(9),AN       Mark it rejected                  @SC88273 08033500
         TOCHR 0,REASON,1(9) Copy attribute code to response   @SC90037 08034000
         MVC   DATL,F2       Data = 'N' + code                 @SC86316 08034500
RECRJ2   DS    0H                                              @SC90033 08035000
         OI    RFLG,RRJC     Mark it rejected                  @SC86316 08035500
         BAL   2,SENDACKL    Acknowledge                       @SC86316 08036000
         B     RECDAT        And wait for EOF                  @SC86316 08036500
*                                                                       08037000
RECEOF   TM    RFLG,RRJC     File rejected?                    @SC89218 08037500
         BO    RECDISC       Yes, discard                      @SC89218 08038000
         CLC   DATL,F1                                         @SC89218 08038500
         BNE   RECWR                 One piece of data                  08039000
         L     1,ARDATA                                        @SC86190 08039500
         CLI   0(1),AD                                         @SC86190 08040000
         BNE   RECWR                 Go if not discard                  08040500
         MVI   REASON,0      Micro canceling; don't know why   @SC91263 08041000
RECDISC  DS    0H                                              @SC89218 08041500
         CLOSF FILPTR        Close the file                    @SC86135 08042000
         TM    FILFLGS,APPN  Appending to old file?            @SC90033 08042500
         BO    RECKEP        Yes, keep what we got             @SC86225 08043000
         TM    FL1,KEEP                                        @SC90037 08043500
         BO    RECKEP        Don't delete it anyway            @SC86225 08044000
         ERASF FILNAM        And delete it                     @SC86295 08044500
RECKEP   MVI   ERRNUM,ERRTRC Receive cancelled                 @SC86225 08045000
         OI    RFLG,RTRC     Remember that                     @SC86295 08045500
         B     RECACK                Pick up later on                   08046000
* If data left in buffer when we get EOF, write remaining data.         08046500
RECWR    ICM   1,15,WBUFL    Check length in buffer            @SC88120 08047000
         BE    RECCLO                No data in WBUF, send Ack          08047500
         KCALL OUTBUF,E=RECABR Write out buffer                         08048000
RECCLO   CLOSF FILPTR,E=RECCER Close the file                  @SC92076 08048500
         MVI   ERRNUM,ERRNOE No error yet                      @SC88092 08049000
         ICM   1,15,RECDSPTR Any special disposition?          @SC90037 08049500
         BZ    RECACK                                          @SC90037 08050000
         LA    14,CMD                                          @SC90037 08050500
         ST    14,ADR        Save ptr to command buffer        @SC90037 08051000
         SR    1,14          Get length of command             @SC90037 08051500
         ST    1,LEN                                           @SC90037 08052000
         OI    FL4,UCMD                                        @SC90037 08052500
         KCALL SUPFNC,3,E=RECDSPX Disposition failed           @SC90037 08053000
RECACK   KCALL ACCTNG        Save code in table                @SC89218 08053500
         BAL   14,RECRSTA    Restore attributes                @SC90037 08054000
         BAL   2,SENDACK     Send an ACK                       @SC89218 08054500
         BAL   14,INCRSEQ                                               08055000
         NI    FL1,255-ROVR          Only change first file             08055500
         NI    FL4,255-NMOK-NMCHNG Check collision on next file@SC90211 08056000
         B     RECFIL                                                   08056500
*                                                                       08057000
RECBRK   MVI   ERRNUM,ERRTRC Receive cancelled?                @SC90033 08057500
         TM    RFLG,RTRC+RRJC                                  @SC90033 08058000
         BNZ   RECERP        Yes, send an error packet         @SC90033 08058500
         TM    FL2,SRV       Server will read another command  @SC90033 08059000
         BO    *+12           so don't zap write/read flag     @SC90173 08059500
          MVI  WRRD,0        No read for Ack'ing BRK pkt       @SC87343 08060000
          MVI  AEAFLG,X'80'  ditto                             @SC90173 08060500
         BAL   2,SENDACK             Send an ACK                        08061000
         MVI   ERRNUM,ERRNOE Reset error                       @SC86156 08061500
         B     RECRET                                          @SC89218 08062000
*                                                                       08062500
RECDSPX  MVI   ERRNUM,ERRDSP Code for disposition failure      @SC90037 08063000
         B     RECABR                                          @SC90037 08063500
*                                                                       08064000
RECECNCL MVI   ERRNUM,ERRTRC Code for drastic cancellation     @SC91165 08064500
         B     RECABR                                          @SC91165 08065000
*                                                                       08065500
RECCER   MVC   FABCOMM-FABD+DSKSTT(8),=CL8'CLOSE' Error type   @SC92076 08066000
         B     RECRER                                          @SC92076 08066500
RECOER   MVC   FABCOMM-FABD+DSKSTT(8),=CL8'OPEN' Error type    @SC91017 08067000
RECRER   LA    1,DSKSTT      Name error, point to dummy block  @SC91017 08067500
         ERRF  ,             Cannot write. Analyze error       @SC91017 08068000
RECABR   CLOSF FILPTR        Close open file                   @SC86135 08068500
         KCALL ACCTNG        Save code in table                @SC88092 08069000
         BAL   14,RECRSTA    Restore attributes                @SC90037 08069500
RECERP   KCALL ERPACK        Send error packet                 @SC90033 08070000
RECRET   ICM   0,15,RECTRC   Any records truncated?            @SC87268 08070500
         LA    0,4           Indicate return from RECEIVE      @AB89191 08071000
         BZ    RETSNRC       None                              @SC87268 08071500
         CLI   ERRNUM,0                                        @SC87268 08072000
         BNE   *+8           Already got some (worse) error    @SC87268 08072500
         MVI   ERRNUM,ERRRTR Indicate error                    @SC87268 08073000
         B     RETSNRC       Close statistics and return       @SC87268 08073500
* Restore file attribute defaults from saved values            @SC90037 08074000
RECRSTA  XC    FL1,FL1SV     Restore flags                     @SC90037 08074500
         NI    FL1,255-BINF-REN-KEEP Restore only these flags  @SC90037 08075000
         XC    FL1,FL1SV                                       @SC90037 08075500
         MVC   TYPFIL,TYPFSV Restore file type                 @SC90037 08076000
         MVC   FILRCF,RCFSV  Restore record format             @SC90037 08076500
         MVC   FILLRC,LRCSV  Restore record length             @SC90037 08077000
         BR    14                                              @SC90037 08077500
* Receive mode Rpack interpret input tables                             08078000
RECINST  DC    AL1(AS),AL3(0)        Micro sent parm                    08078500
         DC    XL1'FF',AL3(RECABR)   Stop                      @SC88074 08079000
         DC    AL1(00),AL3(RECABR)   Error routine                      08079500
RECFNST  DC    AL1(AF),AL3(0)        Micro sent a filename              08080000
         DC    AL1(AX),AL3(0)        Micro sent a filename     @SC86155 08080500
         DC    AL1(AB),AL3(RECBRK)   Micro sent end of transaction      08081000
         DC    XL1'FF',AL3(RECABR)   Stop                      @SC88074 08081500
         DC    AL1(00),AL3(RECABR)   Error return                       08082000
RECANST  DC    AL1(AA),AL3(RECCKA)   Micro sent A-packet       @SC86316 08082500
RECDNST  DC    AL1(AD),AL3(0)        Micro sent data                    08083000
RECZNST  DC    AL1(AZ),AL3(RECEOF)   Micro sent EOF            @SC86316 08083500
         DC    XL1'FF',AL3(RECABR)   Stop                      @SC88074 08084000
         DC    AL1(00),AL3(RECABR)   Error return                       08084500
         LOCALS ,                                              @SC86295 08085000
RECDSPTR DS    F             Saved length of command           @SC90037 08085500
RFLG     DS    X             Local flags                       @SC86295 08086000
RTRC     EQU   X'80'         Other side cancelled              @SC86295 08086500
RRJC     EQU   X'40'         I cancelled                       @SC86316 08087000
FL1SV    DS    X             Saved global flags                @SC90037 08087500
TYPFSV   DS    C             Saved file type                   @SC90037 08088000
RCFSV    DS    C             Saved record format               @SC90037 08088500
LRCSV    DS    H             Saved record length               @SC90037 08089000
RECRCNT  DS    H             Count of packets after rejection  @SC91165 08089500
RECEIV   EXIT                                                           08090000
         TITLE 'ACCTNG Routine - save statistics for a transfer'        08090500
ACCTNG   ENTER                                                          08091000
         MVC   ERRLAST(2),ERRNUM Save error codes for file     @SC89218 08091500
         LM    2,3,DSKTOT    Current byte count                @SC88092 08092000
         SL    3,SSVDSK+4    Get difference from this file     @SC88092 08092500
         BC    3,*+6                                           @SC88092 08093000
          BCTR 2,0                                             @SC88092 08093500
         AL    3,=F'512'     Round up                          @SC88092 08094000
         BC    12,*+8                                          @SC88092 08094500
          AL   2,F1                                            @SC88092 08095000
         SL    2,SSVDSK                                        @SC88092 08095500
         SRDL  2,10          Convert to Kbytes                 @SC88092 08096000
         MVC   SSVDSK(8),DSKTOT                                @SC88092 08096500
         TS    ACCTFLG       See if file is current            @SC89218 08097000
         BNZ   RTRN0         No, do nothing                    @SC89218 08097500
         ICM   2,15,NSENT    Calculate offset into table       @SC88092 08098000
         BZ    RTRN          Must not be counting              @SC88092 08098500
         BCTR  2,0           Ok, back up one                   @SC91172 08099000
         MH    2,FLFID1+2                                      @SC88092 08099500
         A     2,TSENT       Ptr to next name slot             @SC88092 08100000
         USING ACTBUF,2                                        @SC91172 08100500
         CLC   ACTSIZ,F0     Already set?                      @SC91172 08101000
         BNE   RTRN          Yes, don't mess it up             @SC88092 08101500
         STCM  3,15,ACTSIZ   Save file size in Kbytes          @SC91172 08102000
         MVC   ACTERR(2),ERRNUM Save error code for file       @SC91172 08102500
         BAL   14,ACCTTOD    Get time in R0                    @SC91172 08103000
         STCM  0,15,TRANEND                                    @SC92210 08103500
         DROP  2                                               @SC91172 08104000
         B     RTRN0                                           @SC88306 08104500
*                                                                       08105000
* Copy file name from (R1) to file table, if possible; update count.    08105500
ACCTST   ENTER ALT                                             @SC88306 08106000
         MVI   ACCTFLG,0     Indicate file is current          @SC89218 08106500
         L     3,NSENT       Number of files sent so far       @SC88306 08107000
         LA    4,1(,3)       Incr number of sent files         @AB89191 08107500
         ST    4,NSENTAC     Number of files for acctng        @AB89191 08108000
         C     3,=A(MAXNSENT) Did we send more than countable? @SC88306 08108500
         BNL   RTRN0         Yes, cannot keep track of 'em     @SC88306 08109000
         MH    3,FLFID1+2    Times length of items             @SC88306 08109500
         A     3,TSENT       Loc in sent-table                 @SC88306 08110000
         USING ACTBUF,3                                        @SC91172 08110500
         XC    ACTBUF(ACTLEN),ACTBUF Clear out entry           @SC91172 08111000
         MVC   ACTFID,0(1)   Save filespec                     @SC91172 08111500
         BAL   14,ACCTTOD    Get time in R0                    @SC91172 08112000
         STCM  0,7,ACTBEG                                      @SC91172 08112500
         ST    4,NSENT       Keep it                           @SC88306 08113000
         B     RTRN0                                           @SC88306 08113500
         DROP  3                                               @SC91172 08114000
         LOCALS ,                                              @SC91172 08114500
ACCTNG   EXIT  ,                                               @SC88092 08115000
         TITLE 'SPAR Routine - use parms from other host in DATA'       08115500
SPAR     ENTER                                                          08116000
         L     7,DATL        Data length                       @SC86120 08116500
         L     5,ARDATA      Point to data                     @SC86190 08117000
         LA    8,DEFPARM                                       @SC86190 08117500
         SR    8,5           Set up offset for defaults        @SC86190 08118000
         BCTR  5,0           Point one before data             @SC86190 08118500
         LA    6,1           Set up BXH                        @SC86120 08119000
         AR    7,5           Point to last data char           @SC86120 08119500
         BAL   14,SPARFTCH   Get a char                        @SC86120 08120000
         UNCHR 4             Max send packet size              @SC86120 08120500
         C     4,AKMIN       Less than min Kermit size?        @SC86295 08121000
         BNL   SPARSPM               No, it's OK                        08121500
         LA    4,KMIN                Else, use the min value            08122000
SPARSPM  C     4,AKMAX       More than max Kermit size?        @SC86295 08122500
         BNH   SPARSPS               No, it's OK                        08123000
         LA    4,KMAX                                                   08123500
SPARSPS  ST    4,SPSIZ               Save max send packet size          08124000
         BAL   14,SPARFTCH   Get a char                        @SC86120 08124500
         UNCHR 4,,TIMOUT     Timeout micro wants us to do      @SC86120 08125000
         BAL   14,SPARFTCH   Get a char                        @SC86120 08125500
         UNCHR 4,,SPADN      Pad count micro wants             @SC86120 08126000
         BAL   14,SPARFTCH                                     @SC86120 08126500
         CTL   4,,SPADC      Pad char micro wants              @SC86120 08127000
         BAL   14,SPARFTCH                                     @SC86120 08127500
         UNCHR 4,,SEOL       EOL char we have to use           @SC86120 08128000
         CLC   SEOL,SMARK                                               08128500
         BE    SPARCR                Use CR if EOL=MARK char            08129000
         CLI   SEOL,ABL                                                 08129500
         BL    SPAREOL1      OK if within ctl range            @SC92030 08130000
SPARCR   MVI   SEOL,CR               Send a CR to that crazy micro      08130500
SPAREOL1 CLI   TRMTP,C'F'    Doing FULL?                       @SC92030 08131000
         BNE   SPAREOL2      No, leave it                      @SC92030 08131500
         MVI   SEOL,AEXCL    Yes, insist on printable EOL!     @SC92030 08132000
SPAREOL2 MVC   S1EOL,SEOL    Make extra copy                   @SC87274 08132500
SPARCTL  BAL   14,SPARFTCH                                     @SC86120 08133000
         NOTQR *+8           Go if not 33-62 or 96-126         @SC86120 08133500
          LA   4,A#          Default ctl-quote                 @SC86120 08134000
         STC   4,RCTLQ       Save ctl-quote micro's using      @SC86120 08134500
         BAL   14,SPARFTCH                                     @SC86120 08135000
         CLI   EBQC,0                                          @SC87008 08135500
         BE    SPARNB        8-bit is off                      @SC87008 08136000
         CLI   LCKFRC,X'21'  Forcing locks?                    @SC91275 08136500
         BE    SPARNB        Yes, turn off 8-bit quote         @SC91275 08137000
         CLM   4,1,=AL1(AY)                                    @SC86120 08137500
         BNE   *+8                                             @SC86120 08138000
         IC    4,EBQC        Micro agrees                      @SC86120 08138500
         BAL   14,SPARCKQX                                     @SC86120 08139000
          B    SPARNB        Micro says no 8-bit quoting       @SC86120 08139500
         CLI   EBQ,0                                                    08140000
         BE    SPAREBQ               Use it if we agree                 08140500
         CLM   4,1,EBQ                                         @SC86120 08141000
         BE    SPAREBQ               Or we match                        08141500
SPARNB   SR    4,4                   Otherwise cannot do it             08142000
SPAREBQ  STC   4,EBQ                 Set 8-bit-quoting char/flag        08142500
         BAL   14,SPARFTCH                                     @SC86120 08143000
         CLM   4,1,=AL1(AB)                                    @SC92085 08143500
         BE    SPARBCM       Go if 'B'                         @SC92085 08144000
         CH    4,SPARBCD+2                                     @SC92085 08144500
         BL    SPARBCD       Go if less than 1, use 1          @SC92085 08145000
         CLM   4,1,=AL1(A3)                                    @SC92085 08145500
         BH    SPARBCD       Go if over 3, use 1               @SC92085 08146000
SPARBCM  CLM   4,1,BCTR      Requested and our BCT same?       @SC92085 08146500
         BE    SPARBCT               Yes, they are the same             08147000
         CLI   BCTR,0                                                   08147500
         BE    SPARBCT               We'll accept anything              08148000
SPARBCD  LA    4,A1          We don't match, use 1             @SC92085 08148500
SPARBCT  STC   4,BCTR                Micro's chksum length              08149000
         BAL   14,SPARFTCH                                     @SC86120 08149500
         BAL   14,SPARCKQX   See if valid                      @SC86120 08150000
          B    SPARNR        No good                           @SC86120 08150500
         CLM   4,1,EBQ                                         @SC86120 08151000
         BE    SPARNR                Go if same prefix                  08151500
         CLI   RPTQ,0                                                   08152000
         BE    SPARRQ                We can use anything                08152500
         CLM   4,1,RPTQ                                        @SC86120 08153000
         BE    SPARRQ                We match                           08153500
SPARNR   SR    4,4                   No repeat quoting                  08154000
SPARRQ   STC   4,RPTQ                Use negotiated repeat quote        08154500
         BAL   14,SPARFTCH   Get capabilities                  @SC86149 08155000
         UNCHR 4,,RCAPA                                        @SC86149 08155500
         MVC   LCKCAPA,RCAPA See if agree on locking shift     @SC91275 08156000
         NC    LCKCAPA,SCAPA                                   @SC91275 08156500
         NI    LCKCAPA,X'20'                                   @SC91275 08157000
         CLI   EBQ,0         Negotiated 8-bit quoting?         @SC91275 08157500
         BNE   *+8           Yes, locking is permitted         @SC91275 08158000
          MVI  LCKCAPA,0     No, suppress locking              @SC91275 08158500
         OC    LCKCAPA,LCKFRC Set anyway if FORCE mode         @SC91275 08159000
         TM    RCAPA,LONGP   Test for long packet bit          @TB86196 08159500
         BZ    SPARNX        No extended packets               @TB86196 08160000
         MVC   TMP,RCAPA                                       @SC86202 08160500
SPARNS1  TM    TMP,MORCAPAS  Test for more CAPAS bytes         @SC86202 08161000
         BZ    SPARNS2       No more                           @TB86196 08161500
         BAL   14,SPARFTCH   Get capabilities                  @TB86196 08162000
         UNCHR 4,,TMP                                          @TB86196 08162500
         B     SPARNS1                                         @TB86196 08163000
SPARNS2  BAL   14,SPARFTCH   Skip window byte                  @SC86202 08163500
         BAL   14,SPARFTCH   Get next header byte              @TB86196 08164000
         LR    1,4                                             @TB86196 08164500
         UNCHR 1             MAXLX1 byte                       @TB86196 08165000
         MH    1,XLFCT+2     Times the factor                  @SC86202 08165500
         BAL   14,SPARFTCH   Get next header byte              @TB86196 08166000
         UNCHR 4             MAXLX2 byte                       @TB86196 08166500
         AR    1,4           Compute total length              @TB86196 08167000
         BNP   SPARNX        If zero, use default              @TB86196 08167500
         ST    1,SPSIZ       New SPSIZ for extended            @TB86196 08168000
SPARNX   DS    0H                                              @TB86196 08168500
* Now compute MAXSIZ                                                    08169000
         L     5,SPSIZ               Maximum send packet size           08169500
         LA    6,MAXWS       Longest full-screen write         @SC92030 08170000
         BAL   14,TTYCHK                                       @SC92030 08170500
          LA   6,MAXWT       Longest linemode write            @SC92030 08171000
         CLI   TRMTP,C'F'                                      @SC92030 08171500
         BNE   *+8           Not a full-screen non-transparent @SC92030 08172000
          LA   6,77          Strictly limited                  @SC92030 08172500
         CR    5,6                                             @SC92030 08173000
         BNH   SPAREHL                                         @SC90134 08173500
         LR    5,6           Biggest we can send               @SC92030 08174000
SPAREHL  S     5,F3          SOP, LEN, EOP don't count in LEN  @SC92030 08174500
         IC    4,SPADN       Length of padding, if any         @SC90277 08175000
         SR    5,4           Part of I/O limit if long         @SC90277 08175500
         CLI   S1HND,0                                         @SC90010 08176000
         BE    SPARNY        Ok, no handshake                  @SC90010 08176500
         BCTR  5,0           Deduct one for handshake          @SC90010 08177000
SPARNY   DS    0H                                              @SC86205 08177500
         C     5,AKMAX       Can this be a long packet?        @SC92030 08178000
         BNH   *+8           No                                @SC92030 08178500
          S    5,F3          Yes, minus extended header length @SC92030 08179000
         S     5,F3          Minus SEQ,TYP, and quoting leeway @SC92030 08179500
         IC    4,BCTR                Get user's negotiated BCT          08180000
         N     4,F           Get just length code: 1,2,3       @SC92085 08180500
         SR    5,4                   Minus checksum length              08181000
         CLI   EBQ,0                                                    08181500
         BE    SPARNEBQ              Go if no 8-Bit quoting             08182000
         BCTR  5,0                   Another one for 8-bit quoting      08182500
SPARNEBQ CLI   RPTQ,0                                                   08183000
         BE    SPARNRQ               Go if no repeat char quoting       08183500
         BCTR  5,0                                                      08184000
         BCTR  5,0                   Minus two for repeat prefix        08184500
SPARNRQ  ST    5,MAXSIZ              Save max length for data field     08185000
         ST    5,MAXSIZ+4    Static extra copy (for tuning)             08185500
         CLI   TRMTP,C'F'    FULLSCREEN?                       @SC93173 08186000
         BNE   SPARCTST                                        @SC93173 08186500
         XC    CTLTAB(32),CTLTAB  Yes, must encode everything  @SC93173 08187000
         XC    CTLTAB+127(33),CTLTAB+127  (DEL + C1)           @SC93173 08187500
SPARCTST LA    1,XOFF        Pretty dangerous to send XOFF!    @SC93173 08188000
         BAL   14,SPARENC                                      @SC93173 08188500
         IC    1,SEOL        Must encode EOL                   @SC93173 08189000
         BAL   14,SPARENC                                      @SC93173 08189500
         IC    1,SMARK       Must encode SOP                   @SC93173 08190000
         BAL   14,SPARENC                                      @SC93173 08190500
         IC    1,S1HND       Must encode handshake             @SC93173 08191000
         BAL   14,SPARENC                                      @SC93173 08191500
         MVI   CTLTAB+ABL,1  Mark all printables unprefixed    @SC93173 08192000
         MVC   CTLTAB+ABL+1(94),CTLTAB+ABL                     @SC93173 08192500
SPARBAK  RET                                                   @SC86152 08193000
*                                                                       08193500
SPARENC  CL    1,=F'160'     Proper control?                   @SC93173 08194000
         BNLR  14            No, ignore this one               @SC93173 08194500
         LTR   1,1           Assume "0" means not defined      @SC93173 08195000
         BZR   14            and ignore such                   @SC93173 08195500
         SR    0,0                                             @SC93173 08196000
         STC   0,CTLTAB(1)   Mark this one to encode           @SC93173 08196500
         BR    14                                              @SC93173 08197000
*                                                                       08197500
SPARCKQX CLM   4,1,RCTLQ                                       @SC86120 08198000
         BER   14            Cannot use same prefix            @SC86120 08198500
         CLM   4,1,SCTLQ                                       @SC86120 08199000
         BER   14                                              @SC86120 08199500
         B     CHKQR         Test if 33-62 or 96-126           @SC86120 08200000
SPARFTCH L     4,SPACE       Default                           @SC86120 08200500
         BXH   5,6,*+8       Check for more data               @SC86120 08201000
         IC    4,0(5)        OK, use it                        @SC86120 08201500
         C     4,SPACE       Default?                          @SC86120 08202000
         BNER  14                                              @SC86120 08202500
         IC    4,0(5,8)      Yes, get default value            @SC86190 08203000
         BR    14                                              @SC86120 08203500
*                                                                       08204000
*        SPARSET Routine - set up for exchange (SPAR 1st)      @SC86152 08204500
*                                                                       08205000
SPARSET  ENTER ALT                                             @SC86152 08205500
         MVI   BCTR,0        Use whatever micro wants          @SC86152 08206000
         MVI   EBQ,0                                           @SC86152 08206500
         MVI   RPTQ,0                                          @SC86152 08207000
         MVI   BCTU,1        Must start at 1                   @SC86295 08207500
         MVC   BCTOFF,F0     (and flag at 0)                   @SC92085 08208000
         B     SPARBAK                                         @SC86152 08208500
         LOCALS ,                                              @SC86295 08209000
SPAR     EXIT                                                           08209500
         TITLE 'RPAR Routine - sets up parms to send to other host'     08210000
RPAR     ENTER                                                          08210500
         OI    FL3,PXCH      Parameters exchanged now          @SC87012 08211000
         L     9,ASDATA                                        @SC86295 08211500
         TOCHR 5,RTIMO,1(9)  Time limit for micro to wait      @SC86295 08212000
         TOCHR 5,RPADN,2(9)  Number of padding chars.          @SC86295 08212500
         CTL   5,RPADC,3(9)  Pad character                     @SC86295 08213000
         TOCHR 5,REOL,4(9)   EOL char I need                   @SC86295 08213500
         MVC   5(1,9),SCTLQ                                    @SC86295 08214000
         MVC   6(1,9),EBQ                                      @SC86295 08214500
         CLI   EBQ,0                                                    08215000
         BNE   RPARBCT               It's OK if not null                08215500
         MVI   6(9),AN       Else, use an N                    @SC86295 08216000
RPARBCT  MVC   7(1,9),BCTR   Negotiated checksum               @SC86295 08216500
         MVC   8(1,9),RPTQ                                     @SC86295 08217000
         CLI   RPTQ,0                                                   08217500
         BNE   *+8           It's ok if not null               @SC86149 08218000
         MVI   8(9),ABL      Else, use a blank                 @SC86295 08218500
         LA    0,10          Size of data                      @SC86149 08219000
         NI    SCAPA,255-LONGP No long packets                 @TB86196 08219500
         L     5,RPSIZ       Packet size                       @SC92030 08220000
         L     6,AMAXRS      Biggest send for full-screen      @SC92030 08220500
         CLI   TRMTP,C'A'    3174 AEA mode?                    @SC92030 08221000
         BNE   *+8           No, fine                          @SC92030 08221500
          LA   6,127         Strict limit of 3174 buffer       @SC92030 08222000
         BAL   14,TTYCHK                                       @SC92030 08222500
          L    6,AMAXRT      TTY limited separately by system  @SC92030 08223000
         CLI   TRMTP,C'F'    Full-screen non-transparent?      @SC92030 08223500
         BNE   *+8           No                                @SC92030 08224000
          LA   6,78          Strict limit                      @SC92030 08224500
         CR    5,6                                             @SC92030 08225000
         BNH   *+6                                             @SC92030 08225500
          LR   5,6           Biggest we can receive            @SC92030 08226000
         LA    4,KMAX        Limit for short packets           @SC92030 08226500
         CR    4,5           Check against actual limit        @SC92030 08227000
         BNH   *+6                                             @SC92030 08227500
          LR   4,5           Use actual limit                  @SC92030 08228000
         TOCHR 4,,0(9)       Largest short packet size         @SC92030 08228500
         C     5,AKMAX       Are we allowing long packets?     @SC92030 08229000
         BNH   RPARNEX       KMAX >= RPSIZ                     @SC92030 08229500
         OI    SCAPA,LONGP   Long packets                      @TB86196 08230000
         MVI   10(9),ABL     Window size is blank              @SC86295 08230500
RPARS1   SR    4,4                                             @SC86205 08231000
         SH    5,=H'7'       Allow for long header             @SC90277 08231500
         D     4,XLFCT       Compute extended size bytes       @TB86196 08232000
         TOCHR 5,,11(9)      Extended size 1                   @SC86295 08232500
         TOCHR 4,,12(9)      Extended size 2                   @SC86295 08233000
         LA    0,13          Size of data                      @TB86196 08233500
RPARNEX  DS    0H                                              @TB86196 08234000
         TOCHR 5,SCAPA,9(9)  Capabilities                      @SC86295 08234500
         ST    0,DATL        Return it                         @SC86149 08235000
         LA    0,3           Reset function                    @SC86295 08235500
         BAL   14,TTYCHK                                       @SC92030 08236000
          B    RPARSTT       Line mode                         @SC92030 08236500
         KCALL SCRNIO                                          @SC86295 08237000
         B     RPARBAK                                         @SC86295 08237500
RPARSTT  KCALL TERMIO                                          @SC86295 08238000
RPARBAK  RET                                                   @SC86152 08238500
*                                                                       08239000
*        RPARSET Routine - set up for exchange (RPAR 1st)      @SC86152 08239500
*                                                                       08240000
RPARSET  ENTER ALT                                             @SC86152 08240500
         MVI   BCTU,1        Must start at 1                   @SC86295 08241000
         MVC   BCTOFF,F0     (and flag at 0)                   @SC92085 08241500
         CLI   TRMTP,C'F'                                      @SC92030 08242000
         BNE   *+8                                             @SC92030 08242500
          MVI  S1EOL,AEXCL   Insist on printable EOL for FULL  @SC92030 08243000
         TM    FL2,SRV       Possible I-packet exchange?       @SC87169 08243500
         BZ    RPSCLR        Not in Server mode                @SC87169 08244000
         TM    FL3,PXCH      Any exchange since last SET?      @SC87169 08244500
         BO    RPARBAK       Yes, keep latest settings         @SC87169 08245000
RPSCLR   MVC   BCTR,BCTC     Use what user set                 @SC87169 08245500
         TR    BCTR,ETOAD    Convert to ASCII code             @SC92085 08246000
         MVC   EBQ,EBQC      Set what we want otherwise        @SC86152 08246500
         CLI   LCKFRC,X'21'  Forcing locks?                    @SC91275 08247000
         BNE   RPSEBQ        No, ok                            @SC91275 08247500
         MVI   EBQ,0         Yes, disable 8-bit quote          @SC91275 08248000
RPSEBQ   CLI   RPTQ,0                                          @SC86152 08248500
         BNE   RPARBAK       If RPTQ is set leave it alone     @SC86152 08249000
         MVC   RPTQ,RPTQC    Set what we want otherwise        @SC86152 08249500
         B     RPARBAK                                         @SC86152 08250000
         LOCALS ,                                              @SC86295 08250500
RPAR     EXIT                                                           08251000
         TITLE 'ENCODE Routine - encode pkts from RBUF into DATA'       08251500
ENCODE   ENTER                                                          08252000
         L     6,MAXSIZ                                        @SC86295 08252500
         L     9,ASDATA      Pointer to data to fill           @SC86190 08253000
         AR    6,9           Limit on output                   @SC86295 08253500
ENCAGAIN L     8,RBUFP               Index of next char in RBUF         08254000
         L     5,RBUFL       Data length in RBUF               @SC86163 08254500
         L     1,RBUF                Point to start of buffer           08255000
         AR    5,1                   Point to char after last one       08255500
         AR    8,1           Point to char to encode           @SC86163 08256000
         CR    8,1           Are we at the start?              @SC91116 08256500
         BH    ENCNXT        No, proceed                       @SC91116 08257000
         TM    FL1,NAME                                        @SC91320 08257500
         BO    ENCNXT        Names don't have CC anyway        @SC91320 08258000
         TM    FL1,EOF       Are we at the end?                @SC91116 08258500
         BO    ENCNXT        Yes, quit inserting CC            @SC91116 08259000
         TM    FLNFLGS,FLNCC Yes, see if handling carriage ctl @SC91116 08259500
         BZ    ENCNXT        No, proceed                       @SC91116 08260000
         CR    5,1           Are we before 1st record?         @SC91116 08260500
         BE    ENCNXT        Yes, must read and look again     @SC91116 08261000
         SR    1,1                                             @SC91116 08261500
         ICM   1,1,CARCTL                                      @SC91116 08262000
         BZ    ENCNXTIN                                        @SC91116 08262500
         C     1,F3                                            @SC91116 08263000
         BH    ENCNXT        Already set up: 1 replacement     @SC91116 08263500
         LA    0,0(1,9)      Allow for the inserts             @SC91116 08264000
         CR    0,6           Plenty of room?                   @SC91116 08264500
         BH    ENCGOOD       No, dump out a packet now         @SC91116 08265000
ENCCCLP  MVC   0(1,9),SCTLQ  Insert a LF                       @SC91116 08265500
         MVI   1(9),ALF+64                                     @SC91116 08266000
         LA    9,2(,9)                                         @SC91116 08266500
         BCT   1,ENCCCLP     Repeat correct number of LF's     @SC91116 08267000
         B     ENCNXTIN      Done inserting                    @SC91116 08267500
ENCNXT   CR    8,5           Are we past the last char?        @SC86163 08268000
         BL    ENCPKT        No, not exhausted RBUF yet        @SC86163 08268500
         TM    FL1,NAME                                        @SC86163 08269000
         BO    ENCEMPT       No more disk read if file name    @SC86163 08269500
         KCALL INBUF,E=ENCRET                                  @SC86163 08270000
         B     ENCAGAIN                                        @SC86163 08270500
ENCPKT   MVC   NEWCHAR,0(8)  Get next input character          @SC91275 08271000
         TM    LCKCAPA,X'20'                                   @SC91275 08271500
         BZ    ENCLKZ        Locking shift not enabled         @SC91275 08272000
         MVC   LCKNEW,0(8)   Look ahead 5 characters           @SC91275 08272500
         NC    LCKNEW,=5X'80' Grab the 8th bits                @SC91275 08273000
         CLC   LCKOLD,LCKNEW Is the next one the right state?  @SC91275 08273500
         BE    ENCLKOK       Yes, go on                        @SC91275 08274000
         CLI   EBQ,0         8th-bit quoting allowed?          @SC91275 08274500
         BE    ENCLKSW       No, must switch                   @SC91275 08275000
         CLI   0(8),CR                                         @SC91275 08275500
         BE    ENCLKSW       CR, prevent interference with CC  @SC91275 08276000
         CLI   0(8),SI+128                                     @SC91275 08276500
         BE    ENCLKOK       Avoid quoting shifted <1>SI       @SC91275 08277000
         CLC   LCKNEW(4),LCKNEW+1 Different state; isolated?   @SC91275 08277500
         BNE   ENCLKOK       Yes, keep same state              @SC91275 08278000
ENCLKSW  MVC   LCKOLD,LCKNEW Adjust state                      @SC91275 08278500
         MVC   0(1,9),SCTLQ  Insert prefix                     @SC91275 08279000
         MVI   1(9),SO+64    Make a Shift Out                  @SC91275 08279500
         CLI   LCKNEW,X'80'  8-bit chars?                      @SC91275 08280000
         BE    *+8           Yes, that's it                    @SC91275 08280500
          MVI  1(9),SI+64    No, make a Shift In               @SC91275 08281000
         LA    9,2(,9)       Advance output ptr                @SC91275 08281500
         CR    9,6           Did we reach max pkt size?        @SC91275 08282000
         BNL   ENCFULL       Yes, must empty buffer now        @SC91275 08282500
ENCLKOK  XC    NEWCHAR,LCKOLD Apply state                      @SC91275 08283000
         CLI   NEWCHAR,SO                                      @SC91275 08283500
         BL    ENCLKZ        Not a data-link special           @SC91275 08284000
         CLI   NEWCHAR,DLE                                     @SC91275 08284500
         BH    ENCLKZ        Not a special                     @SC91275 08285000
         LA    14,2(,9)      Updated pointer                   @SC91275 08285500
         CR    14,6          Special, is there enough room?    @SC91275 08286000
         BNL   ENCFULL       No, must empty buffer now         @SC91275 08286500
         MVC   0(1,9),SCTLQ  Special, quote with DLE           @SC91275 08287000
         MVI   1(9),DLE+64                                     @SC91275 08287500
         LR    9,14          Advance ptr                       @SC91275 08288000
ENCLKZ   CLI   RPTQ,0                                          @SC91275 08288500
         BE    ENCEBQ                Go if no repeat quoting            08289000
         CLC   0(1,8),1(8)   At least 2 of these?              @SC92052 08289500
         BNE   ENCEBQ        No, not enough                    @SC86163 08290000
         LA    14,2(,8)      Next untested character           @SC92052 08290500
         LR    2,8           Start of string                   @SC86163 08291000
         LA    3,KMAX(8)     Max allowed by notation           @SC86163 08291500
         CR    3,5           Watch for end of data             @SC86163 08292000
         BNH   *+6                                             @SC86163 08292500
         LR    3,5           Truncate at max                   @SC86163 08293000
         LR    15,3          Same limit                        @SC86163 08293500
         SR    3,2           Get lengths                       @SC86163 08294000
         SR    15,14         Length of shorter string          @SC86163 08294500
         BM    ENCEBQ        2nd one wasn't real after all     @SC92052 08295000
         ICM   15,8,0(8)     Use starting char for fill        @SC86163 08295500
         CLCL  2,14          Find end of match                 @SC86163 08296000
         SR    14,8          Get repeat count                  @SC86163 08296500
         C     14,=A(RPTMIN) Enough to justify?                @SC92052 08297000
         BL    ENCEBQ        No, not enough                    @SC92052 08297500
         AR    8,14          Advance ptr to                    @SC86163 08298000
         BCTR  8,0             last matching char              @SC86163 08298500
         MVC   0(1,9),RPTQ   Put repeat quote into DATA        @SC86163 08299000
         TOCHR 14,,1(9)                                        @SC86163 08299500
         LA    9,2(9)        Count 2 for RPTQ and rpt count    @SC86295 08300000
ENCEBQ   TM    NEWCHAR,X'80' 8th bit on?                       @SC91275 08300500
         BZ    ENCCTL                no 8th bit                         08301000
         CLI   EBQ,0                                                    08301500
         BNE   ENC8B         Can use 8bit quoting, do it       @SC89072 08302000
         TM    SPRTY,DAT8    Can't: see if 8-bit channel       @SC89072 08302500
         BO    ENCCTL        Yes, that's ok too                @SC89072 08303000
         MVI   ERRNUM,ERRPTY No, can't send this byte!         @SC89072 08303500
         LA    15,1                                            @SC89072 08304000
         B     ENCRET        Save length, in case ERPACK loop  @SC89072 08304500
ENC8B    DS    0H                                              @SC89072 08305000
         NI    NEWCHAR,127   Get rid of 8th bit                @SC91275 08305500
         MVC   0(1,9),EBQ            Move EBQ into DATA                 08306000
         LA    9,1(9)        Count for it                      @SC86295 08306500
ENCCTL   IC    7,NEWCHAR     Load desired char                 @SC91275 08307000
         CLI   NEWCHAR,160   Corresponds to control character? @SC93173 08307500
         BNL   ENCNCTL       Not within control range          @SC93173 08308000
         TRT   NEWCHAR,CTLTAB Check table of safe ctls         @SC93173 08308500
         BNZ   ENCNCTLT      Don't need to encode it           @SC93173 08309000
ENCSCTL  CTL   7             Convert to non-control            @SC86163 08309500
         B     ENCMVCTL                                                 08310000
*                                                                       08310500
ENCNCTLT LTR   7,7                                             @SC93173 08311000
         BZ    ENCNOCTL      NUL can't be a prefix char        @SC93173 08311500
ENCNCTL  CLM   7,1,SCTLQ                                       @SC93173 08312000
         BE    ENCMVCTL              send prefix if ctl quote char      08312500
         CLM   7,1,EBQ                                         @SC93173 08313000
         BE    ENCMVCTL              ditto if 8bit quote                08313500
         CLM   7,1,RPTQ                                        @SC93173 08314000
         BNE   ENCNOCTL              not so if not repeat quote         08314500
ENCMVCTL MVC   0(1,9),SCTLQ          Move a ctl quote                   08315000
         LA    9,1(9)                incr for it                        08315500
ENCNOCTL STC   7,0(9)        Move the char, finally!           @SC86163 08316000
         LA    9,1(9)                incr for it                        08316500
ENCNXTIN MVI   CARCTL,1      Indicate started output           @SC91116 08317000
         LA    8,1(8)        Incr RBUF pointer                 @SC86163 08317500
         CR    9,6           Did we reach max pkt size?        @SC86295 08318000
         BL    ENCNXT        Test for more data                @SC86295 08318500
*                                                                       08319000
ENCFULL  CR    8,5           Are we past the last char?        @SC86163 08319500
         BL    ENCGOOD       No, not exhausted RBUF data yet   @SC86163 08320000
ENCEMPT  XC    RBUFL,RBUFL   Zap data length for next time     @SC86163 08320500
ENCGOOD  SR    15,15                                                    08321000
         S     8,RBUF        Get current index                 @SC86163 08321500
         ST    8,RBUFP               Save RBUF index                    08322000
ENCRET   S     9,ASDATA      Get length                        @SC86295 08322500
         ST    9,DATL        Save encoded DATA length          @SC86295 08323000
         RET   ,                                               @SC86295 08323500
         LOCALS ,                                              @SC86295 08324000
LCKNEW   DS    CL5           5-byte lookahead for shift lock   @SC91275 08324500
NEWCHAR  DS    C             Current character with shifts     @SC91275 08325000
ENCODE   EXIT                                                           08325500
         TITLE 'NPREAD Routine - copy from RBUF to SDATA'      @HF86150 08326000
NPREAD   ENTER                                                 @HF86150 08326500
         L     6,SPSIZ       Max packet length                 @SC86295 08327000
         LR    4,6           Save                              @SC86295 08327500
         L     9,ASPKT       Fill pointer (includes header)    @SC86165 08328000
         SR    7,7                                             @SC86165 08328500
         ICM   7,1,TCTLQ     Fetch control quote               @SC91180 08329000
         BZ    *+8           Quoting is off                    @SC91180 08329500
          ICM  7,2,EBQC      Get 8th-bit quote as well         @SC91180 08330000
NPRAGAIN L     8,RBUFP       Index of next char in RBUF        @SC86165 08330500
         L     5,RBUFL       Data length in RBUF               @SC86165 08331000
         L     1,RBUF        Start of buffer                   @SC86165 08331500
         AR    5,1           Point to char after last one      @SC86165 08332000
         AR    8,1           Point to char to encode           @SC86165 08332500
         CR    8,1           Are we at the start?              @SC91116 08333000
         BH    NPRNXT        No, proceed                       @SC91116 08333500
         TM    FLNFLGS,FLNCC Yes, see if handling carriage ctl @SC91116 08334000
         BZ    NPRNXT        No, proceed                       @SC91116 08334500
         TM    FL1,BINF                                        @SC91116 08335000
         BO    NPRNXT        No CC if binary                   @SC91116 08335500
         CR    5,1           Are we before 1st record?         @SC91116 08336000
         BE    NPRNXT        Yes, must read and look again     @SC91116 08336500
         SR    1,1                                             @SC91116 08337000
         ICM   1,1,CARCTL                                      @SC91116 08337500
         BZ    NPRNXTIN                                        @SC91116 08338000
         C     1,F3                                            @SC91116 08338500
         BH    NPRNXT        Already set up: 1 replacement     @SC91116 08339000
         CR    1,6           Plenty of room?                   @SC91116 08339500
         BH    NPRGOOD       No, dump out a packet now         @SC91116 08340000
NPRCCLP  MVI   0(9),ALF      Insert a LF                       @SC91116 08340500
         LA    9,1(,9)                                         @SC91116 08341000
         BCTR  6,0           Count down space remaining        @SC91116 08341500
         BCT   1,NPRCCLP     Repeat correct number of LF's     @SC91116 08342000
NPRNXTIN MVI   CARCTL,1      Mark it begun                     @SC91116 08342500
         LA    8,1(,8)       Skip over the control             @SC91116 08343000
         LTR   6,6                                             @SC91116 08343500
         BNP   NPRGOOD                                         @SC91116 08344000
NPRNXT   CR    8,5           Are we past the last char?        @SC86165 08344500
         BL    NPRTCT        No, not exhausted RBUF yet        @SC86165 08345000
NPRRD    KCALL INBUF,E=NPRRET                                  @HF86150 08345500
         B     NPRAGAIN                                        @SC86165 08346000
NPRTCT   LTR   7,7           Test for quoting                  @SC86165 08346500
         BZ    NPRNOCTL      Not enabled                       @HF86150 08347000
         MVI   NPR8B,0       Clear the 8th bit flag            @SC91180 08347500
         CLM   7,2,0(8)      8th-bit quote?                    @SC91180 08348000
         BNE   NPRNO8B       No, ok                            @SC91180 08348500
         MVI   NPR8B,128     Yes, set flag                     @SC91180 08349000
         LA    8,1(,8)       Next byte is what counts          @SC91180 08349500
         CR    8,5                                             @SC91180 08350000
         BNL   NPRRD         Ran out of data, ignore the quote @SC91180 08350500
NPRNO8B  DS    0H                                              @SC91180 08351000
         CLM   7,1,0(8)      Is it a quote character?          @HF86150 08351500
         BNE   NPRNOCT0      No, copy it                       @SC91180 08352000
         LA    8,1(8)        Check next                        @HF86150 08352500
         CR    8,5                                             @HF86150 08353000
         BNL   NPRRD         Ran out of data, ignore the quote @HF86150 08353500
         CLM   7,2,0(8)      If 8th-bit quote character,       @SC91180 08354000
         BE    NPRNOCT0       it was quoted, so use it.        @SC91180 08354500
         CLM   7,1,0(8)      If repeat of quote character      @HF86150 08355000
         BE    NPRNOCT0       it was quoted, so use it.        @SC91180 08355500
         NI    0(8),X'1F'    Make control character            @HF86150 08356000
NPRNOCT0 OC    0(,8),NPR8B   Get proper 8th bit                @SC91180 08356500
NPRNOCTL MVC   0(1,9),0(8)   Copy the char                     @HF86150 08357000
         LA    9,1(9)        Incr for it                       @HF86150 08357500
         LA    8,1(8)        Incr RBUF pointer                 @HF86150 08358000
         BCT   6,NPRNXT      Get next character if any room    @SC86295 08358500
*                                                                       08359000
NPRGOOD  SR    15,15                                           @HF86150 08359500
         S     8,RBUF        Convert to index                  @SC86165 08360000
         ST    8,RBUFP       Save it                           @SC86165 08360500
NPRRET   SR    4,6           Get DATA length                   @SC86295 08361000
         ST    4,SNDPKL      Save it                           @HF86150 08361500
         RET                                                   @HF86150 08362000
         LOCALS ,                                              @SC86295 08362500
NPR8B    DS    X             8th bit flag                      @SC91180 08363000
NPREAD   EXIT                                                  @HF86150 08363500
         TITLE 'DECODE Routine - decode pkts from DATA to WBUF'         08364000
* Exit: ERRNUM left unchanged unless there is an error.                 08364500
DECODE   ENTER                                                          08365000
         ICM   5,B'1111',DATL        Data length to decode              08365500
         BNP   DECNULL       No data to decode                 @SC91247 08366000
         TM    FL1,EOF                                                  08366500
         BO    DECNULL               Ignore if ctl-z caused EOF         08367000
         L     1,WBUF                Point to output buffer             08367500
         L     9,WBUFL               Number of chars in it              08368000
         AR    1,9                   Point to next spot to fill         08368500
         L     8,ARDATA      Data to be decoded                @SC86190 08369000
         AR    5,8           Point one past the last char               08369500
DECLOOP  LA    3,1           Repeat count                      @SC86316 08370000
         CLI   RPTQ,0                                                   08370500
         BE    DECEBQ                Not doing repeats                  08371000
         CLC   RPTQ,0(8)                                                08371500
         BNE   DECEBQ                Not the repeat quote               08372000
         UNCHR 3,1(8)        Get number of repeats             @SC86316 08372500
         LA    8,2(8)                skip to char to decode             08373000
DECEBQ   MVI   CUR,0                 No 8th bit yet                     08373500
         CLI   EBQ,0                                                    08374000
         BE    DECCTL                Not doing 8bit quoting             08374500
         CLC   EBQ,0(8)                                                 08375000
         BNE   DECCTL                Not the 8bit quote                 08375500
         LA    8,1(8)                point to char to decode            08376000
         MVI   CUR,128               8th bit seen                       08376500
DECCTL   CLC   RCTLQ,0(8)                                               08377000
         BNE   DECCHR                not the ctl quote                  08377500
         LA    8,1(8)                point to char to decode            08378000
         MVC   TMPC,0(8)                                       @SC90270 08378500
         NI    TMPC,127      Look at low 7 bits                @SC90270 08379000
         CLI   TMPC,63                                         @SC90270 08379500
         BL    DECCHR                skip if not in ctl range           08380000
         CLI   TMPC,95                                         @SC90270 08380500
         BH    DECCHR                skip if not in ctl range           08381000
         CTL   4,0(8),0(8)           Ctl it                             08381500
DECCHR   OC    0(1,8),CUR            put in the parity                  08382000
         TM    LCKCAPA,X'20' Locking shift enabled?            @SC91275 08382500
         BZ    DECCH2        No, just do the byte              @SC91275 08383000
         CLI   DECESCP,DLE   Escape pending?                   @SC91275 08383500
         BE    DECCH2        Yes, just do the byte             @SC91275 08384000
         CLI   0(8),SO       No, see if special coming         @SC91275 08384500
         BL    DECCH2        No                                @SC91275 08385000
         CLI   0(8),DLE                                        @SC91275 08385500
         BH    DECCH2        No                                @SC91275 08386000
         MVC   DECESCP,0(8)  Save special indicator            @SC91275 08386500
         BE    DECINCIN      Escape: ignore and suppress repeat@SC91275 08387000
         XI    0(8),X'0F'    SO->1, SI->0                      @SC91275 08387500
         IC    14,0(,8)      Convert to new state byte         @SC91275 08388000
         SLL   14,7                                            @SC91275 08388500
         STC   14,LCKOLD     Save it                           @SC91275 08389000
         B     DECINCIN      Nothing further on this byte      @SC91275 08389500
DECCH2   MVI   DECESCP,0     Not an escape                     @SC91275 08390000
         XC    0(1,8),LCKOLD Put to current state              @SC91275 08390500
         MVC   CUR,0(8)              move it here also                  08391000
DECRLOOP TM    FL1,NAME                                                 08391500
         BO    DECPUT                skip if not writing to disk        08392000
         LTR   7,9           Started yet?                      @SC86316 08392500
         BZ    DECTFUL       No                                @SC86151 08393000
         C     9,RDWLEN                                        @SC86151 08393500
         BNE   DECTFUL                                         @SC86151 08394000
         L     6,WBUF        Just finished RDW                 @SC86316 08394500
         SR    14,14                                           @SC86151 08395000
         ICM   14,3,0(6)     Get expected length               @SC86316 08395500
         C     9,F2          Short?                            @SC86262 08396000
         BE    DECVLEN       Yes, we got it                    @SC86262 08396500
         TR    0(5,6),ATOED  No, must be 5-byte ASCII prefix   @SC89301 08397000
         BAL   14,GETNUM     Read length field                 @SC86316 08397500
          B    DECDLBAD      Bad                               @SC91247 08398000
         LR    14,0                                            @SC86316 08398500
DECVLEN  DS    0H                                              @SC86262 08399000
         AR    14,9               + RDW length                 @SC86151 08399500
         ST    14,MAXOUT     Reset byte limit                  @SC86151 08400000
DECTFUL  C     9,MAXOUT      Max write buffer size reached?    @SC86151 08400500
         BL    DECMORE       No, keep appending                @SC88120 08401000
         KCALL OUTBUF,(9),E=RTRN1 Yes, write buffer            @SC88120 08401500
         SR    9,9           Reset count and output pointer    @SC88120 08402000
         L     1,WBUF                                          @SC88120 08402500
         TM    FL1,BINF                                        @SC88120 08403000
         BO    DECPUT        Binary always folds, no problem   @SC88120 08403500
         CLI   CUR,CR        Exactly full just in time?        @SC88120 08404000
         BE    DECIGN        Yes, don't create empty line      @SC88120 08404500
         LA    0,1           Other, this is called folding     @SC88120 08405000
         A     0,RECFLD                                        @SC88120 08405500
         ST    0,RECFLD                                        @SC88120 08406000
         B     DECPUT        Ok, now copy the new character    @SC88120 08406500
DECMORE  TM    FL1,BINF                                                 08407000
         BO    DECPUT                No special test in binary mode     08407500
         CLI   CUR,CR                                                   08408000
         BE    DECWRT                A cr means end of record           08408500
         CLI   CUR,ALF                                         @SC89301 08409000
         BNE   DECTAB                Not an LF                          08409500
         CLI   PREV,CR                                                  08410000
         BE    DECIGN                A cr/lf together = ignre the LF    08410500
DECWRT   KCALL OUTBUF,(9),E=RTRN1 Write buffer                 @SC88120 08411000
         SR    9,9                   Reset length to resume decoding    08411500
         L     1,WBUF                Reset pointer also                 08412000
         B     DECIGN                                                   08412500
*                                                                       08413000
DECTAB   TM    FL2,TABS                                                 08413500
         BZ    DECCTLZ               Skip if not expanding tabs         08414000
         CLI   CUR,AHT                                         @SC89301 08414500
         BNE   DECCTLZ               Not a tab                          08415000
         LR    0,1           Save output ptr                   @SC86355 08415500
         LH    2,TABCNT      Get count of tabs that are set    @TS86100 08416000
         LTR   2,2           Any?                              @SC86355 08416500
         BZ    DECTL8        No, use every 8 cols              @SC86355 08417000
         LA    7,TABTBL      Yes, point to table of tabs       @TS86100 08417500
         SR    1,1                                             @TS86100 08418000
DECTLP   IC    1,0(7)        Get tab column from table         @TS86100 08418500
         BCTR  1,0           Adjust for displacement compare   @TS86100 08419000
         CR    1,9           Where is this tab compared to buf @TS86100 08419500
         BH    DECTLX        Above buffer position             @TS86100 08420000
         LA    7,1(7)        Point to next tab position        @TS86100 08420500
         BCT   2,DECTLP      Continue with next tab            @TS86100 08421000
DECTL8   DS    0H                                              @SC86355 08421500
         LA    1,8(9)        Buffer pointer + 8                @SC86355 08422000
         SRL   1,3                                             @SC86355 08422500
         SLL   1,3           Round up to multiple of 8         @SC86355 08423000
DECTLX   C     1,MAXLRC                                        @SC86355 08423500
         BL    *+8                                             @SC86355 08424000
         L     1,MAXLRC      Don't go past end of buffer       @SC86355 08424500
         SR    1,9           Number of blanks to add           @SC86355 08425000
         AR    9,1           Advance the count                 @SC86355 08425500
         LA    15,ABL                                          @SC86355 08426000
         SLL   15,24         Set for ASCII blank fill          @SC86355 08426500
         MVCL  0,14          Jump to tab stop                  @SC86355 08427000
         LR    1,0           Restore output ptr                @SC86355 08427500
         B     DECIGN                skip to the end of this            08428000
*                                                                       08428500
DECCTLZ  TM    FL2,EOFZ                                                 08429000
         BZ    DECPUT                Skip if EOF is off                 08429500
         CLI   CUR,ASUB                                        @SC89301 08430000
         BNE   DECPUT                Skip if not a ctl-z                08430500
         OI    FL1,EOF               Fake an end-of-file                08431000
         B     DECEOF                all done                           08431500
*                                                                       08432000
DECPUT   C     9,F64KP       Still within disk buffer?         @SC90338 08432500
         BNL   *+10          No, don't copy                    @SC86355 08433000
         MVC   0(1,1),0(8)   Yes, put the data in buffer       @SC86355 08433500
         LA    9,1(9)                Increment count                    08434000
         LA    1,1(1)                Increment pointer                  08434500
DECIGN   MVC   PREV,CUR              copy the decoded char              08435000
         BCT   3,DECRLOOP    Repeat it repeat count times      @SC86316 08435500
DECINCIN LA    8,1(,8)       Bump input data ptr               @SC91275 08436000
         CR    8,5                   Did we reach end of DATA?          08436500
         BL    DECLOOP               No, More data left to decode       08437000
DECEOF   ST    9,WBUFL               Save buffer length                 08437500
DECNULL  B     RTRN0         Good return code                  @SC86295 08438000
*                                                                       08438500
DECDLBAD MVI   ERRNUM,ERRBPC Bad length field for D-binary     @SC91247 08439000
         B     RTRN1                                           @SC91247 08439500
         LOCALS ,                                              @SC86295 08440000
CUR      DS    C             Char being decoded                @SC86295 08440500
TMPC     DS    C             Low 7 bits of char                @SC90270 08441000
DECODE   EXIT                                                           08441500
         TITLE 'ERPACK Routine - send error packet with errnum'         08442000
ERPACK   ENTER                                                          08442500
         CLI   ERRNUM,ERRABO                                   @SC86295 08443000
         BE    RTRN0         Skip it if the micro died         @SC86295 08443500
         CLOSF SIMPTR        In case we were replaying this    @SC91312 08444000
         MVI   STYPE,AE              Error packet                       08444500
         MVC   SEQ,RSN               Synch packet numbers               08445000
         SR    5,5                                                      08445500
         IC    5,ERRNUM              Get right message number           08446000
         SLL   5,2           Pointer offset = ERRNUM * 4       @SC86156 08446500
         A     5,=A(ERRTAB)  Pointer address                   @SC89215 08447000
         L     3,0(5)        Msg ptr                           @SC86156 08447500
         SR    4,4                                             @SC86156 08448000
         IC    4,0(5)        Msg length                        @SC86156 08448500
         TM    FL2,PROTO                                       @SC87300 08449000
         BZ    RTRN0         Skip packet if never started      @SC87300 08449500
         TM    FL3,ZPRO                                        @SC92064 08450000
         BO    *+12          Must stop, even if server mode    @SC92064 08450500
         TM    FL2,SRV       Server will read another command  @SC87343 08451000
         BO    *+12           so don't zap write/read flag     @SC90173 08451500
          MVI  WRRD,0        No read ncessary for Err pkt      @SC87300 08452000
          MVI  AEAFLG,X'80'  ditto                             @SC90173 08452500
         L     1,RBUF                                                   08453000
         MVC   0(50,1),0(3)  Put data in RBUF (and some extra) @SC86156 08453500
         CLI   ERRNUM,ERRTRC Cancelled?                        @SC91172 08454000
         BNE   ERPCODE       No, message is complete           @SC91172 08454500
         SR    9,9                                             @SC91172 08455000
         CLI   REASON,STACNN Within table?                     @SC91172 08455500
         BH    *+8           No, must be new                   @SC91172 08456000
          IC   9,REASON      Ok, get the complaint code        @SC91172 08456500
         SLL   9,3           Index into table                  @SC91172 08457000
         A     9,=A(STACNTB)                                   @SC91172 08457500
         LA    3,0(4,1)      Offset to end of message          @SC91172 08458000
         MVI   0(3),C' '     Leave a space                     @SC91172 08458500
         MVC   1(8,3),0(9)   Get type of cancellation          @SC91172 08459000
         LA    4,9(,4)       Lengthen message                  @SC91172 08459500
ERPCODE  ST    4,RBUFL       Save length to encode             @SC91172 08460000
         TR    0(50,1),ETOAD ASCII it                          @SC89301 08460500
         LA    8,F0          Point to null list                @SC89072 08461000
         BAL   9,ENCODEN                                       @SC86295 08461500
         KCALL SPACK         Send error packet                 @SC86135 08462000
         RET                                                            08462500
         LOCALS ,                                              @SC86295 08463000
ERPACK   EXIT                                                           08463500
         TITLE 'SPACK Routine - sends DATA buffer'                      08464000
SPACK    ENTER                                                          08464500
         SR    3,3                   Zero out IC register               08465000
         L     8,AASPKT      SNDPKT address                    @SC86295 08465500
SPKNX3   LA    8,3(8)        Remove LX1, LX2, HCHECK from hdr  @SC86295 08466000
         L     9,DATL                Data size                          08466500
         IC    3,BCTU                CHK len                            08467000
         LA    9,2(3,9)              Data, CHK, SEQ, TYP lengths        08467500
         LA    1,3(9)        Plus SOH, LEN, EOL lengths        @SC86202 08468000
         C     9,AKMAX       Check packet length byte          @SC86202 08468500
         BNH   SPKNXDL1      No extended data len              @SC86202 08469000
         LA    1,3(1)        Plus LX1,LX2,HCHECK for ext. hdr  @SC86202 08469500
         SR    9,9           Set 'Type 0' extended hdr         @SC86202 08470000
         SH    8,SPKNX3+2    Remove LX1, LX2, HCHECK from hdr  @SC86295 08470500
SPKNXDL1 ST    1,SNDPKL      SNDPKT length                     @SC86202 08471000
         ST    8,ASPKT       Ptr to buffer                     @SC86295 08471500
         MVC   0(1,8),SMARK  Add mark to packet                @SC86295 08472000
         TOCHR 9,,1(8)       Add it to packet                  @SC86295 08472500
         TOCHR 4,SEQ,2(8)    Get packet number                 @SC86295 08473000
         AR    9,4                   And add to checksum                08473500
         IC    3,STYPE               Type                               08474000
         STC   3,3(8)        Store in buffer                   @SC86295 08474500
         AR    9,3                   Add to checksum                    08475000
         CLI   1(8),ABL      Chk 'Type 0' extended hdr         @SC86295 08475500
         BNE   SPKNXDL3      No extended data len              @TB86196 08476000
         L     7,DATL        Data size                         @TB86196 08476500
         IC    3,BCTU        CHK len                           @TB86196 08477000
         AR    7,3           Sum = extended length             @TB86196 08477500
         SR    6,6                                             @TB86196 08478000
         D     6,XLFCT       Get two parts                     @TB86196 08478500
         TOCHR 7,,4(8)       Add LENX1 to packet               @SC86295 08479000
         AR    9,7           And add to checksum               @TB86196 08479500
         TOCHR 6,,5(8)       Add LENX2 to packet               @SC86295 08480000
         AR    9,6           And add to checksum               @TB86196 08480500
         LR    6,9           Chksum thru LENX2 byte            @TB86196 08481000
         SRL   6,6           High 2 bits of total              @TB86196 08481500
         N     6,F3          Get just 2 bits                   @SC86295 08482000
         AR    6,9           Get type-1 check value            @TB86196 08482500
         N     6,MOD64                                         @TB86196 08483000
         TOCHR 6,,6(8)       Make printable                    @SC86295 08483500
         AR    9,6           And add to checksum               @TB86196 08484000
SPKNXDL3 DS    0H                                              @TB86196 08484500
         L     8,ASDATA                                        @SC86295 08485000
         BCTR  8,0           Ptr one before data               @SC86295 08485500
         ICM   6,B'1111',DATL        Data length                        08486000
         BZ    SPKCHK                Go if no data                      08486500
         LR    5,6                                             @SC86135 08487000
SPKCHAR  IC    3,0(5,8)      Pick up char                      @SC86295 08487500
         AR    9,3                   Add to checksum                    08488000
         BCT   5,SPKCHAR     Yes, there's more data            @SC86135 08488500
SPKCHK   LA    6,1(6,8)      Point to where chksum goes        @SC86295 08489000
         LR    7,9                   Need copy of chksum                08489500
         CLI   BCTU,2                                                   08490000
         BE    SPKCHK2               Go if 2 char chksum                08490500
         BH    SPKCHK3               Go if 3 char CRC                   08491000
         SRL   9,6                   High 2 bits of total               08491500
         N     9,F3          Get just 2 bits                   @SC86295 08492000
         AR    7,9                   Add the two values                 08492500
         B     SPKCHK1               Go add chksum to data              08493000
*                                                                       08493500
SPKCHK3  L     5,ASPKT                                         @SC86190 08494000
         LA    5,1(5)        Where checksum starts             @SC86190 08494500
         KCALL CRCCLC        Calculate the CRC                          08495000
         LR    7,15                  Keep in here                       08495500
         SRL   15,12                 High 4 bits of high byte           08496000
         A     15,BCTOFF     0/1                               @SC92085 08496500
         TOCHR 15,,0(6)              Make char printable                08497000
         LA    6,1(6)                Bump output pointer                08497500
SPKCHK2  LR    15,7                  total                              08498000
         SRL   15,6          Next 6 bits of total              @SC86295 08498500
         N     15,MOD64      Get just 6 bits                   @SC86295 08499000
         A     15,BCTOFF     0/1                               @SC92085 08499500
         TOCHR 15,,0(6)              Make char printable                08500000
         LA    6,1(6)                Bump pointer                       08500500
SPKCHK1  N     7,MOD64               Get low order 6 bits               08501000
         A     7,BCTOFF      0/1                               @SC92085 08501500
         TOCHR 7,,0(6)               Make printable                     08502000
SPKEOL   MVC   1(2,6),S1EOL  Add micro's EOL char + handshake  @SC87274 08502500
         KCALL SIO           Write the SNDPKT                  @SC86135 08503000
         RET   ,             Return with SIO's rc              @SC86295 08503500
         LOCALS ,                                              @SC86295 08504000
SPACK    EXIT                                                           08504500
         TITLE 'RPACK Routine - Reads data into DATA buffer'            08505000
* ERRNUM set if error found, unchanged otherwise               @SC89219 08505500
RPACK    ENTER                                                          08506000
         MVI   RPKERN,ERRTIE Error if RIO fails                @SC90289 08506500
RPKRED   KCALL RIO,E=RPKNAK                                    @SC90106 08507000
         L     7,RCVPKL              Length of data read                08507500
         LM    14,15,TINTOT  Update recv count                 @SC86295 08508000
         ALR   15,7                                            @SC86295 08508500
         BC    12,*+8                                          @SC88092 08509000
         AL    14,F1                                           @SC86295 08509500
         STM   14,15,TINTOT  Save new count                    @SC86295 08510000
         L     8,APKT        Point to PKT                      @SC86190 08510500
         C     7,F2          Watch for XON-XOFF pairs          @SC90106 08511000
         BNE   *+14                                            @SC90106 08511500
          CLC  0(2,8),=AL1(XON,XOFF)                           @SC90106 08512000
          BE   RPKRED        Ignore pure flow-control "packet" @SC90106 08512500
         MVI   RTYPE,AT      In case of time-out               @SC87012 08513000
         C     7,F1          Time-out signal is ASCII T        @SC87012 08513500
         BNE   RPKSET                                          @SC90106 08514000
         CLI   0(8),XOFF                                       @SC90106 08514500
         BE    RPKRED        Spurious flow-control "packet"    @SC90106 08515000
         CLI   0(8),AT                                         @SC87012 08515500
         BE    RTRN          Yes, timed out                    @SC87012 08516000
RPKSET   DS    0H                                              @SC90106 08516500
         AR    7,8           Point past last char                       08517000
         MVI   RPKERN,ERRSOH No start-of-packet found          @SC89219 08517500
         MVC   RMARKDT,RMARK Copy packet character             @SC93173 08518000
         CLI   RMARKDT,ABL   Is it a control?                  @SC93173 08518500
         BL    *+8                                             @SC93173 08519000
          MVI  RMARKDT,0     Yes, don't check for it in data   @SC93173 08519500
RPKBEG   SR    3,3                   Use this for IC's                  08520000
         L     14,ARPKT      Point to recv buffer              @SC89065 08520500
RPKLOOP  CLC   RMARK,0(8)                                               08521000
         LA    8,1(8)        Try next character                @SC86135 08521500
         BE    RPKSOH                Go if a Control-A                  08522000
         CR    8,7                   Are we within the received pkt?    08522500
         BL    RPKLOOP               Yes, keep on looking for SOH       08523000
         B     RPKERR                                          @SC89219 08523500
*                                                                       08524000
RPKSOH   LA    9,4(14)       Skip over usual header            @SC86295 08524500
         MVC   1(3,14),0(8)  Copy usual header to RCVPKT       @SC86295 08525000
         MVI   RPKERN,ERRBPC SOH found - cksm may be bad       @SC89219 08525500
         UNCHR 3,0(8)                Length                             08526000
         BM    RPKBEG        Invalid length, try again         @SC86153 08526500
         LA    5,ABL(3)              Chksum accumulator                 08527000
         LR    4,3                   Keep length to compute DATA len    08527500
         LA    15,0(3,8)             pkt len + beg                      08528000
         CR    15,7                  Is it within received pkt?         08528500
         BNL   RPKBEG                too long, look for another SOH     08529000
         IC    3,2(8)        Pick up packet type               @SC86153 08529500
         STC   3,RTYPE       Save value here                   @SC86153 08530000
         NI    RTYPE,X'7F'   Assure conventional ASCII char    @SC88074 08530500
         AR    5,3           Add to checksum                   @SC86153 08531000
         BCTR  4,0                   -1 for Seq #                       08531500
         BCTR  4,0                   -1 for Type                        08532000
         UNCHR 3,1(8)        Pick up packet number             @SC86153 08532500
         BM    RPKBEG        Invalid char                      @SC86153 08533000
         LA    5,ABL(3,5)            Add to checksum                    08533500
         STC   3,RSN         Received packet number            @SC86135 08534000
         LA    8,3(8)        Go to putative data               @SC86153 08534500
         CLI   1(14),ABL     Is this an extended pkt?          @SC86295 08535000
         BNE   RPKEXT2       No                                @TB86196 08535500
         LA    15,3(8)       Past LENX1,LENX2,HCHECK           @TB86196 08536000
         CR    15,7          Is it within rcvd pkt?            @TB86196 08536500
         BNL   RPKBEG        Too long, try for another SOH     @TB86196 08537000
         MVC   4(3,14),0(8)  Copy extended pkt hdr             @SC86295 08537500
         UNCHR 1,0(8)        Pick up LENX1 byte                @TB86196 08538000
         LA    5,ABL(1,5)    Add to check                      @SC86202 08538500
         MH    1,XLFCT+2     High digit of size                @SC86202 08539000
         UNCHR 3,1(8)        Pick up LENX2 byte                @TB86196 08539500
         LA    5,ABL(3,5)    Add to chksum                     @SC86202 08540000
         AR    1,3           Total extended pkt size           @TB86196 08540500
         UNCHR 3,2(8)        Pick up HCHECK byte               @TB86196 08541000
         LR    6,5           Keep chksum copy here             @TB86196 08541500
         SRL   6,6           High 2 bits of total              @TB86196 08542000
         N     6,F3          Get just 2 bits                   @SC86295 08542500
         AR    6,5           Add the two values                @TB86196 08543000
         N     6,MOD64       Get low order 6 bits              @TB86196 08543500
         CR    6,3           Chk computed vs received          @TB86196 08544000
         BNE   RPKBEG        Err if chksums mismatch           @SC89219 08544500
         LA    5,ABL(3,5)    Add HCHECK to chksum              @SC86202 08545000
         LA    8,3(8)        Update input+output ptrs          @SC86202 08545500
         LA    9,3(9)        Past LX1,LX2,HCHECK               @SC86202 08546000
         LR    4,1           Save length of data+check         @SC86202 08546500
         AR    1,8           Expected end of packet            @SC86202 08547000
         CR    1,7           Is it within pkt?                 @SC86202 08547500
         BH    RPKBEG        Too long, chk for SOH             @SC86202 08548000
RPKEXT2  DS    0H                                              @SC86202 08548500
         IC    3,BCTU        Chksum length                     @SC86202 08549000
         SR    4,3           Minus chksum length               @SC86202 08549500
         BM    RPKBEG        Can't have negative data length   @SC86202 08550000
         ST    4,DATL        Save data length                  @SC86202 08550500
         ST    9,ARDATA      Save ptr                          @SC86202 08551000
         LTR   4,4           Any data received?                @SC89219 08551500
         BZ    RPKCHK                Nope                               08552000
RPKCHAR  IC    3,0(8)                Get next data char                 08552500
         STC   3,0(9)                Move it to DATA                    08553000
         AR    5,3                   Add to checksum                    08553500
         CLC   RMARKDT,0(8)  Packet char? (disabled if FULL)   @SC93173 08554000
         BE    RPKBEG        Yes, must be error, start over    @SC93173 08554500
         LA    8,1(8)                Bump input buffer pointer          08555000
         LA    9,1(9)                Bump output buffer pointer         08555500
         BCT   4,RPKCHAR             Decrement amount of input          08556000
RPKCHK   UNCHR 3,0(8)                Get checksum                       08556500
         S     3,BCTOFF      0/1                               @SC92085 08557000
         LR    6,9           CRC calc ends here                @SC86135 08557500
         LR    4,5                   Keep chksum copy here              08558000
         CLI   BCTU,2                                                   08558500
         BE    RPKCHK2               Go if using 2 char chksum          08559000
         BH    RPKCHK3               Three character CRC                08559500
         SRL   5,6                   High 2 bits of total               08560000
         N     5,F3          Get just 2 bits                   @SC86295 08560500
         AR    4,5                   Add the two values                 08561000
         B     RPKCHK1               compare it                         08561500
*                                                                       08562000
RPKCHK3  LA    5,1(14)       Start of data for CRC             @SC86295 08562500
         KCALL CRCCLC        Calculate the CRC                          08563000
         LR    4,15                  Keep computed value here also      08563500
         SRL   15,12                 High 4 bits of high byte           08564000
         CR    15,3                  compare computed and received      08564500
         BNE   RPKBEG        Skip if chksums don't match       @SC89219 08565000
         LA    8,1(,8)       Ok so far, bump input pointer     @SC90285 08565500
         UNCHR 3,0(8)                Get next char of checksum          08566000
         S     3,BCTOFF      0/1                               @SC92085 08566500
RPKCHK2  LR    15,4                  Get back the CRC                   08567000
         SRL   15,6          Next 6 bits of total              @SC86295 08567500
         N     15,MOD64      Get just 6 bits                   @SC86295 08568000
         CR    15,3                  compare computed and received      08568500
         BNE   RPKBEG        Skip if chksums don't match       @SC89219 08569000
         LA    8,1(,8)       Ok so far, bump input pointer     @SC90285 08569500
         UNCHR 3,0(8)                Get checksum                       08570000
         S     3,BCTOFF      0/1                               @SC92085 08570500
RPKCHK1  N     4,MOD64               Get low order 6 bits               08571000
         CR    4,3                   Compare computed and received      08571500
         BE    RPKRET                skip if chksums match              08572000
         TM    FL1,TSTF                                        @SC86295 08572500
         BO    RPKRET        Just testing, anything goes       @SC86295 08573000
         CR    8,7                                             @BS86001 08573500
         BL    RPKBEG        More stuff, see if it's a packet  @BS86001 08574000
RPKERR   DS    0H                                              @SC89219 08574500
         LA    8,STOPBUF                                       @SC88074 08575000
         L     7,RCVPKL                                        @SC88074 08575500
         AR    7,8           Ptr to packet end in work area    @SC88074 08576000
         CLC   =X'114040',0(8)  SBA sequence prepended?        @SC91256 08576500
         BNE   *+8           No, normal                        @SC91256 08577000
          A    8,F3          Yes, ignore it                    @SC91256 08577500
         CLC   RMARK,0(8)                                      @SC88074 08578000
         BE    RPKNAK        Assume bad packet if SOH present  @SC88074 08578500
         BCTR  7,0                                             @SC88074 08579000
         IC    0,0(,7)       Look at last character            @SC91032 08579500
         N     0,LOBIT       (but only 7 bits)                 @SC91032 08580000
         CLM   0,1,REOL      Is it an EOL?                     @SC91032 08580500
         BNE   *+6                                             @SC88074 08581000
          BCTR 7,0           Don't count closing EOL           @SC88074 08581500
         CLC   =C'STOP',0(8)                                   @SC91032 08582000
         BE    RPKSTUP       Seems to be EBCDIC already (3270) @SC91032 08582500
         CLC   =C'stop',0(8)                                   @SC91032 08583000
         BE    RPKSTUP       Seems to be EBCDIC already (3270) @SC91032 08583500
         TR    STOPBUF,ATOED                                   @SC89301 08584000
RPKSTUP  DS    0H                                              @SC91032 08584500
         TR    STOPBUF,UPCASE                                  @SC88074 08585000
         CLI   0(8),C'S'                                       @SC88074 08585500
         BE    *+8                                             @SC88074 08586000
          LA   8,1(8)        Allow one extra character in front@SC88074 08586500
         S     7,F3          Back len(STOP) - 1                @SC88074 08587000
         CR    7,8                                             @SC88074 08587500
         BNE   RPKNAK        Doesn't match exactly             @SC88074 08588000
         CLC   =C'STOP',0(8)                                   @SC88074 08588500
         BE    RPKSTP        Exact match                       @SC88074 08589000
RPKNAK   MVI   RTYPE,AQ              Return a Q pkt                     08589500
RPKRET   RET                                                            08590000
*                                                              @SC88074 08590500
RPKSTP   OI    FL3,ZPRO      Indicate stopping protocol mode   @SC88074 08591000
         MVI   ERRNUM,ERRTRC Transfer cancelled, if any        @SC88074 08591500
         MVI   REASON,0      Reason is "unknown"               @SC92031 08592000
         MVI   RTYPE,X'FF'   Special packet type for quitting  @SC88074 08592500
         RET                                                   @SC88074 08593000
         LOCALS ,                                              @SC86295 08593500
RMARKDT  DS    C             Packet char or NULL for scanning  @SC93173 08594000
RPACK    EXIT                                                           08594500
         TITLE 'CRCCLC Routine - calculates CRC'                        08595000
* Calculate the CRC and return it in R15.  Expects R5 to point to the   08595500
* start of the data on which the CRC is calculated, and R6 to the       08596000
* char after the last one.                                              08596500
*                                                                       08597000
CRCCLC   ENTER                                                          08597500
         SR    15,15                 Initial CRC value is zero          08598000
CRCLUP   IC    4,0(5)        Get the next character            @SC86295 08598500
         XR    4,15          XOR char and CRC low byte         @SC86295 08599000
         LR    7,4                   same as above                      08599500
         SRL   7,4                   High 4 bits of low byte            08600000
         N     4,F                   Low 4 bits of low byte             08600500
         N     7,F           High 4 bits of low byte           @SC86295 08601000
         ALR   4,4                   Double to get index into table     08601500
         LH    4,CRCTAB2(4)          CRC for low 4 bits                 08602000
         ALR   7,7                   Double to get another index        08602500
         LH    7,CRCTAB1(7)          CRC for high 4 bits                08603000
         XR    4,7                   XOR the two                        08603500
         SRL   15,8                  Shift prev CRC 8 bits to right     08604000
         XR    15,4                  XOR current char's CRC into it     08604500
         N     15,=XL4'FFFF' Drop negative stuff               @SC86295 08605000
         LA    5,1(5)                Bump input pointer                 08605500
         CR    5,6                   Did we reach the end?              08606000
         BL    CRCLUP                Nope, loop for whole pkt           08606500
CRCRET   RET                                                            08607000
* Table to use for CRC calculation                                      08607500
CRCTAB1  HTBL  00,00,10,81,21,02,31,83,42,04,52,85,63,06,73,87 @SC89268 08608000
         HTBL  84,08,94,89,A5,0A,B5,8B,C6,0C,D6,8D,E7,0E,F7,8F @SC89268 08608500
*                                                                       08609000
CRCTAB2  HTBL  00,00,11,89,23,12,32,9B,46,24,57,AD,65,36,74,BF @SC89268 08609500
         HTBL  8C,48,9D,C1,AF,5A,BE,D3,CA,6C,DB,E5,E9,7E,F8,F7 @SC89268 08610000
*                                                                       08610500
         LOCALS ,                                              @SC86295 08611000
CRCCLC   EXIT                                                           08611500
         TITLE 'RIO Routine - Read packet into RCVPKT'                  08612000
RIO      ENTER                                                          08612500
         MVI   SIORIO,C'R'   Set type                          @SC86316 08613000
         L     7,APKT        Ptr to data                       @SC86316 08613500
         L     15,RIOC       Previous read count               @SC86295 08614000
         MVI   RIOC,X'80'    Nothing left in read buffer       @SC86295 08614500
RIOSM0   ICM   0,15,SIMPTR   See if replaying...               @SC91312 08615000
         BNZ   RIOSIM        Read from canned file             @SC91312 08615500
         BAL   14,TTYCHK                                       @SC92030 08616000
          B    RIOTTY        Go if not transparent             @SC92030 08616500
         SR    4,4           Don't translate for STOP test     @SC91032 08617000
         LA    5,OFF80       Turn off all X'80' bits           @SC86316 08617500
         TM    RPRTY,DAT8    Unless 8-bit line                 @SC88288 08618000
         BZ    *+6           Not 8-bit                         @SC86316 08618500
         SR    5,5           Yes, use all bits                 @SC86316 08619000
         LTR   15,15         Any previous?                     @SC86295 08619500
         BNM   RIOCOM        Yes, use it                       @SC86295 08620000
         LA    0,4           Write                             @SC86295 08620500
         KCALL SCRNIO,S1XOPL,E=(RIOER,M) Send a prompt         @SC86295 08621000
RIOS1R   DS    0H                                              @SC87215 08621500
         LA    0,5           Read                              @SC86295 08622000
         KCALL SCRNIO,RIOPTRS,E=(RIOER,M) perform read         @SC90173 08622500
         BP    RIOCOM                                          @SC86355 08623000
RIOER    MVI   ERRNUM,ERRTIE Terminal I/O error                @SC86156 08623500
         B     RTRN1         Error, return to caller           @SC86295 08624000
*                                                                       08624500
RIOSIM   L     5,RIOPTRS+4                                     @SC91312 08625000
         READF SIMPTR,BUFFER=(7),BSIZE=(5),E=RIOSMX            @SC91312 08625500
         LR    15,0          Save length                       @SC91312 08626000
         SR    5,5           Assume no translation             @SC91312 08626500
         CLC   =C'S:',0(7)                                     @SC91312 08627000
         BE    RIOSIM                                          @SC91312 08627500
         CLC   =C'R:',0(7)                                     @SC91312 08628000
         BNE   *+8                                             @SC91312 08628500
          L    5,AEPTRS+4    It's in EBCDIC, translate it      @SC92352 08629000
         LR    4,5                                             @SC91312 08629500
         B     RIOCOM                                          @SC91312 08630000
*                                                                       08630500
RIOERR   CLI   WRRD,0        Expecting a reply?                @SC91281 08631000
         BNE   RIOER         Yes, report the error             @SC91281 08631500
         B     SIOGOOD       No, ignore it                     @SC91281 08632000
*                                                                       08632500
RIOTTY   L     5,AEPTRS+4    Translate to ASCII (ETOA/TETOA)   @SC92352 08633000
         CLI   TRMTP,C'F'    Full-screen?                      @SC92030 08633500
         BE    RIOTTY1       Yes, avoid override table         @SC92030 08634000
         ICM   6,15,KSYSETOA Possible overriding table         @SC88302 08634500
         BZ    *+6                                             @SC88302 08635000
          LR   5,6           Use it instead                    @SC88302 08635500
RIOTTY1  DS    0H                                              @SC92030 08636000
         LR    4,5           Use same translation for STOP     @SC91032 08636500
         LTR   15,15         Any previous data?                @SC86295 08637000
         BNM   RIOCOM        Yes, use it                       @SC86295 08637500
         LA    0,5           No, read some now                 @SC86295 08638000
         KCALL TERMIO,RIOPTRS,E=(RIOER,M) perform read         @SC90173 08638500
RIOCOM   LR    6,15          Copy byte count                   @SC86295 08639000
         ST    6,RCVPKL      Save                                       08639500
         MVC   STOPBUF,0(7)  Copy to work area, in case STOP   @SC91032 08640000
         LTR   4,4           Any translation for STOP test?    @SC91032 08640500
         BZ    *+10          Don't translate it                @SC91032 08641000
          TR   STOPBUF,0(4)  Do the translate                  @SC91032 08641500
         BAL   9,RIORAW      Log raw data                      @SC86316 08642000
         LR    2,7                                             @SC86316 08642500
         LR    3,6           Length                            @SC86202 08643000
         LTR   15,5          Copy table ptr                    @SC86316 08643500
         BZ    *+8           Don't translate after all         @SC86316 08644000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08644500
         BAL   9,RIOLOG      Write to log                      @SC86190 08645000
         B     RTRN0                                           @SC86295 08645500
*  Write record to log buffer, R7->data, R6=length             @SC87286 08646000
*  Clobbers R0,R1,R2,R3,R8,R14,R15, return to (R9)             @SC87286 08646500
RIORAW   SR    3,3           Write raw data                    @SC86316 08647000
         B     RIOLG1                                          @SC86316 08647500
RIOLOG   L     3,AEPTRS      Write data in EBCDIC (ATOE/TATOE) @SC92352 08648000
RIOLG1   SR    8,8           Assume raw not wanted             @SC88168 08648500
         TM    DBGFLG,DBGRW                                    @SC88168 08649000
         BO    *+8                                             @SC88168 08649500
         L     8,AEPTRS      Raw wanted                        @SC92352 08650000
         CR    3,8           Correct type (raw/EBCDIC)?        @SC88168 08650500
         BNER  9             No, skip this one                 @SC86316 08651000
         TM    FL1,DEBUG                                       @SC86316 08651500
         BZR   9             Skip if no debugging              @SC86190 08652000
         LA    8,2(6)        Two extra for R:, etc.            @SC87286 08652500
         L     2,LOGBUF      LOG buffer                        @SC86316 08653000
         MVC   0(1,2),SIORIO Indicate log type                 @SC86316 08653500
         LA    2,2(2)        Skip over prefix                  @SC86190 08654000
         LR    0,2           Buffer ptr                        @SC86190 08654500
         LR    1,8           Data length                       @SC86316 08655000
         LR    14,7          Data ptr                          @SC86316 08655500
         LR    15,8                                            @SC86316 08656000
         MVCL  0,14          Copy to log buffer                @SC86316 08656500
         LTR   15,3          Check if translation needed       @SC86316 08657000
         BZ    *+10          No                                @SC86316 08657500
         LR    3,8           Data length                       @SC86316 08658000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08658500
         WRITF LOGPTR,BSIZE=(8),E=RIOLQU                       @SC87034 08659000
         TM    DBGFLG,DBGSV  SAVE requested?                   @SC88168 08659500
         BZR   9             No, skip closing log file         @SC88168 08660000
         SAVEF LOGPTR        Update disk directory             @SC88168 08660500
         BR    9             Done                              @SC86190 08661000
RIOLQU   CLOSF LOGPTR        Turn off DEBUG, it fails          @SC86355 08661500
         NI    FL1,255-DEBUG                                   @SC86355 08662000
         BR    9                                               @SC86355 08662500
*                                                                       08663000
RIOSMX   CLOSF SIMPTR        Turn off replay -- it failed      @SC91312 08663500
         B     RIOSM0        Try again for real                @SC91312 08664000
         TITLE 'SIO Routine - Send packet in SNDPKT'                    08664500
SIO      ENTER ALT                                             @SC86190 08665000
         MVI   SIORIO,C'S'   Set type                          @SC86316 08665500
         MVI   RTYPE,0       Clear previous received packet    @SC88074 08666000
         MVI   RIOC,X'80'    Set no read count                 @SC86295 08666500
         L     6,SNDPKL              Length of SNDPKT to be sent        08667000
         TM    FL4,NPS       Non-protocol?                     @SC86239 08667500
         BO    SIOPLEN       Yes, no handshake at all          @LP87272 08668000
         CLI   WRRD,0        Only writing?                     @LP87272 08668500
*        BE    SIOPLEN       Yes, handshake done next Read     @LP87272 08669000
         CLI   S1HND,0       Handshake desired at all?         @SC87275 08669500
         BE    SIOPLEN       No, skip it                       @SC87275 08670000
         LA    6,1(6)        Allow for handshake character     @LP87272 08670500
SIOPLEN  DS    0H                                              @SC86239 08671000
         L     7,ASPKT       Ptr to send data                  @SC86316 08671500
         BAL   9,RIOLOG      Write to log                      @SC86190 08672000
         L     2,SIOPTRS     Final output buffer               @SC90173 08672500
         LR    1,2           Save start                        @SC86154 08673000
         SR    3,3                                             @SC86154 08673500
         TM    FL4,NPS       Non-protocol?                     @SC86191 08674000
         BO    *+8           Yes, skip padding                 @SC86191 08674500
         IC    3,SPADN       Pad count                         @SC86154 08675000
         LA    15,7(3,6)     Length of pad+data                @SC92030 08675500
         STCM  15,3,AEABUFL  Set length of OEM data struct fld @SC90173 08676000
         LM    4,5,WRCMD     Adr,len of I/O command stuff      @SC90173 08676500
         AR    3,5           Total padding + Series/1          @SC86154 08677000
         LA    9,0(5,2)      Save start of ASCII stuff         @SC88288 08677500
         ICM   5,8,SPADC     Get padding character             @SC86154 08678000
         MVCL  2,4           Copy to buffer with padding       @SC86154 08678500
         LR    3,6           Packet length                     @SC86154 08679000
         LR    5,6                                             @SC86154 08679500
         LR    4,7           Ptr to packet                     @SC86316 08680000
         MVCL  2,4           Copy packet to buffer             @SC86154 08680500
         LR    3,2           Copy end of transmission          @SC90173 08681000
         SR    2,1           Total length                      @SC90173 08681500
         ST    2,SIOPTRS+4   Store len in CCW                  @SC90173 08682000
         LR    2,9           Start of ASCII stuff              @SC88288 08682500
         SR    3,2           Length                            @SC88288 08683000
         BAL   14,TTYCHK                                       @SC92030 08683500
          B    SIOTTY        Go if not transparent             @SC92030 08684000
         LA    15,ON80       Set high bits                     @SC88288 08684500
         TM    SPRTY,DAT8    Unless 8-bit line                 @SC88288 08685000
         BO    *+8           Yes, 8-bit downloading            @SC88288 08685500
          BAL  14,TRANSLAT                                     @SC88288 08686000
         L     4,=A(SCRNIO)  I/O routine for fullscreen        @SC89215 08686500
SIOGO    LM    7,8,SIOPTRS                                     @SC90173 08687000
         LM    14,15,TOUTOT  Update send count                 @SC88006 08687500
         ALR   15,8                                            @SC88006 08688000
         BC    12,*+8                                          @SC88092 08688500
         AL    14,F1                                           @SC88006 08689000
         STM   14,15,TOUTOT  Save new count                    @SC88006 08689500
         LR    6,8           Set up for log routine            @SC88168 08690000
         BAL   9,RIORAW      Log it                            @SC86316 08690500
         NI    FL5,255-NAK0  Something sent now                @SC90037 08691000
         ICM   0,15,SIMPTR                                     @SC91312 08691500
         BNZ   RTRN0         Replaying, suppress packet I/O    @SC91312 08692000
         LA    0,4           Write                             @SC86295 08692500
         KCALL (4),SIOPTRS,E=(RIOER,M)                         @SC90173 08693000
         CLI   TRMTP,C'S'    S/1?                              @SC90173 08693500
         BE    *+12                                            @SC90173 08694000
          CLI  WRRD,0        Only writing?                     @SC90173 08694500
          BE   SIOGOOD       Yes, expect no answer             @SC90173 08695000
         LA    0,5                                             @SC86295 08695500
         KCALL (4),RIOPTRS,E=(RIOER,M)  Read it now            @SC90173 08696000
         CLI   WRRD,0        Write/read?                       @SC86301 08696500
         BE    SIOGOOD       No, ignore bare status            @SC86301 08697000
         LTR   15,15                                           @TB87009 08697500
         BP    SIOCOM                                          @TB87009 08698000
         CLI   TRMTP,C'S'    S/1?                              @SC90173 08698500
         BNE   SIOCOM        No problem                        @SC90173 08699000
* If only 3 bytes (AID and cursor) come in, VTAM has caused    @TB87009 08699500
* the S/1 to discard its transparent data. Fill the screen and @TB87009 08700000
* read it back in protocol conversion mode to cause VTAM       @TB87009 08700500
* to put up a longer READ MODIFIED CCW at its next read.       @TB87009 08701000
         LA    0,6           Message (Leave Transparent Mode)  @TB87009 08701500
         KCALL SCRNIO,SIORTPL,E=(SIORTY,M)                     @TB87009 08702000
         LA    0,5                                             @TB87009 08702500
         KCALL SCRNIO,RIOPTRS,E=(RIOER,M) Rdmod to prime VTAM. @SC90173 08703000
         L     14,RIOPTRS    Input buffer                      @SC91039 08703500
         CLC   SIOMSGT,3(14) Is it what we just wrote?         @SC91039 08704000
         BNE   SIOCOM        No, maybe it's real               @SC91039 08704500
SIORTY   SR    15,15         No data actually seen.            @TB87009 08705000
SIOCOM   DS    0H                                              @TB87009 08705500
         ST    15,RIOC               save residual byte count           08706000
SIOGOOD  DS    0H                                              @SC88100 08706500
         B     RTRN0                                           @SC86295 08707000
*                                                                       08707500
SIOTTY   DS    0H                                              @SC90173 08708000
         CLI   TRMTP,C'F'    Full-screen?                      @SC92030 08708500
         BE    SIOTTY1       Yes, avoid override table         @SC92030 08709000
         ICM   15,15,KSYSATOE Possible overriding table        @SC88302 08709500
         BNZ   SIOTRNT                                         @SC88302 08710000
SIOTTY1  DS    0H                                              @SC92030 08710500
         L     15,AEPTRS     Send in EBCDIC (ATOE/TATOE)       @SC92352 08711000
SIOTRNT  DS    0H                                              @SC88302 08711500
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08712000
         L     4,=A(TERMIO)  I/O routine for TTY               @SC89215 08712500
         B     SIOGO         Now do it                         @SC87275 08713000
*                                                              @TB87009 08713500
SIORTPL  DC    A(SIOMSGXX,SIOMSL)                              @TB87009 08714000
* Greetings for ERROR mode                                     @TB87009 08714500
SIOMSGXX DC    &S1CMD,AL1(SBA),X'4040'                         @SC90264 08715000
SIOMSGT  DC    C'&VTAMERR'                                     @TB87009 08715500
         DC    AL1(RTA),X'4040',C' '  Blanks to end of screen  @SC88139 08716000
SIOMSL   EQU   *-SIOMSGXX                                      @TB87009 08716500
* For setting high bits...                                     @SC88288 08717000
ON80     DC    X'808182838485868788898A8B8C8D8E8F'             @SC88288 08717500
         DC    X'909192939495969798999A9B9C9D9E9F'             @SC88288 08718000
         DC    X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'             @SC88288 08718500
         DC    X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'             @SC88288 08719000
         DC    X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'             @SC88288 08719500
         DC    X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'             @SC88288 08720000
         DC    X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'             @SC88288 08720500
         DC    X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'             @SC88288 08721000
         DC    X'808182838485868788898A8B8C8D8E8F'             @SC88288 08721500
         DC    X'909192939495969798999A9B9C9D9E9F'             @SC88288 08722000
         DC    X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'             @SC88288 08722500
         DC    X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'             @SC88288 08723000
         DC    X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'             @SC88288 08723500
         DC    X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'             @SC88288 08724000
         DC    X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'             @SC88288 08724500
         DC    X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'             @SC88288 08725000
         LOCALS ,                                              @SC86295 08725500
SIORIO   DS    C             Operation code                    @SC86316 08726000
SIO      EXIT                                                           08726500
         TITLE 'INTINI Routine - Initialize console for protocol'       08727000
* If R1 is 0, reset the traps unless in Server mode.                    08727500
* If R1 is positive, set up console traps for protocol:                 08728000
*  1 for SERVER, 2 for SEND, 3 for RECEIVE, 4 for short msg    @SC86184 08728500
* R15 = 0 on return if ok                                               08729000
*                                                                       08729500
INTINI   ENTER                                                          08730000
         TM    FL2,SRV                                                  08730500
         BO    INTINIR               Return if server running           08731000
         LTR   3,1           Call type: 0 or 1-5               @HF86232 08731500
         BZ    INTINICL              If R1 is 0 clear traps             08732000
         MVI   WRRD,5        Reset w/r flag                    @SC91352 08732500
         MVI   AEAFLG,0      ditto for AEA                     @SC91352 08733000
         CLI   TRMTP,C'N'    Controller = NONE?                @SC90173 08733500
         BE    INTINERR      If so, give up right away         @SC90173 08734000
         CLI   TRMTP,C'F'    Full-screen non-transparent?      @SC92030 08734500
         BNE   *+12          No, we're ok                      @SC92030 08735000
          CLI  SMARK,ABL     Yes, see if printable SOP         @SC92030 08735500
          BL   INTINBAD      No, give up right away            @SC92030 08736000
         OI    FL2,PROTO     Line open for transfer            @SC86295 08736500
         MVI   RTYPE,AN      No packet received yet            @SC89263 08737000
         ICM   5,15,LCLDLY   No delay?                         @HF86232 08737500
         BNZ   INTINIDL                                        @HF86232 08738000
         LA    1,5           Yes, use no message               @HF86232 08738500
INTINIDL C     1,F5          No delay or non-protocol send?    @HF86232 08739000
         BE    INTINIMS      Yes                               @HF86232 08739500
         BCT   5,INTINIMS    Short delay?                      @HF86232 08740000
         LA    1,4           Yes, use short message anyway     @SC86184 08740500
INTINIMS SLL   1,3           8-byte indexing                   @HF86232 08741000
         LA    5,INTCCWSR-8(1)  Get ptr to correct CCW         @SC86184 08741500
         MVC   SVHND,S1HND   Save handshake character          @SC87343 08742000
         KCALL SETMSG,2,E=INTINERR Prepare line for transfer   @SC87300 08742500
         LA    0,2                                             @SC87309 08743000
         SR    0,3                                             @SC87309 08743500
         LPR   0,0           Get ABS(code-2)                   @SC87309 08744000
         BCT   0,*+8         Test for Serve or Rec codes (1,3) @SC87309 08744500
         OI    FL5,NAK0      Send NAK during retry, if any     @SC90037 08745000
         MVI   RIOC,X'80'    Clr any prev byte count           @SC86295 08745500
         LA    6,S1DATA      Series/1 stuff                    @SC90173 08746000
         LA    7,S1ORDL      Length of Series/1 stuff          @SC90173 08746500
         LA    8,3           Expect AID + cursor adr           @SC90173 08747000
         CLI   TRMTP,C'S'                                      @SC90173 08747500
         BE    INTSSIOC                                        @SC90173 08748000
         LA    6,GRDATA      Graphics stuff                    @SC90173 08748500
         LA    7,GRDL                                          @SC90173 08749000
         CLI   TRMTP,C'G'                                      @SC90173 08749500
         BE    INTSSIOC                                        @SC90173 08750000
         LA    6,AEADAT      AEA stuff                         @SC90173 08750500
         LA    7,AEAL                                          @SC90173 08751000
         LA    8,16          Expect AID + WSF stuff            @SC90173 08751500
         CLI   TRMTP,C'A'                                      @SC90173 08752000
         BE    INTSSIOC                                        @SC90173 08752500
         SR    7,7           Nothing for TTY-mode              @SC90173 08753000
         SR    8,8                                             @SC90173 08753500
         CLI   TRMTP,C'F'                                      @SC92030 08754000
         BNE   INTSSIOC                                        @SC92030 08754500
         LA    8,FSRDOF      Depends on system                 @SC92030 08755000
INTSSIOC STM   6,8,WRCMD     Save ptrs for fullscreen I/O cmds @SC90173 08755500
         A     8,RIOPTRS     Get ptr to start of data          @SC90173 08756000
         ST    8,APKT                                          @SC90173 08756500
         BAL   14,TTYCHK                                       @SC92030 08757000
          B    INTINITY      Go if TTY                         @SC92030 08757500
         LA    0,1           Open screen                       @SC86295 08758000
         KCALL SCRNIO                                          @SC86295 08758500
         LA    0,6           Simple write                      @SC86316 08759000
         KCALL SCRNIO,(5),E=(INTINIR,M)  Message               @SC86295 08759500
         C     3,F2          Was this SEND?                    @SC86184 08760000
         BE    INTINIR               SEND does sleep anyway             08760500
         ICM   0,15,LCLDLY   See if speed wanted               @SC87253 08761000
         BZ    INTINIP       Yes, no greetings anyway          @SC87309 08761500
         LA    0,1           Wait 1 sec                        @SC86295 08762000
         KCALL SUPFNC,9      This seems essential              @SC86295 08762500
INTINIP  DS    0H                                              @SC90173 08763000
         B     INTINIR                                                  08763500
*                                                                       08764000
INTINITY L     1,0(5)        Text address from ccw             @SC86184 08764500
         LH    4,6(5)        Get total length                  @SC86184 08765000
         LA    3,INTPRL(1)   Skip over WCC and SBA             @SC86184 08765500
         SH    4,*-2          and deduct that from length      @SC86184 08766000
         SR    0,0                                             @SC92030 08766500
         KCALL SCRNIO        Clear screen if FULLSCREEN        @SC92030 08767000
         LA    6,80                                            @SC92161 08767500
INTINIT1 CR    4,6                                             @SC92161 08768000
         BNH   INTINIT2      Just one line left                @SC92161 08768500
         WTEXT (3),(6)       Write out one line                @SC92161 08769000
         AR    3,6           Point to next line                @SC92161 08769500
         SR    4,6           Adjust length remaining           @SC92161 08770000
         B     INTINIT1                                        @SC92161 08770500
INTINIT2 WTEXT (3),(4)                                         @SC86184 08771000
         WTEXT =X'24',1      SNA Inhibit Presentation          @2L90270 08771500
         LA    0,1                                             @SC86295 08772000
         KCALL TERMIO        Open line                         @SC86295 08772500
         B     INTINIR                                                  08773000
*                                                                       08773500
INTINICL NI    FL3,255-ZPRO  Now stopping protocol mode        @SC88074 08774000
         TM    FL2,PROTO     Was line open?                    @SC88074 08774500
         BZ    INTINIR       No                                @SC86295 08775000
         CLI   TRMTP,C'A'    Special treatment of AEA here     @SC91352 08775500
         BNE   INTINICM      Not needed                        @SC91352 08776000
         CLI   AEAFLG,X'80'  Transparency suppressed yet?      @SC91352 08776500
         BE    INTINICM      Yes, all set                      @SC91352 08777000
         MVI   AEAFLG,X'80'  No, must do it now                @SC91352 08777500
         MVI   WRRD,0        (just for completeness)           @SC91352 08778000
         MVI   WRCMD+7,AEADOL Set up plist for WSF             @SC91352 08778500
         LA    0,4           Write                             @SC91352 08779000
         KCALL SCRNIO,WRCMD  Send just the D/O field           @SC91352 08779500
INTINICM DS    0H                                              @SC91352 08780000
         LA    0,2                                             @SC86295 08780500
         L     15,=A(SCRNIO)                                   @SC89215 08781000
         BAL   14,TTYCHK                                       @SC92030 08781500
          L    15,=A(TERMIO) TTY mode                          @SC92030 08782000
INTINIK  KCALL (15)          Release line                      @SC87300 08782500
         KCALL SETMSG,3                                        @SC86316 08783000
         MVC   S1HND,SVHND   Restore handshake character       @SC87343 08783500
         NI    FL2,255-PROTO End protocol mode                 @SC88035 08784000
         CLI   TRMTP,C'T'                                      @2L90270 08784500
         BE    *+12          Go if TTY                         @2L90270 08785000
          CLI  TRMTP,C'V'                                      @2L90270 08785500
          BNE  INTINIR       Go if VTAM TTY                    @2L90270 08786000
         WTEXT =X'14',1      SNA Enable Presentation           @2L90270 08786500
INTINIR  B     RTRN0                                           @SC87300 08787000
*                                                                       08787500
INTINBAD WTEXT '&UNPRSOP'                                      @SC92030 08788000
INTINERR NI    FL2,255-PROTO Turn off protocol mode            @SC87300 08788500
         MVI   ERRNUM,ERRCOM Bad comm line                     @SC87300 08789000
         B     RTRN1                                           @SC87300 08789500
*                                                                       08790000
         DS    0D                                                       08790500
INTCCWSR DC    A(INTMSGSR,INTPRL+80+80+80)                     @SC92161 08791000
INTCCWSN DC    A(INTMSGSN,INTPRL+80+80+80)                     @SC92161 08791500
INTCCWRC DC    A(INTMSGRC,INTPRL+80+80+80)                     @SC92161 08792000
INTCCWQU DC    A(INTMSGQU,INTQL)                               @SC86295 08792500
INTCCWNL DC    A(INTMSGQU,INTPRL+1)    Send the blank, too     @SC92072 08793000
* Short greetings                                              @SC86184 08793500
INTMSGQU DC    &S1CMD,AL1(SBA),X'4040'                         @SC90264 08794000
INTPRL   EQU   *-INTMSGQU    Length of prefix                  @SC86295 08794500
INTMSGQ2 DC    C' Kermit-&KSYS....'                            @SC92072 08795000
INTQL    EQU   *-INTMSGQU                                      @SC86184 08795500
* Greetings for RECEIVE mode                                            08796000
INTMSGRC DC    &S1CMD,AL1(SBA),X'4040'                         @SC90264 08796500
         DC    CL80'Kermit-&KSYS &READYR'                      @SC92300 08797000
         DC    CL80'&PLSESCP.&TOSEND'                          @SC92300 08797500
 DC CL80'KERMIT READY TO RECEIVE...'                           @SC92161 08798000
* Greetings for SEND mode                                               08798500
INTMSGSN DC    &S1CMD,AL1(SBA),X'4040'                         @SC90264 08799000
         DC    CL80'Kermit-&KSYS &READYS'                      @SC92300 08799500
         DC    CL80'&PLSESCP.&TORECV'                          @SC92300 08800000
 DC CL80'KERMIT READY TO SEND...'                              @SC92161 08800500
* Greetings for SERVER mode                                             08801000
INTMSGSR DC    &S1CMD,AL1(SBA),X'4040'                         @SC90264 08801500
         DC    CL80'Kermit-&KSYS &READYSR &PLSESCP..'          @SC92300 08802000
         DC    CL80'&ENDSRV &AAAABYE &ZZZZOR &AAAAFIN..'       @SC92300 08802500
 DC CL80'KERMIT READY TO SERVE...'                             @SC92161 08803000
*                                                                       08803500
         LOCALS ,                                              @SC86295 08804000
INTINI   EXIT                                                           08804500
         TITLE 'INBUF Routine - read next disk record into WBUF'        08805000
* Exit: R15=0 if ok, -1 if EOF, 1 if read error (ERRNUM set)            08805500
INBUF    ENTER                                                          08806000
         WEAKX KJETOA                                          @SC91325 08806500
         TM    FL1,EOF                                                  08807000
         BO    RTRNM1        Go if hit eof already             @SC86295 08807500
         SR    15,15         In case reading from memory       @SC86158 08808000
         ST    15,RBUFP      Clear read buffer pointer         @SC86158 08808500
         ST    15,RBUFL      Clear read buffer length          @SC86158 08809000
         L     9,RBUF        Read into this buffer             @SC86158 08809500
         TM    FL4,SFM       Source is memory?                 @SC86158 08810000
         BZ    IBFDSK        No, read disk                     @SC86158 08810500
         LM    4,5,TXTPTR    Yes, copy to buffer               @SC86158 08811000
         CR    4,5           Any left?                         @SC86158 08811500
         BNL   IBFEOF        No, quit                          @SC86158 08812000
         XC    CMD,CMD                                         @SC86158 08812500
         MVI   CMD+X'15',1   Set up TRT                        @SC86158 08813000
         MVC   0(256,9),0(4) Copy one line or so               @SC86158 08813500
         LA    1,256(4)      In case no NL                     @SC86158 08814000
         TRT   0(256,4),CMD  Scan for NL                       @SC86158 08814500
         CR    1,5           No X'15'?                         @SC86158 08815000
         BNH   *+6           OK                                @SC86158 08815500
         LR    1,5           Limit is end of data              @SC86158 08816000
         SR    1,4           Length of line                    @SC86158 08816500
         LA    4,1(1,4)                                        @SC86158 08817000
         ST    4,TXTPTR      Update ptr                        @SC86158 08817500
         LR    0,1           Save length                       @SC86158 08818000
         B     IBFXLAT       Go change to ASCII                @SC86158 08818500
IBFDSK   DS    0H                                              @SC86158 08819000
         ICM   1,15,FLNOPTS  Get record counter                @SC89218 08819500
         AL    1,F1                                            @SC89218 08820000
         STCM  1,15,FLNOPTS  Update record counter             @SC89218 08820500
         CLM   1,15,FLNOPTS+4 Passed end?                      @SC89218 08821000
         BH    IBFEOF        Yes, quit now                     @SC89218 08821500
         ICM   2,15,RDWLEN   Special format?                   @SC86151 08822000
         AR    9,2           Space over record descriptor      @SC86151 08822500
         READF FILPTR,BUFFER=(9),E=IBFERR                      @SC87034 08823000
         LM    14,15,DSKTOT  Update disk count                 @SC86295 08823500
         ALR   15,0                                            @SC86295 08824000
         BC    12,*+8                                          @SC88092 08824500
         AL    14,F1                                           @SC86295 08825000
         STM   14,15,DSKTOT  Save new count                    @SC86295 08825500
         LTR   2,2           Special format?                   @SC86151 08826000
         BZ    IBFNRM        No                                @SC86151 08826500
         SR    9,2           Back up to start of buffer        @SC86151 08827000
         STCM  0,3,0(9)      Store length                      @SC86151 08827500
         C     2,F2          Short?                            @SC86262 08828000
         BE    IBFVLEN       Yes                               @SC86262 08828500
         CVD   0,TMPDW       No, use 5-byte ASCII              @SC86262 08829000
         OI    TMPDW+7,15                                      @SC86262 08829500
         UNPK  0(5,9),TMPDW                                    @SC86262 08830000
         TR    0(5,9),ETOAD                                    @SC89301 08830500
IBFVLEN  DS    0H                                              @SC86262 08831000
         AR    0,2                                             @SC86151 08831500
         B     IBFLEN        Must be binary                    @SC86151 08832000
IBFNRM   DS    0H                                              @SC86151 08832500
         TM    FL1,BINF                                                 08833000
         BO    IBFLEN                No trans for binary file           08833500
         ICM   1,15,RMARG    Text file: check margins          @SC87253 08834000
         BZ    IBFCKLM       No right margin specified         @SC87253 08834500
         CR    0,1                                             @SC87253 08835000
         BNH   IBFCKLM       Record is shorter than margin     @SC87253 08835500
         LR    0,1           Truncate record at margin         @SC87253 08836000
IBFCKLM  L     1,LMARG                                         @SC87253 08836500
         S     1,F1                                            @SC87253 08837000
         BNP   IBFXLAT       No left margin, or start in col 1 @SC87253 08837500
         TM    FLNFLGS,FLNCC                                   @SC91116 08838000
         BO    IBFXLAT       Can't use left margin if CC       @SC91116 08838500
         SR    0,1           See if record is long enough      @SC87253 08839000
         BNP   IBFEMPT       Too short, make empty record      @SC87253 08839500
         LR    2,9           Ptr to record                     @SC87253 08840000
         LR    3,0           Shortened length                  @SC87253 08840500
         LA    4,0(1,2)                                        @SC87253 08841000
         LR    5,3                                             @SC87253 08841500
         MVCL  2,4           Eliminate stuff before margin     @SC87253 08842000
IBFXLAT  LA    15,ETOA       Change to ASCII                   @SC86202 08842500
         MVC   IBFC1+1(1),0(9) Save column 1 as EBCDIC         @SC91116 08843000
         LR    2,9           Address                           @SC86202 08843500
         LR    3,0           Length                            @SC86202 08844000
         CLC   =CL(LALF)'&JAPNEUC',TRNALF                      @SC91325 08844500
         BNE   IBFXLA1       Normal translation                @SC91325 08845000
         ICM   14,15,=A(KJETOA) See if 2-byte Kanji present    @SC91325 08845500
         BZ    IBFXLA1       No, that could be a disaster      @SC91325 08846000
         KCALL (14),E=(IBFTRNX,M) Yes, call the routine        @SC91325 08846500
         LR    0,15          Get new length of buffer          @SC91325 08847000
         B     IBFXLA2       Done translating                  @SC91325 08847500
IBFXLA1  DS    0H                                              @SC91325 08848000
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08848500
IBFXLA2  DS    0H                                              @SC91325 08849000
         AR    9,0           Point one past last char                   08849500
         C     0,F1                                            @SC88340 08850000
         BE    IBFTRUNC      Record of 1 blank always converted@SC88340 08850500
         CLI   FRECF,C'F'                                      @SC88050 08851000
         BE    IBFTRUNC      Always trim if fixed length       @SC88349 08851500
         CLC   RMARG,F0                                        @SC88349 08852000
         BE    IBFTRUZ       Don't trim if no fixed rt. margin @SC88349 08852500
IBFTRUNC BCTR  9,0                   Back up one                        08853000
         CLI   0(9),ABL                                                 08853500
         BNE   IBFLCHAR              Found non-blank                    08854000
         BCT   0,IBFTRUNC            FIND LAST CHAR                     08854500
IBFEMPT  SR    0,0           Record is empty                   @SC87253 08855000
IBFTRUZ  BCTR  9,0           Point to last char of record      @SC88050 08855500
IBFLCHAR MVI   1(9),CR       Add CR                            @SC86135 08856000
         A     0,F1          Count up for CR                   @SC91116 08856500
         TM    FLNFLGS,FLNCC                                   @SC91116 08857000
         BO    IBFCC         Save LF for later                 @SC91116 08857500
         MVI   2(9),ALF      Add LF                            @SC86135 08858000
         A     0,F1          Count up for LF                   @SC91116 08858500
IBFLEN   ST    0,RBUFL               LRECL or LRECL + 2 (FOR CRLF)      08859000
         B     RTRN0                                                    08859500
*                                                                       08860000
IBFCC    L     1,RBUF        Start of buffer                   @SC91116 08860500
         LH    2,IBFC1                                         @SC91116 08861000
         IC    2,IBFCCTB(2)  Determine proper format character @SC91116 08861500
         CLI   CARCTL,0      Just beginning file?              @SC91116 08862000
         BE    *+8           Yes, suppress initial FF or LF    @SC91116 08862500
          STC  2,CARCTL      No, remember what to insert       @SC91116 08863000
         MVI   0(1),ALF      Usually substitute plain LF       @SC91116 08863500
         CLM   2,1,*+9                                         @SC91116 08864000
         BNE   *+8                                             @SC91116 08864500
          MVI  0(1),AFF      Page requires FF                  @SC91116 08865000
         B     IBFLEN                                          @SC91116 08865500
*                                                                       08866000
IBFEOF   OI    FL1,EOF                                                  08866500
         B     RTRNM1                                          @SC86295 08867000
*                                                                       08867500
IBFTRNX  L     1,FILPTR      Ptr to disk FAB                   @SC91325 08868000
         MVC   FABCOMM-FABD(8,1),=CL8'Xlate'                   @SC91325 08868500
         LA    15,999        Weird error code                  @SC91325 08869000
IBFERR   C     15,F12                EOF code?                          08869500
         BE    IBFEOF                Yes                                08870000
         ERRF  ,             Disk read error, analyze it       @SC87338 08870500
         CLOSF FILPTR        Close file                        @SC86295 08871000
         B     RTRN1                                           @SC86295 08871500
*                                                                       08872000
* Table of codes for combined ASA and machine carriage ctrl    @SC91116 08872500
* 0-3 => advance "n" lines, 12 => form feed                    @SC91116 08873000
IBFCCTB  DC    AL1(1,0),(X'13'-X'02')AL1(1),AL1(2)             @SC91116 08873500
         DC    (X'1B'-X'14')AL1(1),AL1(3)                      @SC91116 08874000
         DC    (X'4E'-X'1C')AL1(1),AL1(0)   '+'                @SC91116 08874500
         DC    (X'60'-X'4F')AL1(1),AL1(3)   '-'                @SC91116 08875000
         DC    (X'8B'-X'61')AL1(1),AL1(AFF)                    @SC91116 08875500
         DC    (C'0'-X'8C')AL1(1),AL1(2,AFF),14AL1(1)  '0,1'   @SC91116 08876000
         LOCALS ,                                              @SC86295 08876500
IBFC1    DS    H             Index into CCTB                   @SC91116 08877000
INBUF    EXIT                                                           08877500
         TITLE 'OUTBUF Routine - write WBUF to a disk file'             08878000
* Entry: R1=length of buffer (which starts where WBUF points)           08878500
* Exit: R15=0 if ok, other if error (ERRNUM set)                        08879000
OUTBUF   ENTER                                                          08879500
         WEAKX KJATOE                                          @SC91325 08880000
         LR    9,1           Save buffer length                @SC88120 08880500
         L     6,FSIZE       Use to hold lrecl                 @SC88120 08881000
         L     7,WBUF                Address of buffer                  08881500
         ICM   2,15,RDWLEN                                     @SC86151 08882000
         BZ    OBFNRM                                          @SC86151 08882500
         SR    1,1           Special format                    @SC86151 08883000
         ICM   1,3,0(7)      Get true record length            @SC86151 08883500
         C     2,F2          Short?                            @SC86262 08884000
         BE    OBFVLEN       Yes                               @SC86262 08884500
         PACK  TMPDW,0(5,7)  No, must be 5-byte ASCII          @SC86262 08885000
         OI    TMPDW+7,15    Get + sign                        @SC86262 08885500
         CVB   1,TMPDW       Convert back to binary            @SC86262 08886000
OBFVLEN  DS    0H                                              @SC86262 08886500
         AR    7,2           Skip over descriptor              @SC86151 08887000
         SR    9,2           Correct length                    @SC86151 08887500
         LA    15,15         Suitable disk error               @SC86151 08888000
         CR    1,9           Match?                            @SC86151 08888500
         BE    OBFLEN        Ok, do it                         @SC88053 08889000
         L     1,FILPTR      Ptr to disk FAB                   @SC88053 08889500
         MVC   FABCOMM-FABD(8,1),=CL8'Binary'                  @SC88053 08890000
         B     OBFERR        No, give up                       @SC88053 08890500
OBFNRM   DS    0H                                              @SC86151 08891000
         TM    FL1,BINF                                                 08891500
         BO    OBFLEN                Go if binary data file             08892000
         LTR   9,9                   Any data to write?                 08892500
         BNZ   OBFTR                 Yes, there's data                  08893000
         MVI   0(7),ABL              Make first char a space            08893500
         LA    9,1                   Length of one                      08894000
OBFTR    LA    15,ATOE       Change to EBCDIC                  @SC86202 08894500
         LR    2,7                                             @SC86202 08895000
         LR    3,9           Length                            @SC86202 08895500
         CLC   =CL(LALF)'&JAPNEUC',TRNALF                      @SC91325 08896000
         BNE   OBFXLA1       Normal translation                @SC91325 08896500
         ICM   14,15,=A(KJATOE) See if 2-byte Kanji present    @SC91325 08897000
         BZ    OBFXLA1       No, that could be a disaster      @SC91325 08897500
         KCALL (14),E=(OBFTRNX,M) Yes, call the routine        @SC91325 08898000
         LR    9,15          Get new length of buffer          @SC91325 08898500
         B     OBFLEN        Done translating                  @SC91325 08899000
OBFXLA1  DS    0H                                              @SC91325 08899500
         BAL   14,TRANSLAT   Do the translate                  @SC86202 08900000
OBFLEN   CR    9,6           Compare data len. to trunc len.   @SC88120 08900500
         BE    OBFWRT        Go if lrecl exactly               @SC87268 08901000
         BH    OBFTRNC       Go if must truncate               @SC87268 08901500
         CLI   FRECF,C'F'                                      @SC88120 08902000
         BNE   OBFWRT        Go if variable format             @SC88120 08902500
         LR    1,6                   Else, get lrecl size               08903000
         SR    1,9                   Pad with this many spaces          08903500
         LA    0,0(9,7)              Where to start padding             08904000
         SR    15,15                                           @SC86295 08904500
         TM    FL1,BINF                                        @SC86295 08905000
         BO    *+8                                             @SC86295 08905500
         ICM   15,8,BLANK    Pad with spaces                   @SC86295 08906000
         MVCL  0,14                  Do it                              08906500
         B     OBFLRECL      And note new length               @SC87268 08907000
OBFTRNC  LA    0,1                                             @SC87268 08907500
         A     0,RECTRC                                        @SC87268 08908000
         ST    0,RECTRC      Increment count of truncations    @SC87268 08908500
         CLI   TRNCFL,C'H'   Do we halt here?                  @SC88120 08909000
         BNE   OBFLRECL      Truncation allowed, ok            @SC88120 08909500
         MVI   ERRNUM,ERRRTR Mark error and stop               @SC88120 08910000
         B     RTRN1                                           @SC88120 08910500
OBFLRECL LR    9,6                   Length has to be this size         08911000
OBFWRT   LM    14,15,DSKTOT  Update disk count                 @SC86295 08911500
         ALR   15,9                                            @SC86295 08912000
         BC    12,*+8                                          @SC88092 08912500
         AL    14,F1                                           @SC86295 08913000
         STM   14,15,DSKTOT  Save new count                    @SC86295 08913500
         WRITF FILPTR,BUFFER=(7),BSIZE=(9)                     @SC87034 08914000
         LTR   15,15                 Any disk write errors?             08914500
         BZ    OBFRET                Nope, all OK                       08915000
         MVI   ERRNUM,ERRFUL Maybe disk is full                @SC86345 08915500
         CLM   15,1,ERRNUM   Is it?                            @SC86345 08916000
         BE    OBFRET        Yes, too bad                      @SC86345 08916500
OBFERR   ERRF  ,             General write error, analyze it   @SC87338 08917000
OBFRET   RET                                                            08917500
OBFTRNX  L     1,FILPTR      Ptr to disk FAB                   @SC91325 08918000
         MVC   FABCOMM-FABD(8,1),=CL8'Xlate'                   @SC91325 08918500
         LA    15,999        Weird error code                  @SC91325 08919000
         B     OBFERR        Give up                           @SC91325 08919500
         LOCALS ,                                              @SC86295 08920000
OUTBUF   EXIT                                                           08920500
         TITLE 'FOPSTR Routine - test string for file options'          08921000
* Entry: R1->Address of option field, R6->string, R7=length - 1         08921500
* Exit: R15=0 + R6,R7 fixed if ok, R15=1 if error (msg ptrs set up)     08922000
FOPSTR   ENTER ,                                               @SC89218 08922500
         LR    5,1           Save ptr to options               @SC89218 08923000
         NI    FL2,255-FOPTS Clear option flag                 @SC89218 08923500
         MVC   0(8,5),=F'0,-1' Default values                  @SC89218 08924000
         MVI   8(5),0        Default flags                     @SC91116 08924500
         LA    9,0(7,6)      Point to last character           @SC89218 08925000
         LR    1,9                                             @SC89218 08925500
         EX    7,FOPTRT      Scan for option starter           @SC89218 08926000
         BZ    RTRN0         Not found, no action              @SC89218 08926500
         OI    FL2,FOPTS     Yes, note the fact                @SC89218 08927000
         PTEXT '&MISSOPS'  Just in case                        @SC89249 08927500
         CR    1,9           Anything after the starter?       @SC89218 08928000
         BE    FOPERR        No, too bad                       @SC89218 08928500
         PTEXT '&BADDELF'    In case                           @SC89249 08929000
         CLI   0(9),FBRK2    Check ending                      @SC89218 08929500
         BNE   FOPERR        Wrong one                         @SC89218 08930000
         LR    0,1                                             @SC89218 08930500
         SR    0,6           Length of stuff before options    @SC89218 08931000
         BCTR  0,0           Length - 1                        @SC89218 08931500
         LA    6,1(,1)       Ptr to option string              @SC89218 08932000
         RETREG (7,0)        Return length-1 as fixed R7       @SC89218 08932500
*          Set up loop over line numbers                       @SC89218 08933000
         LA    1,2                                             @SC89218 08933500
         LR    2,5           Ptr to option fields              @SC89218 08934000
         LA    8,C'-'        Delimiter after 1st number        @SC89218 08934500
*                                                                       08935000
FOPNLP   LA    7,1(,9)       End of string                     @SC89218 08935500
         SR    7,6           Length remaining                  @SC89218 08936000
         CH    7,*+10                                          @SC89218 08936500
         BNH   *+8                                             @SC89218 08937000
         LA    7,15          Max allowed by GETNUM             @SC89218 08937500
         LR    15,6          Save start of string              @SC89218 08938000
         BAL   14,GETNUM     1st, returns R15->end of digits   @SC89218 08938500
         LR    7,15                                            @SC89218 08939000
         SR    7,6           Length of numeric string          @SC89218 08939500
         BAL   14,GETNUM     2nd, returns number and skips     @SC89218 08940000
          SR   0,0           Omitted, use -1                   @SC89218 08940500
          BCTR 0,0                                             @SC89218 08941000
         LA    6,1(,15)      Ptr to rest of string             @SC89218 08941500
         STCM  0,15,0(2)     Save result in option field       @SC89218 08942000
         CLI   0(15),FBRK2   Reached end?                      @SC89218 08942500
         BE    FOPNLQ        Yes, quit scanning                @SC89218 08943000
         CLI   0(15),C'_'    Reached end of range limits?      @SC89218 08943500
         BE    FOPNLQ        Yes, quit scanning                @SC89218 08944000
         PTEXT '&BADDELM'                                      @SC89249 08944500
         CLM   8,1,0(15)     Delimiter for this number?        @SC89218 08945000
         BNE   FOPERR        None of these, syntax error       @SC89218 08945500
         LA    2,4(,2)       Advance output ptr                @SC89218 08946000
         LA    8,C'_'        Change delimiter                  @SC89218 08946500
         BCT   1,FOPNLP      Get next number                   @SC89218 08947000
FOPNLQ   ICM   1,15,0(5)     Check starting line number        @SC89218 08947500
         S     1,F1          Convert to number to skip         @SC89218 08948000
         BNM   *+6                                             @SC89218 08948500
          SR   1,1           No skipping                       @SC89218 08949000
         STCM  1,15,0(5)                                       @SC89218 08949500
         PTEXT '&BADRNGE'                                      @SC89249 08950000
         CLM   1,15,4(5)     Check range for order             @SC89218 08950500
         BNL   FOPERR        Upper limit smaller!              @SC89218 08951000
         CR    6,9           Any more option text?             @SC89218 08951500
         BNL   RTRN0         No, all done                      @SC89218 08952000
*          Other options                                       @SC89218 08952500
*                                                                       08953000
         CLC   =C'CC',0(6)                                     @SC91116 08953500
         BE    FOPCC                                           @SC91116 08954000
         CLC   =C'cc',0(6)                                     @SC91116 08954500
         BE    FOPCC                                           @SC91116 08955000
*          Fall through if option not defined                  @SC89218 08955500
         PTEXT '&BADOPTS'                                      @SC89249 08956000
FOPERR   RETREG 3,4          Return msg ptrs as R3, R4         @SC89218 08956500
         MVI   ERRNUM,ERROPT Error with option(s)              @SC89249 08957000
         B     RTRN1                                           @SC89218 08957500
*                                                                       08958000
FOPCC    OI    FLNFLGS-FLNOPTS(5),FLNCC  Set flag for CC       @SC91116 08958500
         B     RTRN0                                           @SC91116 08959000
*                                                                       08959500
FOPTRT   TRT   0(,6),FOPBRK  Scan for initial character        @SC89218 08960000
FOPBRK   DC    256X'00'                                        @SC89218 08960500
         ORG   FOPBRK+FBRK1                                    @SC89218 08961000
         DC    X'01'                                           @SC89218 08961500
         ORG   ,                                               @SC89218 08962000
         LOCALS ,                                              @SC89218 08962500
         EXIT  ,                                               @SC89218 08963000
         TITLE 'KHDMP Routine - dump storage to log file'               08963500
* Dump area to log                                                      08964000
* Entry: R1->area, R0=length, R2-> 8-byte title for area                08964500
* Exit: R15=0 if ok                                                     08965000
KHDMP    ENTER ,                                               @SC91008 08965500
         AIF   ('&KTRACE' EQ 'NO').KHDZ1                       @SC91008 08966000
         TM    FL1,DEBUG+TSTF Special logging in effect?       @SC91008 08966500
         BNO   RTRN0         No, that's all                    @SC91008 08967000
         LA    5,15          Round up to mult of 16            @SC91008 08967500
         ALR   5,0           From length                       @SC91008 08968000
         SRA   5,4           Convert to count of lines         @SC91008 08968500
         BNP   RTRN0         Nothing there                     @SC91008 08969000
         LR    4,1           Save ptr to area                  @SC91008 08969500
         L     6,LOGBUF      Ptr to buffer                     @SC91008 08970000
         MVI   0(6),C'*'     Set log label                     @SC91008 08970500
         MVC   2(8,6),0(2)   Copy title                        @SC91008 08971000
         WRITF LOGPTR,BSIZE=10                                 @SC91008 08971500
         MVC   4*9+2(3,6),=C'  *'  Set off character version   @SC91008 08972000
         MVI   4*9+2+3+16(6),C'*'                              @SC91008 08972500
KHDLP1   LA    3,2(,6)       Start of data area                @SC91008 08973000
         LA    1,4           Words to dump per line            @SC91008 08973500
         MVC   4*9+2+3(16,6),0(4)   Copy string                @SC91008 08974000
         TR    4*9+2+3(16,6),KHDPRT and make printable         @SC91008 08974500
         MVI   0(3),C' '     Add for readability               @SC91008 08975000
KHDLP2   UNPK  1(9,3),0(5,4) Unpack into buffer                @SC91008 08975500
         TR    1(8,3),TRHEX  Convert to printable hex          @SC91008 08976000
         MVI   9(3),C' '     Blank out garbage                 @SC91008 08976500
         LA    3,9(,3)       Advance text ptr                  @SC91008 08977000
         LA    4,4(,4)       and data source                   @SC91008 08977500
         BCT   1,KHDLP2      Loop over line of 16              @SC91008 08978000
         LA    3,4*9+2+3+16+1 Length of data                   @SC91008 08978500
         WRITF LOGPTR,BSIZE=(3)                                @SC91008 08979000
         BCT   5,KHDLP1      Loop over lines                   @SC91008 08979500
         TM    DBGFLG,DBGSV  SAVE requested?                   @SC91008 08980000
         BZ    RTRN0         No, skip closing log file         @SC91008 08980500
         SAVEF LOGPTR        Update disk directory             @SC91008 08981000
.KHDZ1   ANOP                                                  @SC91008 08981500
         B     RTRN0                                           @SC91008 08982000
*                                                                       08982500
         AIF   ('&KTRACE' EQ 'NO').KHDZ2                       @SC91008 08983000
KHDPRT   DC    64C'.',192AL1(*-KHDPRT)                         @SC91008 08983500
.KHDZ2   ANOP                                                  @SC91008 08984000
         LOCALS ,                                              @SC91008 08984500
         EXIT  ,                                               @SC91008 08985000
         END   KERMIT                                                   08985500
