**************************************************************
** MAIN ENTRY POINT - KERMIT ONLY RUNS AS A SERVER SINCE    **
**  			THE SPERRY 90/60 CAN NOT INITIATE   **
**			USE OF AN RTIO LINE OTHER THAN THE  **
**			TERMINAL LINE ITSELF                **
** MCC TABLES AND TRANSLATION MODULES MODIFIED IN SYSTEM    **
**	THIS IS NECESSARY TO INSURE THAT ALL THE CHARACTERS **
**	IN THE PRINTABLE ASCII RANGE AND THE ^A HAVE VALUES **
**	WITHIN THE EBCDIC REPRESENTATION (SEE ATOE TABLE)   **
**************************************************************
SERVER   CSECT
         STM   14,12,12(13)      SAVE CALLER REGISTERS
         BALR  12,0              SET UP A BASE REGISTER
         USING *,12
         ST    13,SAVE+4         SAVE MY CALLERS SAVE AREA ADR
         LA    13,SAVE           SET UP MY SAVE AREA TO CALL 
         SETBF 200,N
WAIT     LA    1,=A(PKNAK,REC)   SET UP PARAMATER LIST
ERRSEN   L     15,=V(PACKETIO)   GET READY TO GO
         BALR  14,15             GO DO A TRANSFER
         LA    1,=A(REC)         ADDRESS OF PACKET RECIEVED
         LA    14,CHCK           RETURN ADDRESS FOR FOLLOWING
CHCK     CLI   RECTYP,C'S'       IS IT A SEND INIT PACKET
         BNE   SKIPSEND          CHECK NEXT PACKET TYPE
         L     15,=V(RECFILE)    REMOTE IS SENDING US A FILE
         BR    15                GO TAKE FILE FROM REMOTE TO DISK
SKIPSEND CLI   RECTYP,C'R'       IS IT A RECIEVE INIT PACKET
         BNE   SKIPREC           NO GO TO CHECK OTHER TYPES
         L     15,=V(SENFILE)    ROUTINE TO SEND FILE TO REMOTE
         BR    15                AND OFF WE GO
SKIPREC  CLI   RECTYP,C'I'       CHECK FOR AN INIT PACKET
         BNE   SKIPINIT
         L     15,=V(KRMTINI)    ADDRESS OF INIT HANDLER
         BR    15
SKIPINIT CLI   RECTYP,C'G'
         BNE   SKIPGEN
         CLI   RECDAT,C'L'       IS THIS A LOGOUT
         BNE   SKIPGEN
         LA    1,=A(PKYAK,0)
         L     15,=V(PACKETIO)
         BALR  14,15             ACK THE LOGOFF COMMAND
         CMAND '/LOGOFF'
SKIPGEN  CLI   RECTYP,C'Y'       IS THIS AN EXTRA ACK
         BE    WAIT              YES SEND A NAK AND WAIT    
         CLI   RECTYP,C'E'
         BE    WAIT
         LA    1,=A(PKERR,REC)
         B     ERRSEN
PKERR  DS  0F
PKELEN DC  X'1B'
PKESEQ DC  X'00'
PKETYP DC  C'E'
PKEDAT     DC  C'FUNCTION NOT IMPLEMENTED'
PKNAK    DS    0F
         DC    X'03'             LENGTH OF NAK PACKET TO SEND
         DC    X'00'             SEQUENCE NUMBER
         DC    C'N'
PKYAK    DC    X'03'             PACKET LENGTH
         DC    X'00'             PACKET NUMBER
         DC    C'Y'              PACKET DATA
REC      DS    0F
RECLEN   DS    XL1
RECSEQ   DS    XL1
RECTYP   DS    XL1
RECDAT   DS    CL150
SAVE     DS    18F
         END
KRMTINI  CSECT
         STM   14,12,12(13)      SAVE CALLER REGISTERS
         BALR  12,0              SET UP MY BASE REGISTER
         USING *,12
         ST    13,SAVE+4         SAVE CALLERS SAVE ADDRESS LOCAL
         LA    13,SAVE           SET UP A SAVE AREA FOR OTHER CALLS
***************************************************************
**KERMIT INIT PACKER HANDLER                                 **
**    ARGUMENTS (1) - 1 ADDRESS OF PACKET                    **
**                  RECIEVED INIT PACKET ON INPUT            **
**                  NEXT PACKET ON RETURN                    **
**    EXTERNAL REFF POINT - (KRMTPARM) START OF KERMIT 
**             PARAM LIST                                    **
***************************************************************
         L     2,0(1)            ADDRESS OF PACKET
         IC    3,0(2)            LENGTH OF PACKET
         MVI   PARMPKT,C' '      BLANK OUT THE LOCAL PACKET
         MVC   PARMPKT+1(152),PARMPKT
         BCTR  3,0               DECREMENT FOR AN EX MOVE
         EX    3,MOVEPKT         MOVE IT TO PARMPKT
         MVI   CALLTYP,C' '      NORMAL CALL
         CLI   PARMTYP,C'R'      IS THIS AN INIT REMOTE RECIEVE
         BE    WESTART           IF SO WE START THE INIT
SETMAXL  SR    11,11             CLEAR A REGISTER
         IC    11,PARMDAT        GET MAX LENGTH
         L     3,=V(ETOA)        NEED PACKETIO TRANS TABLE  
         IC    11,0(11,3)        CHANGE CHARACTER TO ASCII
         SH    11,=H'32'         LOWER FROM PRINTABLE RANGE
         STC   11,PARMMAXL       STORE AMOUNT IN PARM TABLE
SETTIME  SR    11,11
         IC    11,=X'10'         SET TIME TO WAIT TO 16 SECONDS
         AH    11,=H'32'         SET UP IN PRINTABLE RANGE
         L     4,=V(ATOE)        TRANS FROM PACKETIO TO EBCDIC
         IC    11,0(11,4)        CHANGE TIME TO EBCDIC
         STC   11,PARMDAT+1      PUT IN PACKET TO SEND
SETPAD   SR    11,11
         IC    11,PARMDAT+2      GET NUMBER OF PADDING CHARS
         IC    11,0(11,3)        CONVERT IT TO ASCII BITS
         SH    11,=H'32'         ADJUST DOWN FROM PRINTABLE
         STC   11,PARMNPAD       STORE IN MY PARM LIST
         LH    11,=H'0'         PUT SOME FILL CHARS IN
         AH    11,=H'32'         GET UP TO PRINTABLE RANGE
         IC    11,0(11,4)        TRANSLATE TO EBCDIC
         STC   11,PARMDAT+2      PUT IN PACKET TO SEND
SETPADC  SR    11,11 
         IC    11,PARMDAT+3      GET CHARACTER THEY ASKED FOR
         IC    11,0(11,3)        TRANSLATE TO ASCII
         X     11,XORWRD         USE CTL FUNCTION TO MOVE DOWN
         IC    11,0(11,4)        TRANSLATE BACK TO EBCDIC
         STC   11,PARMPADC       PUT IN PARM LIST
         SR    11,11
         X     11,XORWRD         USE CTL FUNCTION TO MOVE UP
         IC    11,0(11,4)        SET TO EBCDIC CHAR
         STC   11,PARMDAT+3      TELL HIM I WANT NULLS(WHO CARES)
SETEOL   SR    11,11
         IC    11,PARMDAT+4      GET EOL CHAR THEY WANT TO SEND
         IC    11,0(11,3)        TRANSLATE TO ASCII
         SH    11,=H'32'
         IC    11,0(11,4)        TRANSLATE BACK TO EBCDIC
         STC   11,PARMEOL        PUT IN PARM LIST
         IC    11,=X'15'         PUT IN MY <NL> CHARACTER
         IC    11,0(11,3)        TRANSLATE TO ASCII
         AH    11,=H'32'         SET UP TO PRINTABLE
         IC    11,0(11,4)        TRANSLATE BACK TO EBCDIC
         STC   11,PARMDAT+4
SETQCTL  IC    11,PARMDAT+5      GET QUOTE CHARACTER FOR CTL
         STC   11,PARMQCTL       GOOD FOR ME TOO
SETQBIN  MVI   PARMDAT+6,C'N'    WE DONT DO 8 BIT QUOTING
         MVI   PARMDAT+7,C'1'    WE ONLY DO 1 BYTE CHECKSUMS
SEQREPT  IC    11,PARMDAT+8      GET A REPT QUOTE CHARACTER
         STC   11,PARMREPT       GOOD ENOUGH FOR M
         MVI   PARMDAT+9,X'00'   WE HAVE NO EXTENSIONS
         MVI   PARMTYP,C'Y'      CHANGE PACKET TO AN ACK
         CLI   CALLTYP,C'R'      IS THIS INIT CAUSED BY A R PACKET
         BE    ENDCALL           WE ALREADY SENT OUT INIT PARAMS
         LA    1,ARGLIST
         L     15,=V(PACKETIO)   CALL PACKET I/O FOR MESS SWAP
         BALR  14,15
ENDCALL  L     11,=V(PIOINIT)    GET PARAM LOCATION IN PACKETIO
         MVC   0(3,11),PARMNPAD  MOVE NPAD, PADC, AND EOL CHARS
GOBACK   SR    11,11             CLEAR IT
         IC    11,PARMLEN        GET THE LENGTH
         BCTR  11,0              DECREMENT BY 1 FOR EX MOVE
         EX    11,MOVEBK         MOVE IT BACK TO CALLER
RETURN   L     13,SAVE+4
         LM    14,12,12(13)
         SR    15,15
         BR    14
WESTART  LA    1,=A(PKINIT,PARMPKT)
         L     15,=V(PACKETIO)   SEND BASIC INIT START
         BALR  14,15
         CLI   PARMTYP,C'E'
         BE    GOBACK
         CLI   PARMTYP,C'I'
         BE    ISOK
         CLI   PARMTYP,C'Y'
         BE    ISOK
         B     GOBACK
ISOK     MVI   CALLTYP,C'R'      THIS IS AN R PACKET INIT
         B     SETMAXL           GO UP AND GET PARAM
ARGLIST  DC    A(PARMPKT)
         DC    A(PARMPKT)
XORWRD   DC    F'64'
MOVEPKT  MVC   PARMPKT(1),0(2)
MOVEBK   MVC   0(1,2),PARMPKT
CALLTYP  DS    CL1
SAVE     DS    18F
PARMPKT  DS    0F
PARMLEN  DS    XL1
PARMSEQ  DS    XL1
PARMTYP  DS    XL1
PARMDAT  DS    CL150
         ENTRY KRMTPARM
KRMTPARM EQU   *
PARMMAXL DS    XL1
PARMTIME DS    XL1
PARMNPAD DS    XL1
PARMPADC DS    CL1
PARMEOL  DS    CL1
PARMQCTL DS    CL1
PARMQBIN DS    CL1
PARMCHKT DS    CL1
PARMREPT DS    CL1
PARMCAPS DS    X'00'
PKINIT   DS    0F 
PKILEN   DC    X'0C'
PKISEQ   DC    X'00'
PKITYP   DC    C'S'
PKIMAXL  DC    X'FF'
PKITIM   DC    C'-'
PKINPAD  DC    C' '
PKIPADC  DC    C'@'
PKIEOL   DC    C'-'
PKIQCTL  DC    C'#'
PKIQBIN  DC    C'N'
PKICKTYP DC    C'1'
PKIQREPT DC    C'_'
         END
KRMTUC   CSECT
         STM   14,12,12(13)
         BALR  12,0
         USING *,12
         ST    13,SAVE+4
         LA    13,SAVE
****************************************************
*  ROUTINE TO CONVERT A 54 CHAR FIELD TO UPPER CS  *
****************************************************
         L     2,0(1)            GET ADDRESS OF THE FIELD
         LA    3,54              GET A COUNT IN REG 3
LOOPUC   CLI   0(2),X'81'        CHECK LOWER RANGE TO CHANGE
         BL    NOCHNG            IF LOW NO CHANGE
         CLI   0(2),X'A9'        CHECK THE UPPER RANGE
         BH    NOCHNG            IF HIGH NO CHANGE
         OI    0(2),X'40'        SET THE BIT FOR UPPER CASE
NOCHNG   LA    2,1(2)            INCREMENT 2 BY 1
         CLI   0(2),X'40'        IS IS A BLANK
         BE    RETURN            IF SO NO MORE TO CHECK
         BCT   3,LOOPUC          GO CHECK NEXT CHAR
RETURN   L     13,SAVE+4         GET THE SAVE AREA
         LM    14,12,12(13)      SET REGISTERS BACK
         SR    15,15             ALL OK
         BR    14                AND BACK WE GO
SAVE     DS    18F
         END
PACKETIO CSECT 
         STM   14,12,12(13)
         BALR  12,0
         USING *,12
**************************************************************
**  KERMIT I/O HANDELER                                     **
**  USE:                                                    **
**      CONVERTS A PACKET FROM SIMPLE INTERNAL FORMAT       **
**         TO KERMIT FORMAT AND SENDS IT                    **
**      RECIEVES THE ANS PACKET AND CONVERTS IT TO SIMPLE   **
**         INTERNAL FORMAT                                  **
**      RETRANSMITS FOR I/O ERRORS UNTIL TRANSACTION FINISH **
**  CALL FORMAT:                                            **
**      STANDARD LINKAGE USAGE                              **
**      ARG #1 - ADDRESS OF PACKET TO SEND                  **
**      ARG #2 - ADDRESS OF PACKET TO RECIEVE               **
**  INTERNAL PACKET FORMAT:                                 **
**      <LENGTH> BINARY LENGTH INCLUSIVE                    **
**      <SEQ>    PACKET SEQUENCE NUMBER IN BINARY           **
**      <TYPE>   CHARACTER REPRESENTING PACKET TYPE         **
**      <DATA>   VARIABLE LENGTH DATA FIELD                 **
**                  LENGTH OF FIELD = <LENGTH>-3            **
**  PROCEDURE:                                              **
**       A) PREFIX PACKET WITH A ^A FOR START OF PACKET     **
**       B) PREFIX PACKET WITH LENGTH AND STUFF FOR A       **
**           UNIVAC V TYPE RECORD                           **
**       C) CONVERT <LENGTH>&<SIZE> TO CHAR ADJUSTED FORM   **
**       D) CALCULATE A CHECK SUM BASED ON ASCII REP        **
**       F) SUFFIX PACKET WITH A CARRAGE RETURN             **
**           EBCDIC <NL> X'15' = ASCII <CR> X'0D'           **
**       G) SEND THE PACKET AND GET THE RETURN PACKET       **
**       H) CONVERT THE RETURN PACKET TO SIMPLE FORM        **
**       I) RETURN THE PACKET TO THE CALLER                 **
**  ERRORS:                                                 **
**       ALL ERRORS CAUSE THE ORIGINAL PACKET TO BE SENT    **
**         AGAIN. (THIS SHOULD BE OK; DUPE PACKETS ARE DROP)**
**       ERRORS WHICH ARE INTERCEPTED ARE:                  **
**         RTIO ERROR - UNIVAC BUFFER OVERRUN               **
**         CHECKSUM   - ERROR ON CHECKSUM ON RETURNING PACK **
**         NAK        - PACKET SENT WAS NAK'ED BY REMOTE    **
**************************************************************
         SPACE
         SPACE
**************************************************************
** BUILD THE PACKET TO GO OUT                               **
**************************************************************
         L     3,0(1)            GET ADDRESS PACKET TO SEND
         L     4,4(1)            GET ADDRESS OF PACKET 
         SR    5,5               CLEAR A REG FOR ERROR COUNT
SENDAGN  SR    11,11             CLEAR OUT A TEMP REG
         C     5,=F'50'          CHECK FOR ERROR ABORT
         BH    TERMD             LETS GET THAT DUMP
         IC    11,0(3)           GET THE LENGTH OF PACKET
         EX    11,MOVEPK         MOVE TO LOCAL(YES 1 EXTRA CHAR)
         MVI   SENDMRK,X'27'     MOVE IN ^A FOR START OF PACKET
         LA    11,8(11)          GET LENGTH FOR V RECORD
         STH   11,SENDVREC       STORE IT IN BEGINNING OF BUFFER
         MVC   SENDFIL,=X'4040'  BLANKS TO KEEP UNIVAC HAPPY
         MVI   SENDNUL,X'00'     MOVE IN A NUL AT START OF LINE
         SR    11,11             CLEAR IT AGAIN
         IC    11,SENDLEN        GET THE LENGTH AGAIN
         STC   11,SAVELEN        SAVE LENGTH FOR LATER USE
         AH    11,=H'32'         MOVE UP TO PRINTABLE
         STC   11,SENDLEN        PUT BACK IN PACKET
         TR    SENDLEN,ATOE      TRANS TO EBCDIC FOR LATER ASCII
         SR    11,11             CLEAR 11 FOR SAME TO SEQUENCE
         IC    11,SENDSEQ        GET THE SEQUENCE NUMBER
         AH    11,=H'32'         ADJUST UP TO PRINTABLE
         STC   11,SENDSEQ        PUT BACK IN PACKET RECORD
         TR    SENDSEQ,ATOE      TRANS TO EBCDIC FOR LATER ASCII CVT
         SR    11,11             CLEAR TEMP REGISTER AGAIN
         IC    11,SAVELEN        GET ORIGINAL BINARY LENGTH
         EX    11,MOVETS         MOVE PACKET TO TEMP STORAGE
         EX    11,TRANTS         TRANSLATE TEMPORARY TO ASCII
         SR    10,10             CLEAR ANOTHER REGISTER FOR TEMP
         SR    9,9               CLEAR A REGISTER FOR SUM
         LR    8,11              POINT TO LAST CHAR (CHECKSUM)
LOOPCKSM IC    10,TEMPS-1(8)     GET NEXT CHAR IN STRING
         AR    9,10              ADD TO SUM
         BCT   8,LOOPCKSM        GO BACK FOR MORE CHARS
         N     9,ZAPHIGH         GET RID OF HIGH 3 BYTES
         LR    8,9               COPY TO 8
         SRL   8,6               SHIFT RIGHT 6 BITS TO LEAVE HIGH 2
         AR    9,8               ADD IT TO THE SUM
         N     9,ZAPBUT6         ZAP ALL BUT LAST 6 BITS
         AH    9,=H'32'          MOVE UP TO PRINTABLE RANGE
         IC    9,ATOE(9)         CONVERT TO EBCDIC
         STC   9,SENDLEN(11)     PUT AT END OF PACKET
         IC    8,CARRET          GET A CARRAGE RETURN/NEW LINE
         STC   8,SENDLEN+1(11)   PUT AFTER THE CHECK SUM
**************************************************************
** NOW THAT A PACKET IS READY TO GO WE WILL SEND IT TO      **
** THE REMOTE DEVICE VIA TERMINAL LINE AND WAIT FOR THE     **
** RETURN PACKET FROM THE REMOTE                            **
         SR    11,11             CLEAR REG
         IC    11,NPAD           GET NUMBER OF PAD CHARS
         LTR   11,11             SEE IF ZERO
         BZ    WTRD              DO THE WRITE NOW
         MVC   TEMPS(1),PADC     MOVE IN PAD CHARACTER
         MVC   TEMPS+1(150),TEMPS
         AH    11,=H'5'          ADD FOR RECLEN
         STH   11,TEMPS          PUT IN THE RECORD
         MVC   TEMPS+2(2),=C'  ' PUT IN BLANKS KEEP UNI HAPPY
         WROUT TEMPS,X'16'       WRITE OUT THE NULLS (NO CR)
WTRD     LTR   4,4               CHECK RETURN PACKET ADDR
         BZ    SENDONLY          IF ZERO WE SEND AND RETURN
         WRTRD SENDPK,X'16',TEMPS,X'16',150,RTIOERR
**************************************************************
** INPUT BUFFER (TEMPS) SHOULD HAVE A PACKET. FIRST WE MUST **
** FIND THE ^A TO START THE PACKET AND DROP TRASH           **
**************************************************************
         TRT   TEMPS+4(L'TEMPS-4),TABCTLA
         BZ    RTIOERR           ^A NOT FOUND    
         LA    11,TEMPS-1        ADDRESS OF START OF PACKET
         LH    10,TEMPS          LENGTH OF STRING (V REC)
         LR    9,1               ADDRESS OF ^A
         N     9,ZAPADDR
         N     11,ZAPADDR        GET RID OF FIRST BY ADDRESS CONST
         SR    9,11              AMOUNT OF TRASH BEFORE ^A
         AR    11,9              ADD LENGHT OF TRASH TO START
         SR    10,9              GET LENGHTOF GOOD DATA
         LR    8,10              SAVE LENGHT OF GOOD DATA(TEMP)
         BCTR  10,0              DECREMENT BY 1 FOR EX TYPE MOVE
         EX    10,MOVEGT         MOVE IT TO THE "GET" PACKET
***************************************************************
** THE GOOD PART OF THE PACKET IS IN THE "GET" AREA          **
** MUST BE CHECKED FOR CHECKSUM OR NAK                       **
***************************************************************
         SR    11,11             CLEAR OUT A TEMP REG
         IC    11,GETLEN         GET THE EBCDIC LENGTH(NOT READY)
         IC    11,ETOA(11)       TRANSLATE CHAR TO ASCII
         SH    11,=H'32'         DOWN FROM PRINTABLE TO BINARY
         BM    RTIOERR           THIS PACKET LENGTH IS BAD
         SR    8,11              GET DIFF BETWEEN V LEN AND PACKET
         C     8,=F'5'           IS THE DIFF MORE THAN 5
         BH    RTIOERR
         C     8,=F'-5'          IS DIFF LESS THAN 5
         BL    RTIOERR
         EX    11,MOVEGTP        MOVE IT TO TEMP STORAGE
         EX    11,TRANTS        TRANSLATE IT TO ASCII
         LR    10,11             POINT TO LAST CHAR
         SR    9,9               CLEAR FOR SUM
         SR    8,8               CLEAR FOR TEMP USE
LOOPCK   IC    8,TEMPS-1(10)     GET A CHARACTER
         AR    9,8               ADD IT TO THE SUM
         BCT   10,LOOPCK         GO BACK FOR MORE CHARS?
         N     9,ZAPHIGH         CLEAR ALL BUT LAST BYTE
         LR    10,9              COPY TO REG 10
         SRL   10,6              MOVE HIGH 2 BITS OF BYTE TO LOW BITS
         AR    9,10              ADD THOSE BITS TO THE SUM
         N     9,ZAPBUT6         CLEAR ALL BUT LAST 6 BITS
         AH    9,=H'32'          ADD TO COMPAIR IN PRINTABLE RANGE
         IC    10,TEMPS(11)      GET THE CHECKSUM RECIEVED
         CR    9,10              ARE THEY THE SAME
         BNE   RTIOERR           IF NOT LETS TRY AGAIN
**************************************************************
** THIS LOOKS LIKE A GOOD PACKET. NEXT TO CHANGE THE BINARY **
** FIELDS FROM THEIR EBCDIC CHAR TRANSLATION                **
**************************************************************
         CLI   GETTYP,C'N'       IS THE PACKET A NAK
         BE    RTIOERR           IF SO LETS TRY AGAIN
         SR    11,11             CLEAR IT
         IC    11,TEMPS+1        GET ASCII REP FOR SEQUENCE
         SH    11,=H'32'         MOVE IT DOWN
         STC   11,GETSEQ         PUT IT IN THE PACKET TO RETURN
         IC    11,TEMPS          GET THE ASCII REP FOR LENGTH
         SH    11,=H'32'         MOVE IT DOWN FROM PRINTABLE
         STC   11,GETLEN         PUT IN PACKET TO RETURN
         BCTR  11,0              DECREMENT IT FOR THE MOVE
         EX    11,MOVEBK         MOVE IT BACK TO CALLER
RETURN   LM    14,12,12(13)      RESTORE CALLERS REGISTERS
         SR    15,15             ALL IS OK
         BR    14                AND BACK TO THE CALLER
RTIOERR  LA    5,1(5)            INCREMENT I/O ERROR COUNT
         B     SENDAGN           GO BACK AND SEND AGAIN
SENDONLY WROUT SENDPK,X'16'
         B     RETURN            AND BACK WE GO
TERMD    TERMD      
         ENTRY ATOE,ETOA
ATOE     DC    X'00270303030303030303030303150303'
         DC    X'03030303030303030303030303030303'
         DC    X'405A7F7B5B6C507D4D5D5C4E6B604B61'
         DC    X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'
         DC    X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'
         DC    X'D7D8D9E2E3E4E5E6E7E8E9B4BCB56A6D'
         DC    X'4A818283848586878889919293949596'
         DC    X'979899A2A3A4A5A6A7A8A9C04FD0FF07'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'03030303030303030303030303030303'
ETOA     DC    X'000303030303037F0303030303030303'
         DC    X'03030303030D03030303030303030303'
         DC    X'03030303030303010303030303030303'
         DC    X'03030303030303030303030303030303'
         DC    X'20030303030303030303602E3C282B7C'
         DC    X'2603030303030303030321242A293B03'
         DC    X'2D2F03030303030303035E2C255F3E3F'
         DC    X'030303030303030303033A2340273D22'
         DC    X'03616263646566676869030303030303' 
         DC    X'026A6B6C6D6E6F707172030303030303'
         DC    X'0303737475767778797A030303030303'
         DC    X'030303035B5D0303030303035C030303'
         DC    X'7B414243444546474849030303030303'
         DC    X'7D4A4B4C4D4E4F505152030303030303'
         DC    X'0303535455565758595A030303030303'
         DC    X'3031323334353637383903030303037E'
TABCTLA  DC    256X'00'
         ORG   TABCTLA+X'27'
CTRLA    DC    X'27'
         ORG
SAVELEN  DS    CL1
         ENTRY PIOINIT
PIOINIT  EQU   *
NPAD     DS    XL1
PADC     DS    CL1
CARRET   DC    X'15'
MOVETS   MVC   TEMPS(1),SENDLEN
MOVEGTP  MVC   TEMPS(1),GETLEN
TRANTS   TR    TEMPS(1),ETOA
MOVEPK   MVC   SENDLEN(1),0(3)
MOVEGT   MVC   GETLEN(1),1(11)
MOVEBK   MVC   0(1,4),GETLEN
         DS    0F
ZAPHIGH  DC    X'000000FF'
ZAPBUT6  DC    X'0000003F'
ZAPADDR  DC    X'00FFFFFF'
         LTORG
SENDPK   DS    0F
SENDVREC DS    H
SENDFIL  DS    XL2
SENDNUL  DS    XL1
SENDMRK  DS    CL1
SENDLEN  DS    CL1
SENDSEQ  DS    CL1
SENDTYP  DS    CL1
SENDDATA DS    CL150
SAFE1    DS    CL256
         DS    0F
TEMPS    DS    CL150
SAFE2    DS    CL256
GETPK    DS    0F
GETLEN   DS    CL1
GETSEQ   DS    CL1
GETTYP   DS    CL1
GETDATA  DS    CL150
SAFE3    DS    CL256
         END
SENFILE  CSECT
         STM   14,12,12(13)
         BALR  12,0
         USING *,12
         ST    13,SAVE+4
         LA    13,SAVE
***********************************************************
** ROUTINE TO SEND A FILE                                **
***********************************************************
         L     3,0(1)            GET THE ADDRESS OF PACKET
         SR    11,11             CLEAR IT
         IC    11,0(3)           GET THE LENGTH
         BCTR  11,0              DECREMENT BY 1 FOR MVC
         EX    11,MOVELCL        MOVE THE PACKET TO LOCAL
         MVI   INFCB+X'2E',C' '
         MVC   INFCB+X'2F'(53),INFCB+X'2E'
         SH    11,=H'3'          SUBTRACT FOR LEN,SEQ,TYP
         EX    11,MOVEFIL        MOVE THE FILE NAME TO FCB
         LA    1,=A(INFCB+X'2E')
         L     15,=V(KRMTUC)
         BALR  14,15
         MVC   FILECMD+12(54),INFCB+X'2E'
         LA    1,=A(PACKET)      SET UP PARM FOR SUB CALL
         L     15,=V(KRMTINI)    GET READY TO DO AN INIT
         BALR  14,15             AND OFF WE GO
         CLI   PKTYP,C'E'
         BE    RETURN
         CLI   PKTYP,C'Y'        IS IT AN ACK FOR INIT
         BE    ISOKACK           YES WE CAN GO ON
         B     RETURN
ABORT    TERMD 
ISOKACK  MVI   PKTYP,C'F'        START BUILDING A FILE PACKET
         MVC   PKDAT(54),FILECMD+12
         LA    11,PKDAT+53       POINT TO THE END OF PACKET
LOOKEND  CLI   0(11),C' '        IS THIS A BLANK CHAR
         BNE   HAVEEND 
         BCT   11,LOOKEND        LOOK FOR THE END OF FILENAME
HAVEEND  LA    10,PACKET         GET START OF PACKET
         SR    11,10             GET LENGTH IN 11
         LA    11,1(11)          INCREMENT TO MAKE INCLUSIVE
         STC   11,PKLEN          PUT IT IN THE LENGTH
         BAL   14,INCSEQ
         SR    10,10             CLEAR A TEMP REGISTER
         SR    11,11             CLEAR A SECOND TEMP REGISTER
         LA    1,ARGLIST         SEND ARG LIST OF PACKET,PACKET
         L     15,=V(PACKETIO)
         BALR  14,15             SEND THE F PACKET
         CLI   PKTYP,C'Y'        DID WE GET FILE ACK
         BNE   RETURN
         PRINT NOGEN
FILECMD  FILE  DUMMYFILE
         PRINT GEN
         OPEN INFCB,INPUT        OPEN THE INPUT FILE
         L     11,=V(KRMTPARM)
         SR    7,7
         IC    7,0(11)           GET MAX PACKET LENGTH
         SH    7,=H'3'           SUBTRACT LEN,TYP,SEQ
***************************************************************
** WE HAVE SENT AN INIT PACKET (SEE KRMTINI)                 **
** ALSO HAVE SENT AN F PACKET WITH THE FILE NAME IN IT       **
** AND THE FILE SHOULD BE OPEN FOR INPUT AT THIS POINT       **
***************************************************************
         SR    11,11
         SR    4,4               CLEAR A POINTER TO RECORD
         SR    5,5               CLEAR A POINTER TO DATA
         SR    9,9
GETREC   GET   INFCB,RECLEN      GET A RECORD FROM THE FILE
         LH    6,RECLEN          GET LENGTH OF RECORD
         SH    6,=H'4'           SUBTRACT LENGTH OF V REC FORMAT
MOVECHR  IC    11,RECORD(4)      GET NEXT CHARACTER FROM RECORD
         L     8,=V(ETOA)        NEED ADDRESS OF TRANSLATION TABLE
         IC    10,0(11,8)        GET ASCII VALUE OF CHARACTER
         EX    10,TESTBAD        CHECK FOR A NON PRINTABLE CHAR
         BNE   NOZAP             NOT CHANGED TO TILD
ZAPIT    IC    11,=X'6D'         MAKE THIS A TILD CHARACTER
NOZAP    STC   11,TESTCHR        PUT IT IN MEMORY
         CLI   TESTCHR,X'00'     GET RID OF NULLS
         BE    ZAPIT
         CLI   TESTCHR,X'0D'     IS IT A DEL CHARACTER
         BE    ZAPIT             GET RID OF THAT ALSO
         CLI   TESTCHR,X'01'     IS IT A CONTROL A
         BE    ZAPIT
         CLI   TESTCHR,X'FF'
         BE    ZAPIT
         CLI   TESTCHR,C'#'      IS THIS A #
         BNE   NORMCH            NO PROCESS NORMAL
         STC   11,PKDAT(5)       PUT IN FIRST #
         LA    5,1(5)            INCREMENT IN BUFFER
         CR    5,7               WILL THERE BE ROOM FOR NEXT #
         BL    STORECH           YES GO PUT IT IN
         BCTR  5,0               TAKE OFF THE ONE WE PUT IN
         BAL   2,WRITEPK         WRITE THE SHORT PACKET
         IC    11,=C'#'          GET BACK THE #
         STC   11,PKDAT(5)       PUT ONE IN
         LA    5,1(5)            INCREMENT POINTER
         B     STORECH           PUT IN THE SECOND ONE
NORMCH   CLC   TESTCHR,LASTCHR   IS THIS THE SAME AS LAST
         BE    INCCNT            IF SO INC THE REPT COUNT
         SR    9,9               SET CHAR COUNT TO ZERO
         MVC   LASTCHR,TESTCHR   MOVE THIS TO LAST
INCCNT   LA    9,1(9)            INCREMENT BY 1
         CH    9,=H'4'           HOW MANY DO WE HAVE
         BL    STORECH           NOT ENOUGH
         STC   11,PKDAT-1(5)     PUT THE CHAR IN
         IC    11,=X'FF'          GET A TILD
         STC   11,PKDAT-3(5)     PUT TILD IN FOR QUOTE
         L     8,=V(ATOE)        TRANS TO EBCDIC CHAR
         IC    11,32(8,9)        GET ASCII VALUE OF AMT
         STC   11,PKDAT-2(5)
         CH    9,=H'94'
         BL    INCDPTR
         MVI   LASTCHR,X'FE'
         B     INCDPTR
STORECH  STC   11,PKDAT(5)       PUT THE CHARACTER IN OUTPUT
         LA    5,1(5)            INCREMENT DATA POINTER
INCDPTR  LA    4,1(4)            INCREMENT RECORD POINTER
         CR    5,7               IS MORE ROOM IN PACKET
         BL    CHECKREC          IF YES IS MORE DATA IN REC
SKIPWRT  BAL   2,WRITEPK         WRITE A PACKET
CHECKREC CR    4,6               IS MORE DATA IN CURRENT RECORD
         BL    MOVECHR           PROCESS REST OF RECORD
         SR    9,9               SET REPT COUNT TO ZERO
         LR    11,5              GET LENGTH USED IN PACKET
         LA    11,4(11)           WILL THERE BE ROOM FOR QUOTED CHAR
         CR    11,7
         BNL   SKIPWRT           WE HAVE ROOM NO NEED TO WRITE
         IC    11,=C'#'          GET A PREFIX CHAR
         STC   11,PKDAT(5)       PUT IT IN THE RECORD
         IC    11,=C'M'          GET A 'M' FOR ^M
         LA    5,1(5)            INCREMENT BY 1
         STC   11,PKDAT(5)       PUT IT IN THE RECORD
         IC    11,=C'#'          QUOTE AGAIN
         LA    5,1(5)            GO TO NEXT POSITION
         STC   11,PKDAT(5)
         LA    5,1(5)
         IC    11,=C'J'
         STC   11,PKDAT(5)
         LA    5,1(5)            RECORD IS FINISHED
         SR    4,4               CLEAR RECORD POINTER FOR NEXT
         CR    5,7               DID WE FILL THE BUFFER
         BL    GETREC
         BAL   2,WRITEPK         GO TO LOCAL RTN TO WRITE PACKET
         B     GETREC            GO GET ANOTHER RECORD
INCSEQ   IC    11,PKSEQ
         LA    11,1(11)
         STC   11,PKSEQ
         NI    PKSEQ,63
         BR    14
WRITEPK  MVI   PKTYP,C'D'        SET PACKET TYPE TO DATA
         SR    11,11
         BAL   14,INCSEQ
         LA    5,3(5)            ADD FOR LEN,TYPE,SEQ
         STC   5,PKLEN           STORE IT IN THE LENGTH
         LA    1,ARGLIST         GET ADDRESS LIST FOR SUB CALL
         L     15,=V(PACKETIO)   GET ROUTINE TO WRITE PACKET
         BALR  14,15             AND WRITE IT OUT
         CLI   PKTYP,C'Y'        DID WE GET AN ACK
         BNE   ERRCLS            NO ABORT THIS RUN
         SR    5,5               THE NEW PACKET IS EMPTY
         SR    9,9               REPT COUNT IS ZERO
         BR    2                 GO BACK TO CALLER
EOF      LTR   5,5               WAS THERE DATA IN A PACKET
         BZ    WRITEZ            NO CLOSE THE TRANSMISSION
         BAL   2,WRITEPK         WRITE LAST PACKET
WRITEZ   MVI   PKTYP,C'Z'        END OF FILE PACKET
         CLOSE INFCB             REMEMBER TO CLOSE THE INPUT 
         SR    11,11
         BAL   14,INCSEQ
         MVI   PKLEN,X'03'       SET LENGTH TO 3
         LA    1,ARGLIST         GET READY TO CALL PACKETIO
         L     15,=V(PACKETIO)
         BALR  14,15             SEND THAT PACKET GET AN ACK
         CLI   PKTYP,C'E'
         BE    RETURN
         CLI   PKTYP,C'Y'        WAS IT AN ACK
         BNE   RETURN            LETS GET A DUMP
         MVI   PKTYP,C'B'        BUILD A BREAK PACKET
         BAL   14,INCSEQ
         MVI   PKLEN,X'03'       SET THE LENGTH TO 3
         L     15,=V(PACKETIO)
         BALR  14,15
         CLI   PKTYP,C'E'
         BE    RETURN
         CLI   PKTYP,C'Y'        THE BREAK SHOULD BE ACKED
         BNE   RETURN            IF NOT ABORT AGAIN
RETURN   SR    11,11
         IC    11,PKLEN          GET THE LENGTH
         BCTR  11,0              DECREMENT BY 1
         EX    11,MOVEBK         MOVE THE PACKET BACK TO CALLER
         L     13,SAVE+4         GET WHERE I PUT CALLERS REGISTERS
         LM    14,12,12(13)      RESTORE THOSE REGISTERS
         SR    15,15             ALL OK
         BR    14
NOFILE   LA    1,=A(D33ERR,PACKET)
         L     15,=V(PACKETIO)
         BALR  14,15
         B     RETURN
ERRCLS   CLOSE INFCB
         B     RETURN
SAVE     DS    18F
D33ERR   DC    YL1(ED33-*)
D33PKN   DC    X'00'
D33PKT   DC    C'E'
D33PKD   DC    C'OPEN ERROR OCCURED ON FILE OPEN'
ED33     EQU   *
ARGLIST  DC    A(PACKET)
         DC    A(PACKET)
PACKET   DS    0F
PKLEN    DS    XL1
PKSEQ    DS    XL1
PKTYP    DS    CL1
PKDAT    DS    CL150
MOVELCL  MVC   PACKET(1),0(3)    TARGET MOVE TO GO TO LOCAL STORAGE
MOVEBK   MVC   0(1,3),PACKET     TARGET MOVE TO GOT BACK TO CALLER
MOVEFIL  MVC   INFCB+X'2E'(1),PKDAT
TESTBAD  CLI   BADCHR,X'00'
BADCHR   DC    X'03'
TESTCHR  DS    CL1
LASTCHR  DS    CL1
         PRINT NOGEN
         DS    0D
INFCB    FCB   LINK=KRMOUT,FCBTYPE=SAM,RECFORM=V,EXIT=EXLST
EXLST    EXLST COMMON=NOFILE,EOFADDR=EOF
UNIREC   DS    0F
RECLEN   DS    H
REDFIL   DS    CL2
RECORD   DS    CL1000
         END
RECFILE  CSECT
         STM   14,12,12(13)
         BALR  12,0
         USING *,12
         ST    13,SAVE+4
         LA    13,SAVE           SET UP MY SAVE AREA
***********************************************************
** ROUTINE TO RECIEVE A FILE FROM REMOTE KERMIT          **
** FIRST WE MUST CHECK FOR AN S TYPE PACKET WHICH WOULD  **
** REQUIRE WE ACK WITH INIT PARAMS USING KRMTINI ROUTINE **
***********************************************************
         L     2,0(1)            GET ADDRESS OF PACKET
         IC    11,0(2)           GET THE LENGTH OF THE PACKET
         BCTR  11,0              DECREMENT BY 1 FOR MVC
         EX    11,MOVELCL        MOVE TO LOCAL STORAGE
         CLI   PKTYP,C'S'        IS IT THE INIT PACKET
         BNE   SKIPINI           IF NOT WE DONT NEED INIT
         LA    1,=A(PACKET)      SET UP AN ARG LIST FOR CALL
         L     15,=V(KRMTINI)    GET ADDRESS OF INIT ROUTINE
         BALR  14,15             OFF WE GO FOR THE INIT
         CLI   PKTYP,C'E'
         BE    RETURN
************************************************************
** HAVING INIT THE CONNECTION IT IS TIME TO SET UP THE    **
** FILE TO BE TRANSFERED                                  **
************************************************************
SKIPINI  CLI   PKTYP,C'F'        SHOULD BE A FILE NAME
         BNE   RETURN            WE REALLY NEED A FILE NAME
         L     11,=V(KRMTPARM)   GET ADDRESS OF INIT PARAM
         MVC   CTLCHR,5(11)      GET THE CONTROL QUOTE CHAR
         MVC   REPTCHR,8(11)     GET THE REPT QUOTE CHAR
         MVI   FILEFCB+X'2E',C' ' 
         MVC   FILEFCB+X'2F'(53),FILEFCB+X'2E'
         IC    11,PKLEN          GET LENGTH OF PACKET
         SH    11,=H'4'          SUBTRACT LEN,SEQ,TYP,+1
         EX    11,MOVENAME       MOVE NAME IN CLEAN FIELD
         LA    1,=A(FILEFCB+X'2E')
         L     15,=V(KRMTUC)
         BALR  14,15             CONVERT FILENAME TO UPPER CASE
         MVC   FILECMD+12(54),FILEFCB+X'2E'
FILECMD  FILE  DUMMYFILE
OPENFL   OPEN  FILEFCB,OUTPUT    OPEN THE FILE
*************************************************************
** FILE IS OPEN AND WE ARE READY TO START THE TRANSFER     **
** WE SHOULD BE PROCESSING 'D' PACKETS AT THIS TIME        **
**  P.S. SORRY ABOUT THE SLOPPY WAY OF REFF FILE NAME IN   **
**       UNIVAC FCB = FCB+X'2E' IT WASN'T WORTH THE COMPILE**
**       TIME TO INCLUDE THE IDFCB AND COVER IT WITH A REG **
*************************************************************
         MVC   PKASEQ,PKSEQ
         LA    1,=A(PKACK,PACKET)
         L     15,=V(PACKETIO)   ACK FILE NAME GET FIRST D
         BALR  14,15
         CLI   PKTYP,C'D'
         BNE   ERRCLS
         SR    10,10             CLEAR RECORD POINTER
         SR    8,8               CLEAR TEMP REG
         SR    9,9               START AT BEG OF DATA FIELD
         SR    11,11             CLEAR REG FOR COUNT
         IC    11,PKLEN          PUT IN THE LENGTH
         SH    11,=H'3'          REMOVE LEN TYP AND SEQ FIELDS
LOOPCHR  BAL   4,GETNEXT         GET THE NEXT CHARACTER IN 8
         EX    8,TESTCTL         TEST FOR A CONTROL PREFIX
         BE    PROCCTL           PROCESS A CONTROL CHAR
         EX    8,TESTREPT        TEST FOR REPT
         BE    PROCREPT          PROCESS THE REPT CHAR
         EX    8,TESTEND
         BE    PROCEND           PROCESS AN END OF FILE
TAKECHR  STC   8,RECORD(10)      PUT IT IN THE RECORD
         LA    10,1(10)          INCREMENT RECORD POINTER
         C     10,=F'2000'       HAVE WE REACHED THE END OF REC
         BE    ENDFILE           PRETEND WE HAD A LINE FEED
         B     LOOPCHR           GO FOR MORE 
PROCCTL  BAL   4,GETNEXT         GET NEXT CHARACTER
         STC   8,TEMPCHR         PUT IN MEMORY FOR CLI
         CLI   TEMPCHR,C'M'      IS IT A CARRAGE RETURN ^M
         BE    LOOPCHR           WE DONT NEED IT
         CLI   TEMPCHR,C'J'      IS IT A LINE RETURN
         BE    ENDREC            YES WRITE THE RECORD
         CLI   TEMPCHR,C'#'      IS THIS A # SIGN QUOTED WITH A #
         BE    TAKECHR           WELL WE WILL KEEP IT
         IC    8,=X'FF'          GIVE THEM A FLAG OF BAD CHAR
         B     TAKECHR           PUT IT IN THE OUTPUT REC
ENDREC   LTR   10,10             IS THERE ANY LENGTH TO REC
         BNZ   WRITEOK           YES NO BLANK NEEDED
         LA    10,1(10)          ADD 1 TO LENGTH
         IC    1,=C' '
         STC   1,RECORD(10)      PUT A BLANK IN THE RECORD
WRITEOK  AH    10,=H'4'          ADD FOR UNIVAC V REC
         STH   10,RECLEN         PUT IT IN THE LENGTH
         MVC   RECFIL,=C'   '    PUT IN V FILL CHARS
         PUT   FILEFCB,RECLEN    WRITE THE RECORD (USING MOVE MODE)
         SR    10,10             CLEAR THE RECORD POINTER
         B     LOOPCHR           GO PROCESS MORE CHARACTERS
PROCREPT BAL   4,GETNEXT         GET THE NEXT CHAR(REPT COUNT)
         L     5,=V(ETOA)        NEED IT IN ASCII
         IC    8,0(5,8)          CHANGE IT
         SH    8,=H'32'          MOVE IT DOWN FROM PRINTABLE
         LR    7,8               HOLD THAT COUNT
         BAL   4,GETNEXT         AND WHAT CHAR DO WE NEE
         EX    8,TESTCTL         IS THE REPT CHAR A CTL
         BNE   LOOPINS           GOOD NO INSERT IT
         BAL   4,GETNEXT         WHAT IS THE UNCTL CHAR
         STC   8,TEMPCHR         PUT IN MEMORY
         CLI   TEMPCHR,C'J'      IS IT A LINEFEED
         BE    WRITEBLK          WRITE THIS AND BLANK LINES
         CLI   TEMPCHR,C'#'      IS THIS A LOUSY # SIGN
         BE    LOOPINS           WELL WE WILL KEEP IT
         IC    8,=X'FF'          CHANGE IT TO FLAG CHAR
LOOPINS  STC   8,RECORD(10)      PUT IT IN THE RECORD
         LA    10,1(10)          GO UP BY 1
         BCT   7,LOOPINS         KEEP DOING IT FOR COUNT IN 7
         B     LOOPCHR           GO FOR MORE
WRITEBLK AH    10,=H'4'          MAKE THE UNIVAC V RECORD LENGHT
         STH   10,RECLEN         PUT IN RECORD
         MVC   RECFIL,=C'   '    AND BLANKS
         PUT   FILEFCB,RECLEN    WRITE IT
         BCT   7,LOOPBLK         GO FOR MORE(REPT OF 1 LOOSER)
         B     LOOPCHR 
LOOPBLK  PUT   FILEFCB,BLKREC    WRITE A PREFORMATTED BLANK REC
         BCT   7,LOOPBLK         GO BACK FOR MORE
         B     LOOPCHR           GO FOR MORE CHARS.  
***********************************************************
** ROUTINE (GETNEXT) TO GET THE NEXT CHARACTER FROM INPUT**
**  IF NECESSARY IT WILL ACK THE LAST PACKET AND GET NEXT**
***********************************************************
GETNEXT  CR    9,11              ARE THERE MORE IN BUFFER
         BL    TAKENEXT          YES GO GET THE NEXT CHAR
ACKPACK  MVC   PKASEQ,PKSEQ      MOVE THE SEQ NUMBER TO ACK
         LA    1,=A(PKACK,PACKET)
         L     15,=V(PACKETIO)   GO FOR ANOTHER PACKER
         BALR  14,15
         CLI   PKTYP,C'E'
         BE    ERRCLS
         SR    9,9               SET POINTER TO BEG OF PACKET
         IC    11,PKLEN          PUT LENGTH IN 11
         SH    11,=H'3'          DECREMENT FOR LEN,TYP,SEQ
TAKENEXT CLI   PKTYP,C'D'        IS THIS A DATA PACKET
         BNE   ENDFILE           YES SEND A ^B TO END FILE
         IC    8,PKDAT(9)        GIVE HIM THE CHARACTER
         LA    9,1(9)            INCREMENT DATA POINTER
         BR    4                 GO BACK TO CALLER
ENDFILE  IC    8,=X'02'          GIVE HIM A ^B
         BR    4                 AND GO BACK
***********************************************************
** ROUTINE ON END OF FILE                                **
***********************************************************
PROCEND  LTR   10,10             IS ANYTHING IN BUFFER
         BZ    SKIPWRT           NOTHING TO WRITE
         AH    10,=H'4'          ADD FOR V TYPE REC
         STH   10,RECLEN         PUT IN THE RECORD
         MVC   RECFIL,=C'   '    PUT IN BLANK FOR FILL
         PUT   FILEFCB,RECLEN    AND WRITE IT TO THE FILE
SKIPWRT  CLOSE FILEFCB           CLOSE THE FILE
         CLI   PKTYP,C'Z'        IS THIS A REAL END OF FILE
         BNE   RETURN            DONT KNOW WHAT ELSE IT IS  
         MVC   PKASEQ,PKSEQ      ACK THE END OF FILE
         LA    1,=A(PKACK,PACKET)
         L     15,=V(PACKETIO)   GET THE NEXT PACKET
         BALR  14,15
         CLI   PKTYP,C'E'
         BE    RETURN
DONEXT   CLI   PKTYP,C'F'        IS THIS A NEW FILE HEADER
         BE    SKIPINI           START ANOTHER FILE
         CLI   PKTYP,C'B'        IS THIS A BREAK IN TRANS
         BNE   RETURN
         MVC   PKASEQ,PKSEQ      GET READY TO ACK BREAK
         LA    1,=A(PKACK,PACKET)
         L     15,=V(PACKETIO)
         BALR  14,15
RETURN   IC    11,PKLEN          GET THE LENGTH OF PACKET
         BCTR  11,0              DECREMENT BY 1
         EX    11,MOVEBK         MOVE IT BACK (REM REG 2)
         L     13,SAVE+4         GET ADDRESS OF OUT REGS
         LM    14,12,12(13)      RESTORE THE REGISTERS
         SR    15,15             ALL IS OK
         BR    14                BACK WE GO TO CALLER
BADOPN   LA    1,=A(BADPK,PACKET)
         L     15,=V(PACKETIO)
         BALR  14,15
         B     RETURN
ERRCLS   CLOSE FILEFCB
         B     RETURN
ABORT    TERMD 
         LTORG
SAVE     DS    18F
TEMPCHR  DS    CL1
MOVEBK   MVC   0(1,2),PACKET
TESTCTL  CLI   CTLCHR,X'00'
TESTREPT CLI   REPTCHR,X'00'
TESTEND  CLI   ENDCHR,X'00'
MOVELCL  MVC   PACKET(0),0(2)
MOVENAME MVC   FILEFCB+X'2E'(1),PKDAT
CTLCHR   DC    C'#'
REPTCHR  DC    C'_'
ENDCHR   DC    X'02'
BADPK    DC    YL1(ENDBAD-*)
         DC    X'00'
         DC    C'E'
         DC    C'OPEN FAILED FOR OUTPUT FILE'
ENDBAD   EQU   *
PACKET   DS    0F
PKLEN    DS    XL1
PKSEQ    DS    XL1
PKTYP    DS    XL1
PKDAT    DS    CL150
PKACK    DS    0F
PKALEN   DC    X'03'
PKASEQ   DS    XL1 
PKATYP   DC    C'Y'
BLKREC   DC    H'5'
         DC    C'    '
EXPRM    EXLST COMMON=BADOPN,OPENER=BADOPN
FILEFCB  FCB   FCBTYPE=SAM,LINK=KRMFL,RECFORM=V,EXIT=EXPRM
RECLEN   DS    H
RECFIL   DS    CL2
RECORD   DS    CL2000
         END
