*COMDECK /PUTDSQ/ 
          SST 
          B1=1
*#
*1CD  PUT$SQ
*0D   PURPOSE 
*0        TRANSFER A SPECIFIED NUMBER OF CHARACTERS FROM THE USER 
*         WORKING STORAGE AREA TO THE CIRCULAR BUFFER.
*0D   CALL
*0                  SB6       RETURN-ADDRESS. 
*                   EQ        =XPUT.SQ
*0D   PARAMETERS
*         A0        FIT ADDRESS.
*         B1        1.
*         B6        RETURN ADDRESS. 
*         WSA       FWA OF USER WORKING STORAGE AREA (WHERE TO GET DATA)
*         RL        RECORD LENGTH (PUT).
*         PTL       PARTIAL TRANSFER LENGTH (PUTP). 
*         EX        USER ERROR ADDRESS. 
*0D   ACTION
*0        ON FIRST CALL FOR EACH FILE, LOAD RECORD TYPE AND BLOCK TYPE
*         CAPSULES IF NECESSARY AND ALLOCATE BUFFER IF NOT SUPPLIED.  ON
*         ALL CALLS, SAVE THE RETURN ADDRESS.  IF THE PREVIOUS
*         OPERATION WAS A GET, SKIP FORWARD, OR SKIP BACK, BRANCH TO
*         *WAR.SQ* TO PROCESS THE WRITE-AFTER-READ CONDITION. 
*         CHECK FOR EXCESS DATA. FLUSH E-BLOCKS IF NECESSARY AND FORM 
*         W-CONTROL WORD FOR W-RECORDS.  PUT THEN CALCULATES THE NUMBER 
*         OF CHARACTERS IN THE CIRCULAR BUFFER FROM THE CURRENT PSEUDO- 
*         IN POINTER (*PIN*) TO EITHER *OUT*, *BLP*, OR *LIMIT*, WHICH- 
*         EVER WILL BE ENCOUNTERED FIRST. IF THAT NUMBER IS GREATER THAN
*         OR EQUAL TO THE NUMBER THE CALLER WISHES TO WRITE (*RL* OR
*         *PTL*)  *MOVE$RM* IS CALLED TO TRANSFER DATA FROM THE USER'S
*         *WSA* TO THE CIRCULAR BUFFER.  IF THE USER WISHES TO WRITE
*         MORE CHARACTERS THAN ARE AVAILABLE IN THE BUFFER, *MOVE$RM* 
*         IS CALLED TO MOVE THE AVAILABLE NUMBER OF CHARACTERS, A JUMP
*         IS TAKEN TO EITHER *LTB*, *GNB*, OR *PDO* TO MAKE MORE SPACE
*         AVAILABLE IN THE BUFFER BY EITHER UPDATING *IN* FROM *LIMIT*
*         TO *FIRST*, BY STARTING A NEW BLOCK (AND WRITING A BLOCK
*         CONTROL WORD IF APPLICABLE), OR BY ISSUEING A CIO CALL TO 
*         OUTPUT DATA, THE AVAILABLE NUMBER OF CHARACTERS IS RE-
*         CALCULATED, AND THE ABOVE PROCEDURE IS CONTINUED UNTIL ALL
*         THE REQUESTED DATA IS MOVED.  UPON EXIT, PUT ADDS PADDING TO
*         K AND E BLOCKS IF NECESSARY AND TRIES TO KEEP THE I/O GOING 
*         BY ISSUEING A CIO CALL, IF APPROPRIATE. 
*0D   REGISTERS USED
*0        ALL 
*0D   OTHER CODE REQUIRED 
*         PROGRAMS- CTL$RM
*         MACROS-   CAP.RM,OFF.RM,SAVE,RESTORE,F.RM,SET.RM,IC.SQ
*                   ON.RM,INC.RM,RCL.RM,BUFINC,MESSAGE,SYSY,BUFSP 
*0D   NARRATIVE DESCRIPTION 
*#
 DIVBFS   MACRO     REG 
          A_REG     2              1/4
 DIVBFS   ENDM
 BLANKS   DATA      10H 
  
 P        ERRNZ     PUT$SQ-RTABLE-#PGPLSZ# PASSLOC TABLE MOVED
 RTABLE   BSS 
#CSWPE#   EQU       1 
#FECH#    MICRO     1,,/0,00,03,11D,1,1/        TOP BITS OF FEC 
 #.C#     MICRO     2-#PLAO#,,/,/ 
          ECHO      1,CAP=(W,-,R,Z,DT,DT,EK,-,CI"#.C#"),NTRY=("#.C#"W,F,
,R,Z,D,T,K,U,C) 
          VFD       42D/0LPUT$CAP,18D/=YPUT$NTRY
 EK       EQU       RTABLE+6
 CI       EQU       RTABLE+8
  
 PUT$SQ   CAP.RM
*#
*0        LOAD RECORD TYPE CAPSULE AND SET UP RTJP.  LOAD BLOCK TYPE
*         CAPSULE.  ALLOCATE BUFFER.  SET FOJP TO PTGO$SQ.
*#
          F.RM      RT,A2,+RTABLE+#PLAO#
          RJ        =XRM$BLD       LOAD RT ROUTINE
          SET.RM    RTJP,B5        ADDR OF RT CODE
          SA2       CI+#PLAO# 
          CI.SQ     LDBT
          SA2       EK+#PLAO# 
 LDBT     RJ        =XRM$BLD       LOAD BT ROUTINE
          SET.FOJ   P,B4,PTGO$SQ
          NZ        B3,=XRM$ABUF   ALLOCATE BUFFER, RETURN TO WEOX
          SB3       B4             RETURN TO PUT.SQ 
          EQ        =XRM$ABUF 
 PTGO$SQ  SPACE     4,8 
          CAP.RM
          ENTRY     PTGO$SQ 
 PTGO$SQ  BSS 
          S"ERRREG" 113B           CANNOT PUT AFTER PUTWR,GETWR 
          ON.RM     WSI,=XERR$RM   ERROR IF SBF FILE
          SAVE
*#
*0        IF LAST OPERATION WAS A GET OR SKIP, GO TO WAR$SQ  (WRITE 
*     AFTER READ) TO ADJUST POINTERS AMD FILE POSITION FOR
*     OUTPUT. IF LAST OPERATION WAS NOT A PUT, REPLACE, WEOR, 
*     OR ENDFILE, SET BLOCK LENGTH = MBL TO START A NEW BLOCK.
*     LOAD PIN INTO B3. 
*#
          F.RM      LOP,B2
          SB5       #PU#
          EQ        B2,B5,PUTPUT   IF PRECEDED BY ANOTHER PUT 
          TITLE     IF LOP WAS NOT PUT
*     PREVIOUS OPERATION WAS NOT PUT                                CHG 
          NONEOF    B2,(#GE#,#SF#,#SB#),PEACE 
          SET.RM    LVL,0          CLEAR LVL SO AS NOT TO MESS UP FLUSH 
          SB6       ENDWAR                                          CHG 
 GOTOWAR  BSS       0 
          LGO.RM    PLWAR 
  
 PLWAR    FAKEPL    =XWAR$SQ       STATIC- FORCE LOAD, DYN- ADDR
  
 PEACE    BSS       0                                               CHG 
          F.RM      MBL,2            RECORD IS WRITTEN-SEE CODE AT GET1 
          SOL*10    X2,+           ALLOW FOR S/L CONTROL WORD 
          SET.RM    BL,X2 
 ENDWAR   BSS       0                                               CHG 
          SET.RM    STM,0 
          F.RM      PIN,B3
          BX2       0 
          NE.RM     RT,#ZT#,SETWCR,B2 
          SX2       B1             RT=Z FLAG
 SETWCR   SET.RM    WCR,X2         W-CONT ADDR .OR. RT=Z FLAG 
          SET.RM    LOP,#PU#
          CI.SQ     PUTPUT
          SB3       B3+B1          SAVE ROOM IN BUFR FOR SLCW FOR BT=K/E
          SET.RM    PIN,B3         SAVE ROOM IN BUFR FOR SLCW FOR BT=K/E
          SET.RM    BL,10          COUNT SLCW IN BLOCK LENGTH 
          TITLE     SETUP 
 PUTPUT   BSS       0                                               MAIN
 36B      PUT.IN    0 
          SET.RM    UCP,0 
          F.RM      FP                                              MAIN
          NZ        X1,CRLEQ                                        MAIN
*#
*         IF A PUTP IS FOLLOWED BY A PUT, THE RECORD INITIATED BY THE 
*     PUTP IS TERMINATED (FLSH$SQ) AND THE RECORD INDICATED BY THE PUT
*     IS WRITTEN
*#
          SB6       CRLEQ 
          OFF.RM    PPT,=YFLSH$SQ 
          F.RM      PIN,B3
*#
*         IF PUTP, INCREMENT RL BY PTL AND COMPARE TO MRL. IF RL>MRL
*     AND WE ARE NOT DOING W-CONTINUATION (RRL"0), GO TO ERR$RM TO
*     ISSUE 142 ERROR. IF PUTP TERMINATE, SET RRL=RL SINCE THIS IS
*     LAST PIECE. GO TO MAMAC TO MOVE THE DATA FROM WSA TO THE BUFFER.
*#
          F.RM      RPTL,2
          F.RM      RL             RUNNING TOTAL CHAR COUNT OF ALL PUTPS
          IX7       X2+X1          RUNNING TOTAL RECORD LENGTH
          F.RM      RRL,3,X3,,6 
          IX1       X3-X7          REQUESTED RL - RUNNING RL
          S"ERRREG" 141B+1S17      EXCESS DATA IS FATAL ON PUTP 
          PL        X1,PTCM        PUTP (0=LAST)
          NZ        X3,=YERR$RM    IF PAST RRL AND RRL NOT 0
          OFF.RM    TRM,PTCM       JUMP IF NOT PUTP TERMINATE 
          SET.RM    RRL,X7,6
PTCM      BSS       0 
          F.RM      MBL 
*                   RRL            INITIAL VALUE STILL IN X3
          IX3       X3+X1 
          F.RM      RT,X1,-#WT# 
          IX3       X3+X1 
          ZR        X3,=YPUT$WI    IF RT=W AND MBL=0 AND RRL=0 NEED WCW 
          EQ        PTCM$SQ 
 CRLEQ    BSS       0                                               MAIN
*#
*         IF THE FP IS EOR AND THE CURRENT OPERATION IS A PUTP TERM,
*     SET RL=PTL TO INDICATE COMPLETE RECORD IS BEING WRITTEN BY ONE
*     PUTP TERM 
*#
          OFF.RM    PPT,DORLEQ
          F.RM      RT,B2 
          NONEOF    B2,(#ZT#,#FT#),NOFL 
          F.RM      FL,3
          F.RM      RT,X1,-#FT#    IF RT=F,SET RRL=FL 
          ZR        X1,SETRRL 
          F.RM      RRL,X1
          ZR        X1,SETRRL      IF RT=Z AND RRL=0,SET RRL=FL 
          EQ        SETRL          IF RT=Z AND RRL"0,DO NOT CHANGE RRL
 NOFL     BSS       0 
          F.RM      RT,X1,-#RT#    IF RT = R, PUTP IS ILLEGAL 
          NZ        X1,PUTP.OK
          S"ERRREG" 256B+1S17 
          EQ        =YERR$RM
 PUTP.OK  BSS       0 
          OFF.RM    TRM,CHKRL 
          F.RM      RPTL,3
          EQ        SETRRL
 CHKRL    BSS       0 
          SA1       A0+7
          SA2       X1-1
          LX2       59-25 
          NG        X2,SETRL       IF RL SPECIFIED ON MACRO CALL, SKIP
          F.RM      RL,3
          F.RM      RT,B4 
          NONEOF    B4,(#DT#,#TT#),SETRRL 
          F.RM      RPTL,3
          F.RM      LL,X2,+1       FETCH LL,ADD 1,PUT RESULT IN X2
          F.RM      LP,1           FOR RT=D/T,RPTL MUST BE GQ LP+LL+1 
          IX2       X2+X1 
          IX1       X3-X2 
          PL        X1,DORLEQ      RL MUST BE DETERMINED(INFO IN RECORD)
          S"ERRREG" 034B+1S17 
          EQ        =YERR$RM
 SETRRL   BSS 
          SET.RM    RRL,X3
 SETRL    BSS       0 
*#
*         INCREMENT THE RECORD COUNT, ZERO RL (RL WILL COUNT FROM 
*     0 TO RL), JUMP TO PUT RECORD-TYPE CAPSULE (RTJP) TO GET 
*     REQUESTED LENGTH IN X2, STORE IT IN RRL AND COMPARE IT TO 
*     MRL. IF RRL>MRL, GO TO ERR$RM TO ISSUE 142 ERROR (EXCESS DATA). 
*#
 DORLEQ   BSS       0 
          SET.RM    RL,0
          INC.RM    RC,1                                            MAIN
          SB5       GOTRRL         RETURN ADDRESS 
          F.RM      RTJP,B4 
          STO.REG 
          JP        B4             GO FIND THE RECORD LENGTH        MAIN
 GOTRRL   BSS       0 
          PUT.IN
          BX2       X3             MVL - NEEDED BY PUT$E
          F.RM      PIN,B3
* 
*         CHECK FOR VALID RL
* 
          F.RM      RT,B4 
          F.RM      MRL            TO COMPARE RL AND RRL
          SX7       =YRM$LVL
          NG        X7,CHK.MRL
          ANYOF     B4,(#FT#,#ZT#),MRL.CHK MRL=0 IS NOT LEGAL FOR RT=F/Z
CHK.MRL   BSS       0 
          ZR        X1,RLOK        IF MRL/FL=0,DONT CHECK CALCULATED RL 
 MRL.CHK  BSS       0 
          IX7       X1-X3 
          PL        X7,RLOK 
          S"ERRREG" 142B           EXCESS DATA
          OFF.RM    PPT,NON.FTL 
          S"ERRREG" 141B+1S17      EXCESS DATA IS FATAL TO PUTP 
 NON.FTL  BSS       0 
          EQ        =YERR$RM
*         CHECK AGAINST MNR DELETED BECAUSE OF RT=Z 
 RLOK     BSS       0 
          F.RM      RT,B2 
          NONEOF    B2,(#DT#,#TT#),RL.OK
          SET.RM    RRL,X3         SET RRL TO CALC RL,IF RRL=0
 RL.OK    BSS       0 
          OFF.RM    PPT,ISPUT                                       MAIN
          F.RM      RPTL,2         NEEDED BY PTCM$SQ(PARTIALS),PUT$E
 ISPUT    BSS       0                                               MAIN
*#        FOR E-BLOCKS, GO TO PUT$E TO SEE IF THE RECORD WILL FIT 
*     IN THE CURRENT BLOCK. FOR W-RECORDS, GO TO PUT$WI TO FORM 
*     THE W-CONTROL WORD. 
*#
          F.RM      BT,B2,-#ET# 
          EQ        B2,B0,=YPUT$E  CHECK IF REC FITS IN CURRENT BLOCK 
          NE.RM     RT,#WT#,PTCM$SQ 
          EQ        =YPUT$WI
 MAMAC    TITLE     MOVE AS MUCH AS CONVENIENT
*#
*         MAMAC (MOVE AS MUCH AS CONVENIENT).  FIRST FIND OUT HOW MANY
*     CONTIGUOUS CHARACTERS ARE FREE IN THE BUFFER.  THIS IS DONE BY
*     FINDING OUT WHETHER BL CHARS, LIMIT, OR OUT-1 WILL BE HIT NEXT. 
*     THEN MOVE UP TO THAT MANY CHARACTERS.  IF THAT WILL DO, CONTINUE
*     WITH THE MAIN FLOW.  IF NOT, THEN GET THE NEXT BLOCK (GNB), LOOP
*     THE BUFFER (LTB), OR PUSH DATA OUT (PDO) AND THEN REPEAT. 
*         (IGNORE REFERENCES TO A2 BELOW:)
*             INPUT..  B1,A0,A2,OWF=0,B3=PIN,X2=MVL 
*             OUTPUT.. B1,A0,A2,B3=NEW PIN
*             UPDATED..UWD,UBT,PIN,BCC,PRL
*         PTG1$SQ (GET ONE WORD). PTG1$SQ USES MOST OF CODE OF MAMAC
*     EXCEPT FOR THE MOVE CODE.  IT GETS A WORD FROM THE BUFFER AND 
*     LETS THE CALLER FILL IT IN. 
*             INPUT..  B1,A0,A2,B6=RETURN,OWF=ON,B3=PIN 
*             OUTPUT.. B1,A0,A2 
*                      B3 IS LOGICALLY INCREMENTED BY 1 
*     REGISTER USAGE IN MAMAC.. 
*         X6=MVL ACROSS MOVE.RM 
*         X3 = (WSA),(UWD)
*         B6 USED FOR GET1.SQ CALLS BUT NOT FOR MOVE CALLS
*#
 PTG1$SQ  BSS       0 
          F.RM      STM,X6         WHEN TO STOP MOVE
          F.RM      BL,X1 
          IX4       X1-X6          -(AMOUNT AVAILABLE)
          PL        X4,GETSP       GO GET SPACE IF NONE AVAILABLE 
          BX4       -X4 
  
 GOT1     BSS 
          SB3       B3+B1 
          INC.RM    BL,10 
          JP        B6             PTG1$SQ EXIT 
  
 GETSP    BSS 
          F.RM      OUT,B2
          SB4       B2-B1          CANNOT GO PAST OUT-1 ON WRITE
          SB5       PDO            PUSH-DATA-OUT
          LT        B3,B2,BUFSP    JUMP IF OUT IS NEXT POINTER TO BE HIT
          F.RM      LIMIT,B4         OTHERWISE LIMIT IS NEXT PTR HIT
          SX7       B2
          F.RM      FIRST            UNLESS OUT=FIRST,THEN ITS LIMIT-1
          IX7       X7-X1          OUT-FIRST
          SB5       LTB            LOOP THE BUFR IF LIMIT IS NEXT PTR 
          NZ        X7,BUFSP       JUMP IF OUT"FIRST
          SB4       B4-B1          OUT=FIRST,WILL HIT OUT-1 NEXT=LIMIT-1
          SB5       PDO            PUSH DATA OUT IF OUT IS NEXT PTR 
 BUFSP    BSS       0 
          F.RM      BCC 
          SX4       B4-B3          AVAILABLE SPACE IN BUFFER
          IX6       X4+X4 
          LX4       3 
          IX4       X6+X4 
          IX4       X4-X1          *10-BCC
          F.RM      MBL,X6
          F.RM      BL,5
          ZR        X6,ENDSP       IF BLOCK IS INDEFINITELY LONG (BT=C) 
          SOL*10    X5,-           ALLOW FOR S/L CONTROL WORD 
          IX7       X6-X5          MBL-BL (REMAINING CHARS IN BLOCK)
          IX6       X4-X7          AVAIL BUF SPACE - (MBL-BL) 
          NG        X6,ENDSP
          SB5       NEWBLOCK
          BX4       X7
 ENDSP    BSS       0 
*     HERE IS SOME CODE THAT IS ALMOST USELESS.  IT INSURES THAT THE
*     AMOUNT TO MOVE IS LESS THAN 2**17.  IT WAS OPTIMIZED FOR SPACE. 
*     TWO CASES:             N<2**16   N\2**16
          MX7       -16 
          BX1       X7*X4       0      [N/2**16]"0
          BX7       -X7*X4      N      0@MOD(N,2**16)<2**16 
          AX1       8           0      2**8@[N/2**16]/2**8@2**16
          IX4       X1+X7       N      2**8 @ X4 < 2**17
*     SET NEW STOP-MOVE (STM) VALUE.
          IX6       X5+X4          BL + AVAIL 
          SET.RM    STM,X6,,,CHOP 
*     WHEN BL CYCLES, STM MUST BE KEPT GREATER; HENCE SET STM B4 TEST 
          F.RM      OWF            OWM+OWN
          ZR        X4,NOTYET      IF NO SPACE AVAILABLE
          ZR        X1,WILLMOVE    IF PTCM$SQ 
          EQ        GOT1           IF PTG1$SQ 
  
 NOTYET   BSS 
          NZ        X1,JPB5        IF PTG1$SQ 
          SET.RM    MVL,X2
          SET.RM    UWD,X3
          JP        B5             PDO OR NEWBLOCK OR LTB 
  
 JPB5     BSS 
          SAVE
          JP        B5             PDO OR NEWBLOCK OR LTB 
  
*     CODE UNIQUE TO MAMAC
 PTCM$SQ  BSS 
          SET.RM    OWF,0                                           MAIN
 .MD      IFNE      #BETA#,0
          F.RM      WSAD,3
 .MD      ELSE
          F.RM      WSA,3 
 .MD      ENDIF 
          F.RM      STM,X6         WHEN TO STOP MOVE
          F.RM      BL,X1 
          ZR        X2,CONTINUE    IF NOTHING TO MOVE 
          IX4       X1-X6          -(AMOUNT AVAILABLE)
          PL        X4,GETSP       GO GET SPACE IF NONE AVAILABLE 
          BX4       -X4            AMOUNT AVAILABLE 
  
 WILLMOVE BSS       0                                               MAIN
          IX6       X4-X2          HAVE-WANT                        MAIN
          NG        X6,MOVENOW     TO BREAK UP MOVE 
          ZR        X2,CONTINUE    IF NOTHING TO DO 
          BX4       X2             MOVE THE WHOLE RECORD            MAIN
 MOVENOW  BSS       0                                               MAIN
          SB4       X4                                              MAIN
          INC.RM    RL,X4          KEEP RUNNING TOTAL CHAR COUNT PER REC
          SX4       B4             RESTORE X4 SHIFTED BY INC.RM 
          INC.RM    PTL,X4
          SX4       B4             RESTORE X4 SHIFTED BY INC.RM 
          INC.RM    BL,X4          INCREMENT NO. CHARS IN CURRENT BLOCK 
          F.RM      BCC,B5
.MD       IFNE      #BETA#,0
          F.RM      WSAB,X5 
          LX5       21
          BX3       X3+X5          SET LCM FLAG ON SOURCE ADDRESS 
.MD       ENDIF 
          SX5       B3
          F.RM      UCP,B3
          SB6       MOVETHRU                                        MAIN
          EQ        =YMOVE$RM      GO MOVE THE DATA 
 MOVETHRU BSS       0                                               MAIN
          SB3       X5
          SET.RM    BCC,B4                                          MAIN
          PL        X6,CONTINUE    THIS MOVE FINISHED THE RECORD    MAIN
          SET.RM    UCP,X4
          BX2       -X6            REMAINING MOVE LENGTH
          EQ        GETSP 
          SPACE     4,8 
 NEWBLOCK CI.SQ     =YPBNB$SQ 
          SX6       173B+1S17      MBL .LT. RB*FL 
          EQ        =YERR$RM
 LTB      TITLE     LOOP THE BUFFER 
*#
*         LTB (LOOP THE BUFFER).  WHEN LIMIT IS ENCOUNTERED, SET PIN
*     TO FIRST AND MOVE SOME MORE.
*         PLAN ON KICKING THE I/O (USING KIA) AT
*            IN-BFS/4.
*#
 LTB      BSS       0                                               LTB 
          F.RM      FIRST,B3                                        LTB 
          SET.RM    BCC,0                                           LTB 
          ON.RM     TAPE,PTLP$SQ
          F.RM      BFS,X3
          F.RM      OUT 
          DIVBFS    X3
          IX3       X1-X3 
          SX3       X3+25B         ADJUST KIA TO AVOID UNNECESSARY CIO
          SET.RM    KIA,X3,,,CHOP 
 PTLP$SQ  BSS       0 
          F.RM      OWF                                             M 
          NZ        X1,CONTG                                        M 
          F.RM      UWD,3 
          F.RM      MVL,2 
          EQ        GETSP 
 CONTG    RESTORE                                                   GET1
          EQ        GETSP 
 PDO      TITLE     PUSH DATA OUT 
*#
*         PDO (PUSH DATA OUT).  AT THIS POINT THE BUFFER HAS BEEN FOUND 
*     TO BE FULL.  SO WAIT FOR OUT TO MOVE OR THE IO TO FINISH.  IF OUT 
*     DID NOT MOVE THEN CHECK FOR I/O ERRORS AND END-OF-VOLUME.  THEN 
*     ISSUE A CIO REQUEST AND WAIT SOME MORE.  WHEN THERE IS FINALLY
*     SOME ROOM, GO MOVE SOME MORE. 
*#
 BUSY     RCL.RM    1,COUNT 
 PDO      BSS       0                                               PDO 
          BUFINC    B,3,1,4                                         PDO 
          SA2       A0             LOAD FET BEFORE OUT
          F.RM      OUT                                             PDO 
          BX7       X1-X4                                           PDO 
          NZ        X7,PTLP$SQ     IF OUT MOVED 
          LX2       59                                              PDO 
          NG        X2,NOTBUSY
          OFF.RM    RCLA,BUSY 
          RCL.RM    A0,AUTO        IF ONLY BLOCK IN BUFFER
          F.RM      FECH
          NZ        X1,ERR
          EQ        PTLP$SQ        ASSUME OUT MOVED 
 NOTBUSY  BSS 
          F.RM      FEC 
          ZR        X1,CIOWT
          SX2       X1-2
          SX4       3 
          ZR        X2,CLSVP       IF EOV, CLOSE VOLUME 
          BX1       -X4*X1         REMOVE EOV/EOI BITS
          ZR        X1,CIOWT       JUMP IF NO OTHER ERRORS
          SX4       X1-4
          ZR        X4,PARERR      IF PARITY ERROR
          SX6       721B+1S17 
 .OS      IFC       EQ,/"OS.NAME"/KRONOS/ 
          SX2       X1-22B
          NZ        X2,=YERR$RM    IF NOT EXTENDED ERROR CODE 
          SA1       A0+6
          MX7       60-12 
          BX1       -X7*X1         DETAILED ERROR STATUS
          SX2       X1-4007B       CHECK FOR TRACK LIMIT
          NZ        X2,=YERR$RM 
          MX7       1 
          SA1       A0+B1 
          LX7       45+1           UP BIT 
          BX4       X7*X1          GET UP FLAG
          BX7       -X7*X1         MASK OUT UP FLAG 
          SA7       A1
          SX7       37001B
          SA1       A0
          BX2       -X7*X1         REMOVE ERROR FLAGS AND COMPLETE BIT
          SYSY      X2,R           REISSUE LAST CIO CALL + AUTO RECALL
          F.RM      FECH
          NZ        X1,ERR
          SA1       A0+B1 
          BX7       X4+X1          RESET UP FLAG
          SA7       A1
          EQ        PDO 
 .OS      ELSE
          SX2       X1-10B
          NZ        X2,=YERR$RM 
          RCL.RM    -3777B,COUNT        WAIT  1000 MILLISECONDS 
          ON.RM     NOSP,TRYRITE   IF MSG ALREADY OUTPUT
          MESSAGE   NOSPACE,LOCAL,RECALL   ISSUE FLASHING MSG TO B-DISP 
          SET.RM    NOSP,1
          EQ        TRYRITE        TRY AGAIN TO WRITE 
.OS       ENDIF 
 PARERR   BSS       0 
          S"ERRREG" 6140B+1S17     SET SES, NO CLOSE VOLUME 
 NOSBE    IFC       EQ,/"OS.NAME"/SCOPE / 
          OFF.RM    SOL,NOCLV      IF SCOPE DEVICE
          F.RM      ECD,X1,-101B   PICK UP EXTENDED ERROR CODE
          ZR        X1,NOCLV       IF ECD IS NO CLOSE VOLUME, SKIP
          S"ERRREG" 5140B          ELSE, SET SES, CLOSE VOLUME OK 
 NOSBE    ENDIF 
 NOCLV    BSS       0 
          SET.RM    PEF,1 
          EQ        =YERR$RM
 CLSVP    BSS       0              CLOSE VOLUME                     CLSV
*     SAVE ALL REGISTERS                                            CLSV
          SET.RM    PIN,B3                                          CLSV
          STO.REG 
          CLSV$SQ   PUT 
          PUT.IN
*     RESTORE ALL REGISTERS                                         CLSV
          F.RM      PIN,B3                                          CLSV
          SET.RM    LOP,#PU#       RESTORE LAST OPERATION 
 CIOWT    BSS       0                                               PDO 
          F.RM      NOSP
          PL        X1,TRYRITE
          SET.RM    NOSP,0
          MESSAGE   BLANKMSG,BDISP,RECALL 
 TRYRITE  BSS       0 
          ON.RM     SOL,CWNS
          F.RM      WCR,X2,-2      ALLOW FOR RT=Z FLAG
          PL        X2,CWNS        IF W-CONTINUATION
          F.RM      BT,X2,-#CT# 
          ZR        X2,SETIN
          SX2       X2+#CT#-#IT#
SETIN     BSS       0 
          NZ        X2,CWNS 
          SET.RM    IN,B3 
 CWNS     BSS       0 
          F.RM      SOL                                             PDO 
          SX2       264B-014B                                       PDO 
          AX1       59                                              PDO 
          BX2       X1*X2                                           PDO 
          SYSY      X2+014B 
*#
*         SINCE WE HAVE TO KICK THE I/O, PERHAPS THE CP IS FASTER THAN
*     THE I/O.  SO WE WILL KICK THE I/O SOONER (AT LEAST 1/2 BUFFER, OR 
*     100B).  (DO NOT WORRY ABOUT BUFFER LOOPING, KIA IS RESET AT LTB.) 
*#
          F.RM      BFS,X4,+100B
          AX4       1 
          SX4       B3+X4 
          SET.RM    KIA,X4,,,CHOP 
          EQ        PDO                                             PDO 
 NOSPACE  DATA      10H NO SPACE
 BLANKMSG DATA      C*     *
          TITLE     FINISH UP 
*#
*         AFTER THE RECORD HAS BEEN MOVED, THE FOLLOWING NEEDS TO BE
*     DONE. IF TRM SPECIFIED, SPECIAL CASE CERTAIN BT/RT AS DESCRIBED 
*     BELOW. IF IT WAS A W-CONTINUATION PUTP (RRL=0) WITH TRM OFF,
*     OR A NORMAL PUTP WITH RL<RRL, SET FP TO MID-RECORD AND EXIT.
*     IF IT WAS A NORMAL PUT OR IF TRM IS ON OR IF RL\RRL, SET FP TO
*     EOR. IF DOING W-CONTINUATION RECORDS, GO TO PUT$WT TO TERMINATE 
*     THE W-RECORD. IF RT=Z, GO TO PUT$ZT TO TERMINATE THE Z-RECORD.
*     IF BT=K, GO TO PUT$K TO TERMINATE THE K-BLOCK IF IT CONTAINS
*     RB RECORDS. 
*#
 REC.MID  BSS       0 
          ZR        X5,REC.END     IF ZERO, THEN RRL .EQ. RL
          SET.RM    FP,0           SET FP TO MID-RECORD 
          EQ        PTEX$SQ        EXIT 
* 
 CONTINUE BSS       0 
          F.RM      RRL,3 
          F.RM      RL,2,X4        SAVE RL IN X4
          IX5       X3-X4          RRL-RL 
          SET.RM    FP,#EOR#
          S"ERRREG" 142B           EXCESS DATA
          OFF.RM    PPT,NOT.PPT 
          S"ERRREG" 141B+1S17      EXCESS DATA IS FATAL TO PUTP 
          ON.RM     TRM,REC.END    IF TERM ON, NO OTHER WAY OUT 
          ZR        X3,REC.MID     (R)RL GIVEN AS 0, REC STILL INCOMPLT 
          PL        X5,REC.MID     RECORD MAY NOT BE COMPLETED YET
 REC.END  BSS       0 
          NG        X5,=YERR$RM    RL .GT. RRL,THEREFORE EXCESS DATA
          ON.RM     TRM,RL.OK.
          S"ERRREG" 143B           INSUFFICIENT DATA
          NZ        X5,=YERR$RM    IF RL .EQ. RRL, REC TRANSFER GOOD
NOT.PPT   BSS       0 
          F.RM      MRL 
          ZR        X1,RL.OK.      IF MRL/FL=0,DONT CHECK DETERMINED RL 
          IX4       X1-X4          MRL-RL 
          PL        X4,RL.OK. 
          S"ERRREG" 142B           EXCESS DATA
          OFF.RM    PPT,NOT.FTL 
          S"ERRREG" 141B+1S17      EXCESS DATA IS FATAL TO PUTP 
 NOT.FTL  BSS       0 
          EQ        =YERR$RM
 RL.OK.   BSS       0 
          F.RM      WCR,B2         DOING W-CONT RECS IF WCR"0 
          EQ        B2,B1,=YPUT$ZT RT=Z FLAG
          SET.RM    CRF,0 
          NZ        B2,=YPUT$WT    IF W-CONTINUATION
 PTRT$SQ  BSS       0 
          F.RM      BT,B2,-#KT# 
          EQ        B2,B0,=YPUT$K  JUMP TO PAD OUT K-BLOCK
* 
 PTIO$SQ  TITLE     KEEP THE I/O GOING
*#
*         RIGHT BEFORE EXITING, SEE IF SOME I/O CAN BE STARTED.  ON S/L 
*     TAPES, SEE IF IN"OUT. ON SCOPE DEVICES WITH BT=I/C, SET IN TO 
*     PIN AND ISSUE CIO CALL IF THE BUFFER IS OVER 3/4 FULL.  ON
*#
 PTIO$SQ  BSS       0 
          F.RM      LIMIT,B2                                        SCP 
          NE        B2,B3,PINOKA                                    SCP 
          F.RM      FIRST,B3                                        SCP 
 PINOKA   BSS       0                                               SCP 
          ON.RM     SOL,KIOA
          F.RM      WCR,X2,-2      ALLOW FOR RT=Z FLAG
          PL        X2,KIOA        IF W-CONTINUATION
          SET.RM    IN,B3          FOR SCOPE ONLY 
 KIOA     F.RM      KIA,B2
          LT        B3,B2,PTEX$SQ  IF NOT TIME YET
          SX3       014B
          OFF.RM    SOL,KGSCOPE                                     MAIN
          F.RM      OUT,B4
          F.RM      IN,B2                                           SOL 
          EQ        B2,B4,PTEX$SQ  S/L, IN=OUT -- DO NOTHING
          SX3       264B                                            SOL 
 KGSCOPE  BSS       0              SCOPE DEVICES                    SCP 
          MX7       60-9
          SX1       B1                                              MAIN
          LX7       9                                               MAIN
          SA2       A0             FET
          IX7       X1-X7          777001B                          MAIN
          BX2       X7*X2                                           MAIN
          BX7       X2-X1 
          SA1       B1             RA+1                             MAIN
          BX2       X7+X1                                           MAIN
          NZ        X2,MOVKIA      SOMETHING BUSY, PUSH KIA ANYWAY
          SYSY      X3
MOVKIA    BSS       0 
          F.RM      BFS,X3
          SX1       B3+X3 
          DIVBFS    X3
          IX3       X1-X3 
          SX3       X3+25B         ADJUST KIA TO AVOID UNNECESSARY CIO
          SET.RM    KIA,X3,,,CHOP 
 PTEX$SQ  BSS       0 
          RESTORE                                                   MAIN
          SET.RM    PIN,B3                                          MAIN
          SET.RM    TRM,0          CLEAR THE TERMINATE FLAG FOR NEXT OP 
          BX7       X"XREG.RM"
          SA7       A0+"FWRD.RM"
          JP        B6             EXIT BACK TO USER                MAIN
*         IN -> S-TAPE CONTROL WORD 
*         PIN -> END OF DATA (SEE BCC)
*         BCC =0 .. NOTHING AT [PIN]
*         BCC "0 .. [PIN] HAS SOME DATA 
          TITLE     FLSH$SQ 
* 
*         ENTRY POINT FOR BUFFER FLUSHING 
* 
 FLSH$SQ  BSS       0 
          PUT.IN
*#
*         IF RT"W AND THE LAST OPERATION WAS ENDFILE, RETURN TO 
*     CALLER BECAUSE ENDFILE FLUSHED THE BUFFER.
*#
          EQ.RM     RT,#WT#,FL.RCL
          F.RM      LOP,X1,-#EN#   IF LOP=ENDFILE 
          ZR        X1,XIT         BUFFER HAS ALREADY BEEN FLUSHED
*#
*         RECALL THE FILE. IF RECORD DOES NOT END ON A WORD BOUNDARY
*     (BCC"0), BLANK FILL LAST WORD AND INCREMENT PIN (B3) BY 1.
*#
 FL.RCL   BSS       0 
          NE.RM     FP,0,PPTOK     IF NOT MID RECORD
          CRMEP     ES=144B,FNF=#YES# INCOMPLETE PARTIAL PUT SEQUENCE.
 PPTOK    BSS       0 
          RCL.RM    A0,AUTO 
          F.RM      FECH
          NZ        X1,ERR
          F.RM      PIN,1,B3
          F.RM      BCC,1 
          F.RM      LIMIT,3,B4
          ZR     X1,SKPINC
          IX1       X1+X1                   //      2*X1     //  (X1=BCC
          LX5       X1,B1                   //     +4*X1     // 
          IX1       X1+X5                   //     =6*X1     // 
          SB5       X1-1           OBTAIN  SHIFT COUNT
          MX1       1              ESTABLISH MASK 
          AX1       X1,B5          SHIFT FOR APPROPRIATE MASK 
          SA5       B3             FETCH CURRENT WORD 
          BX6       X5*X1          MASK VALUABLE INFORMATION
          SA5       BLANKS         FETCH A BLANK WORD 
          BX5       -X1*X5         MASK NECESSARY BLANK FILL
          IX6       X5+X6          DO THE BLANK FILLING 
          SA6       B3             STORE RESULT IN CURRENT WORD 
          SB3       B3+B1          INCREMENT PIN
SKPINC    BSS    0
          NE        B3,B4,PINLIM1  BR IF PIN NE LIMIT 
          F.RM      FIRST,1,B3     SET PIN = FIRST
 PINLIM1  BSS       0 
          F.RM      BL,4           NO. CHARS IN CURRENT BLOCK 
          SOL*10    X4,-           ALLOW FOR S/L CONTROL WORD 
*#
*         IF RT=W, CALL PUT$WF TO FLUSH W-RECORDS(WRITE A WCW SO
*     RECORD CAN BE BACKSPACED OVER). 
*#
          EQ.RM     RT,#WT#,=YPUT$WF  FLUSH W-RECORD
  
 PTFL$SQ  BSS 
          SB2       B0             SET FLAG FOR WEOS
          F.RM      SOL,1 
          NG        X1,SLCALL2     BR IF S/L DEVICE 
*#
*         FOR NON-S/L DEVICES, IF BLOCK LENGTH=0, EXIT. ELSE SET
*     IN=PIN, ISSUE CIO CODE 24B, AND EXIT. 
*#
          ZR        X4,XIT         SAFE NOW TO CHECK FOR EMPTY BUFFER 
          SB4       24B            WRITER FUNCTION CODE 
          SB2       B1             SET FLAG FOR WEOS
          EQ        WRITALL 
*#
*         FOR S/L TAPES, IF BLOCK LENGTH=0 AND IN=OUT, EXIT - THERE 
*     IS NOTHING TO WRITE. IF BLOCK LENGTH=0 BUT IN"OUT, SET IN=PIN,
*     ISSUE CIO CODE 264B, AND EXIT. IF BLOCK LENGTH"0, CONVERT IT
*     TO WORDS, USE THAT TO STORE S/L CONTROL WORD AT IN, SET IN=PIN
*     ISSUE CIO CODE 264B, AND EXIT.
*#
 SLCALL3  BSS       0 
          F.RM      IN,B3 
          SX1       B3
          F.RM      OUT,2 
          IX7       X2-X1 
          ZR        X7,XIT         IN=OUT, EXIT 
          EQ        WRITALL        ELSE, ISSUE WRITE
 SLCALL2  BSS       0 
          SB4       264B           WRITEN FUNCTION CODE 
          ZR        X4,SLCALL3     CHECK FOR EMPTY BUFFER 
          BX7       X4
          SB5       SLCHWR         RETURN ADDRESS 
          EQ        =YCHWR$RM      CONVERT CHARS TO WORDS 
 SLCHWR   BSS       0 
          SX4       X7
          AX7       18
          LX7       24
          BX7       X7+X4 
          F.RM      IN,5,A7,,2     STORE CONTROL WORD AT [IN] 
 WRITALL  BSS       0 
          RCL.RM    A0,AUTO 
          SET.RM    IN,B3,7,1      RESET IN 
          F.RM      FECH
          NZ        X1,ERR
 WRITAL1 BSS       0
          F.RM      LVL            LEVEL NUMBER 
          SYSY      B4,R,,1 
  
          F.RM      FECH
          NZ        X1,ERR
  
          F.RM      FEC 
          ZR        X1,XIT         IF NO EOV OR EOL 
          SX1       X1-2
          NZ        X1,ERR         IF NOT EOV (SHOULD NOT HAPPEN) 
          F.RM      IN,X2 
          F.RM      OUT 
          IX7       X2-X1          SAFETY CHECK FOR S TAPE
          ZR        X7,XIT         IF NO DATA LEFT
          SAVE
          SA7       SAVEB6         SAVE B6 STACK
          MX7       0 
          SA7       A1             CLEAR STACK
          STO.REG 
          QUAL      WRITALL        AVOID DUP SYMBOL PLCSV 
          CLSV$SQ   PUT 
          QUAL      * 
          PUT.IN
          SA1       SAVEB6
          BX7       X1
          SA7       A0+7           RESTORE B6 STACK 
          RESTORE 
          SET.RM    LOP,#PU#
          SB4       24B            WRITER 
          OFF.RM    SOL,WRITAL1 
          SB4       264B           WRITEN 
          EQ        WRITAL1        GO FINISH FLUSHING 
 SAVEB6   BSSZ      1 
 XIT      BSS       0 
          SET.RM    PAE,0          INDICATE BEFORE ANY END CONDITION
          SET.RM    BCC,0          CLEAR BUFFER CHARACTER COUNT 
          STO.REG 
          JP        B6
  
ERR       BSS       0 
          SX1       X1-#CSWPE#     CHECJK FOR PARITY ERROR
          SX6       140B           WRITE PARITY ERROR 
          ZR        X1,=XERR$RM 
          SX6       104B           CANNOT WRITE BUFFER
          EQ        =XERR$RM
 PUT$SQ   TITLE     PUT$F - GET RL FOR RT=F PUT 
*#
*0        PUT$F -- ENTRY POINT FOR THE F-RECORD HANDLER. DETERMINE
*     RECORD LENGTH FOR PUT$SQ BY FETCHING FL TO X3 AND RETURNING 
*     THROUGH B5
*#
          CAP.RM
 PUT$F    BSS       0 
          F.RM      FL,3
          JP        B5
 PUT$SQ   TITLE     PUT$U - GET RL FOR RT=U PUT 
*#
*0        PUT$U -- ENTRY POINT FOR THE U-RECORD HANDLER. DETERMINE
*     RECORD LENGTH FOR PUT$SQ BY FETCHING RRL TO X3 AND RETURNING
*     THROUGH B5. 
*#
          CAP.RM
 PUT$U    BSS       0 
          F.RM      RRL,3 
          JP        B5
* END /PUTDSQ/
