*DECK XWRITE
          IDENT  XWRITE 
 XWRITE   TITLE  XWRITE MAIN ROUTINE
* 
**    XWRITE - USER CALLABLE ROUTINE TO WRITE AN EXTENDED CODE FILE 
* 
*         INPUT  -  A1 = LOC. OF FORTRAN OR COBOL TYPE PARAMETER LIST 
*                   X1 = FIRST PARAMETER WORD 
* 
*         OUTPUT -  X6 = RETURN STATUS VALUE (NORMALIZED FLOATING PT.)
*                   X7 = 0
* 
*         PRESERVED  --, --, --, --, --, --, --, -- 
*                    A0, --, --, --, --, --, --, -- 
*                        --, --, --, --, --, --, -- 
* 
*CALL COM2
          B1=1
          SST 
          SPACE  4
 TC.XWR   VFD    42/6HXWRITE,18/XWRITE  TRACEBACK WORD
 WR.XIT   SA1    T.STATW     STATUS INFO FOR XREAD
          SA2    T.SAVEA0    RESTORE A0 
          NX6    X5 
          SX7    B0 
          SA6    A0+W.STATUS
          SA0    X2 
          ZR     X1,XWRITE   NO STATUS CELL GIVEN DONT STORE
          SA6    X1 
* 
 XWRITE   JP     400000B+*   ENTRY POINT
 +        SX7    TC.XWR      TRACEBACK INFO 
          SB6    WR.1 
          EQ     CHKPAR      CRACK PARAMETERS 
 WR.1     SA1    A0          CHECK WRITE FLAG 
          SA3    T.USEREC 
          PL     X1,WR.E1    ERROR, NOT A WRITE FILE
          SA2    A0+W.FTYP   FETCH FILE TYPE
          ZR     X3,WR.F     FLUSH BUFFER 
          AX2    S.FTYP 
          SB2    X2-1RT      CHECK FOR TAPE 
          ZR     B2,WR.T     JP TAPE
* 
          SB2    B2+1RT-1RC  CHECK FOR CARD 
          NZ     B2,WR.2     JP PRINT 
          SB3    LW.CARD-1   WORDS      CARD
          SX4    L.CARD*6    BITS 
          EQ     WR.3 
 WR.2     SB3    LW.PRINT-1 
          SX4    L.PRINT*6
* 
 WR.3     SA1    A0+W.BUFR   FILL IN BACKGROUND 
          SX7    0
 WR.4     SA7    X1+B3
          SB3    B3-B1
          PL     B3,WR.4
* 
          LX4    36          BUILD RECORD POINTER 
          SX7    X1 
          BX7    X4+X7
          ZR     B2,WR.GO    JP CARD
          AX1    S.XSET      PRINT CODE SET 
          SB2    X1-1RA 
          ZR     B2,WR.GO    NO PRE-FORMAT
          SA5    B2+D.FMT+1RA-1R1  GET FORMAT CODE
          SX2    SIZE.P 
          SB6    WR.GO1 
          BX6    X5 
          BX1    X7 
          SA7    A0+W.PREV   SAVE RECORD POINTER
          EQ     STBITS      STORE FORMAT CODE
* 
* TAPE SETUP
* 
 WR.T     SA2    A0+W.TPAR   GET TAPE PARAMETERS
          SA3    WR.MSK1     BIT MASK FOR PATH SELECTION
          SB2    X2          RECFM
          LX3    X3,B2
          PL     X3,WR.6     JP (U-B, VS-, V-B) 
          SA5    A0+W.RESBLK
          LX2    60-S.LRECL  GET LRECL
          BX7    X5 
          SX6    X2          LRECL (CHARS)
          AX5    36+3        REMAINING BLOCK (CHARS)
          IX1    X5-X6
          SB6    WR.5 
          NG     X1,WR.PUTB  PUT IF BLOCK OVERFLOW
 WR.5     MX0    60-36
          SA1    A0+W.TPAR
          BX7    -X0*X7 
          SX2    X1          RECFM
          AX1    S.LRECL
          SX1    X1          LRECL (CHARS)
          LX2    60-2 
          LX1    36+3 
          BX7    X1+X7       RECORD POINTER 
          NG     X2,WR.GO        -S-
          SB2    X2-2 
          NZ     B2,WR.GO    NOT V--
          SA7    A0+W.PREV   MUST BE V AND NOT S
          SB6    WR.GO1 
          SX2    32          PRESET COUNT FIELD TO ZERO 
          BX1    X7 
          SX6    B0 
          EQ     STBITS 
* 
 WR.6     SA3    A0+W.BUFR   HERE IF A RECORD AREA IS USED
          AX2    S.LRECL
          SX2    X2          LRECL (CHARS)
          AX3    S.RECAD     RECORD ADDRESS 
          SX7    X3 
          LX2    3           LRECL (BITS) 
          SX2    X2+59-60 
          IX0    X2/X3,60    LRECL (WORDS) - 1
          SB2    X0 
          SX6    B0 
 WR.7     SA6    X7+B2       BACKGROUND WITH ZERO 
          SB2    B2-B1
          PL     B2,WR.7
          EQ     WR.5        MAKE UP POINTER AND PARSE
* 
* GO PARSE
* 
 WR.GO    SA7    A0+W.PREV   SAVE RECORD POINTER
 WR.GO1   SA7    T.OUTREC 
          SA1    T.CSTR      CONV-STRING
          SA2    T.USEREC    SOURCE RECORD
          ZR     X1,WR.8     NO CONVERSION, DEFAULT TO B-B
          BX6    X2 
          SA6    T.INREC
          SB6    WR.10
          EQ     PARSE
* 
 WR.8     BX1    X2          NO CONVERSION
          AX2    36          SIZE OF SOURCE STRING
          SB6    WR.9 
          EQ     MVBITS      MOVE WITHOUT CONVERSION
 WR.9     SA7    T.OUTREC    UPDATED DESTINATION POINTER
          SX5    B0          RETURN FLAG = GOOD 
* 
 WR.10    NZ     X5,WR.XIT   JP CONVERSION ERROR
          SA2    A0+W.FTYP   NO ERROR, GET FILE TYPE
          SA1    A0+W.PREV   POINTER TO START OF RECORD 
          AX2    S.FTYP 
          SB7    X2-1RT 
          ZR     B7,WR.TT    JP TAPE
          SB7    B7+1RT-1RC  CHECK FOR CARD 
          ZR     B7,WR.CT    JP CARD
* 
* PRINT, ROUND RECORD SIZE UP TO WORD MULTIPLE
* 
          SA1    T.OUTREC 
          SX2    60 
          SX7    X1          WORD ADDRESS 
          AX1    18 
          SB2    X1          UBC
          AX1    18          RESIDUAL BIT COUNT 
          SX1    X1+B2
          SX7    X7+B1       NEW WORD ADDRESS 
          IX1    X1-X2       NEW RESIDUAL 
          NG     X1,SKPUBC
          LX1    36 
          BX7    X1+X7
 SKPUBC   BSS    0
          SA7    A1 
* 
* 
 WR.CT    SA1    A0          GET FIT ADDRESS
          SX1    X1 
          STORE  X1,EX=WR.ERR  SET UP ERROR EXIT
          SA1    A0 
          SX1    X1 
          FETCH  X1,OC,X5    CHECK FOR FILE OPEN
          SA1    A0 
          SX1    X1 
          SX5    X5-#OPE# 
          ZR     X5,WR.12    FILE IS OPEN 
* 
          OPENM  X1,I-O,N    OPEN FILE
          SA1    T.A0 
          SA0    X1          RESTORE A0 
          SA1    X1 
          SX1    X1          RESTORE FIT ADDRESS
* 
 WR.12    SA2    A0+W.PREV
          SA3    T.OUTREC 
          SX2    X2 
          SX4    X3 
          AX3    18 
          IX4    X4-X2       WORDS IN RECORD
          SX3    X3          EXTRA BITS IN LAST WORD
          BX5    X4 
          LX4    6           *64
          IX3    X4+X3
          LX5    2           *4 
          IX3    X3-X5
          SX3    X3+SIZE.P-1  ROUND UP TO NEXT MULTIPLE OF SIZE.P (12)
          IX3    X3/X4,SIZE.P 
          LX3    1           CONVERT TO 6-BIT COUNT 
          ZR     X3,WR.13    IGNORE IF ZERO 
* 
          PUT    X1,X2,X3,,,,,SQ
* 
          SA1    T.A0        RESTORE A0 AND FIT ADDRESS 
          SA0    X1 
          SA1    X1 
          SX1    X1 
 WR.13    STORE  X1,EX=WR.ERRX  RESET ERROR ADDRESS 
* 
          SX5    B0          SIGNAL GOOD RETURN 
          EQ     WR.XIT       AND EXIT
* 
* TAPE FORMATS
* 
 WR.TT    SA2    A0+W.TPAR   PICK UP TAPE PARAMS
          SA3    T.OUTREC 
          SX4    X2          RECFM
          LX4    60-2 
          SB2    X4          MAJOR TYPE 
          NE     B1,B2,WR.16 JP NOT TYPE F
* 
          LX4    2-1         CHECK BLOCKING 
          LX2    60-18       GET LRECL
 WR.TTA   SA1    A0+W.RESBLK  BLOCK POINTER 
          SX2    X2          LRECL (CHARS)
          SX0    X1          WORD POINTER 
          AX1    18 
          SX5    X1          EXTRA BITS 
          LX2    3           LRECL (BITS) 
          SX7    60 
          AX1    18          RESIDUAL BITS IN BLOCK 
          IX5    X2+X5       USED BITS
          IX1    X1-X2       NEW RESIDUAL COUNT 
 WR.14    IX6    X5-X7       REDUCE MODULO 60 
          NG     X6,WR.15    DONE 
          SX0    X0+B1
          BX5    X6 
          EQ     WR.14       CONTINUE 
 WR.15    LX5    18          RE-ASSEMBLE POINTER
          IX6    X1-X2       EXCESS OVER LRECL AGAIN
          LX1    36 
          BX7    X5+X0
          IX7    X1+X7       NEW POINTER
          SX5    B0 
          SA7    A1          SAVE RESBLK
          BX1    X7 
          PL     X4,WR.TP    NO BLOCKING
          PL     X6,WR.XIT   DONE IF SPACE FOR ANOTHER RECORD 
 WR.TP    SB6    WR.XIT 
          EQ     WR.PUTB     PUT BLOCK
* 
* 
 WR.16    MX0    60-36-3     ADJUST W.PREV TO *8 AND RECORD SIZE
          BX3    X0*X3       RESIDUAL ROUNDED TO CHARACTER
          IX7    X1-X3
          SB2    B2-B1       RECORD TYPE-1, V=1 
          SA7    A1          SAVE W.PREV
          BX1    X7 
          AX7    36          RESIDUAL SIZE
          ZR     X7,WR.XIT   JP SIZE = 0
          NE     B1,B2,WR.20 JP NOT TYPE V--
          NG     X4,WR.TA    JP TYPE VS-
          SX7    X7-32-1      TYPE V, NOT S 
          NG     X7,WR.XIT   JP NO DATA (HEADER IS 32 BITS) 
* 
          BX6    X1          SET UP V HEADER
          SX2    32 
          SB6    WR.17
          AX6    36+3        RECORD SIZE (CHARS)
          LX6    16          POSITION TO STORE
          EQ     STBITS 
 WR.17    SA2    A2          GET TAPE PARAMS
          SA1    A1          GET RECORD POINTER 
* 
 WR.20    LX2    59-0        CHECK FOR BLOCKING 
          NG     X2,WR.20A   YES
          BX2    X1          NO, JUST FIX UP POINTER AND PUT RECORD 
          MX4    0            (NO BLOCKING) 
          AX2    36+3         PSEUDO LRECL FOR V OR U RECORD
          EQ     WR.TTA 
 WR.20A   SA3    A0+W.RESBLK  BLOCKING, MUST MOVE RECORD
          BX2    X1 
          AX2    36          SOURCE SIZE
          BX7    X3 
          AX3    36          BLOCK REMAINDER
          IX3    X3-X2       CHECK FOR FIT
          PL     X3,WR.22    YES
          SB6    WR.21       NO, FIRST DUMP BLOCK 
          BX1    X7 
          EQ     WR.PUTB
 WR.21    SA2    A0+W.PREV   NOW MOVE DATA
          BX1    X2 
          AX2    36 
 WR.22    SB6    WR.23
          EQ     MVBITS 
 WR.23    SA7    A0+W.RESBLK  SAVE NEW BLOCK POINTER
          BX1    X7 
          AX7    36 
          ZR     X7,WR.TP    BLOCK IS FULL, DUMP IT 
          SA2    A0+W.TPAR
          SX5    B0 
          SX2    X2          RECFM
          AX2    2
          SX2    X2-2        CHECK FOR TYPE=V 
          NZ     X2,WR.XIT   NO, EXIT 
          SX7    X7-32-1     CHECK FOR AT LEAST 32 BITS 
          PL     X7,WR.XIT   YES
          EQ     WR.TP        NO
* 
* 
 WR.TA    SX0    1           TYPE IS VS-  SET FLAGS  = 01 
 WR.30    SA5    A0+W.RESBLK
          BX4    X1 
          AX4    36          RECORD SIZE (BITS) 
          BX7    X5 
          AX5    36          BLOCK SIZE (BITS)
          SX6    32          ALLOWANCE FOR HEADER 
          IX5    X5-X6
          IX6    X5-X4
          NG     X6,WR.31    JP RECORD BIGGER THAN BLOCK
          SX3    B1          RECORD FITS
          LX5    X4 
          BX0    -X3*X0      SET FLAGS TO X0
* 
 WR.31    SX6    32          BUILD HEADER 
          LX0    8
          IX6    X5+X6
          BX1    X7          BLOCK POINTER
          LX6    16-3        SEGMENT SIZE (CHARS) 
          BX6    X0+X6       SEGMENT SIZE + FLAGS 
          SX2    32 
          SB6    WR.32
          EQ     STBITS 
 WR.32    SA1    A0+W.PREV   MOVE RECORD TO BLOCK 
          SB6    WR.33
          BX2    X5 
          EQ     MVBITS 
 WR.33    SA7    A0+W.RESBLK
          BX6    X1 
          LX1    X7 
          SA6    A0+W.PREV
          AX7    36          RESIDUAL BLOCK SIZE
          SB6    WR.34
          SX0    32 
          IX7    X0-X7
          PL     X7,WR.PUTB  PUT A FULL BLOCK 
          SA2    A0+W.TPAR
          LX2    59-0        CHECK IF BLOCKING
          PL     X2,WR.PUTB  NO, PUT OUT BLOCK
          SX5    B0           YES, EXIT 
          EQ     WR.XIT 
* 
 WR.34    SA5    A0+W.PREV
          SX0    3           FLAGS = 11 
          BX1    X5 
          AX5    36          RESIDUAL RECORD SIZE 
          ZR     X5,WR.XIT   =0 
          EQ     WR.30       NOT ZERO 
* 
* FLUSH BLOCK 
* 
 WR.F     AX2    S.FTYP 
          SX5    B0 
          SB2    X2-1RT 
          NZ     B2,WR.XIT   NONE NEEDED IF NOT TAPE
          SA2    A0+W.TPAR
          SX2    X2          RECFM
          LX2    59-0        CHECK BLOCKING 
          PL     X2,WR.XIT   NOT BLOCKING 
          LX2    1+60-2 
          SA3    A0+W.RESBLK
          SA4    A0+W.BUFR
          SB2    X2-2        RECFM-2, V=0 
          BX1    X3 
          SX4    X4          BLOCK BASE ADDRESS 
          SX6    X3          BLOCK FILL WORD ADDRESS
          AX3    18 
          IX6    X6-X4       WORDS IN BLOCK 
          SX3    X3 
          LX6    6           =*64, WE ONLY CARE IF 32 BITS OR MORE
          IX6    X6+X3
          ZR     X6,WR.XIT   NO DATA IN BLOCK 
          NZ     B2,WR.TP    NOT TYPE V AND DATA IN BLOCK 
          SX4    32 
          IX6    X4-X6
          PL     X6,WR.XIT   NOT MORE THAN 32 BITS IN BLOCK 
          EQ     WR.TP       DATA IN BLOCK
* 
          SPACE  2
* 
* WR.PUTB - ROUTINE TO PUT A TAPE BLOCK 
* 
*         INPUT  -  X1 = CURRENT BLOCK POINTER
*                   B6 = RETURN ADDRESS 
*                   A0 = WSA
* 
*         OUTPUT -  X7 = NEW BLOCK POINTER (ALSO IN A0+W.RESBLK)
*                   X5 = ERROR STATUS (0 IF NORMAL RETURN)
* 
*         PRESERVED  --, --, --, --, --, --, --, -- 
*                    A0, --, --, --, --, --, --, -- 
*                        --, --, --, --, --, B6, -- 
* 
* **
          SPACE  2
 WR.PUTB  SX3    X1          GET SIZE TO PUT
          SA2    A0+W.BUFR
          AX1    18 
          SA5    A0+W.TPAR
          SX2    X2 
          SX1    X1 
          IX3    X3-X2       WORDS IN BLOCK 
          SX5    X5          RECFM
          BX6    X3 
          LX3    6           *64
          LX6    2           *4 
          IX6    X3-X6
          AX5    2           MAJOR RECORD TYPE
          IX6    X6+X1       BITS IN BLOCK
          SB5    X5-2        CHECK FOR TYPE = V-- 
          AX6    3           CHARS IN BLOCK 
          NZ     B5,WR.P0    NOT V--
          SA2    X2          FIX UP BLOCK HEADER IF TYPE = V--
          LX6    60-16
          IX7    X2+X6
          LX6    16 
          SA7    A2 
 WR.P0    BSS    0
* 
* UNTIL 6RM CAN HANDLE 8-BIT COUNTS, WE MUST CONVERT TO 6-BIT COUNT HERE
* 
          SX7    5           ROUNDING 
          LX6    3           BACK TO BITS 
          IX6    X6+X7
          IX6    X6/X7,6     DONE 
* ***** 
          SX7    B6 
          SA6    T.OUTREC    SAVE COUNT 
          SA7    T.SAVEB6    SAVE B6
          SA1    A0 
          STORE  X1,B8F=YES  TURN ON 8-BIT ROUND-DOWN IN CRM
          STORE  X1,EX=WR.ERR  SET UP ERROR EXIT
          FETCH  X1,OC,X5    SEE IF FILE IS OPEN
          SX1    X1 
          SX5    X5-#OPE# 
          ZR     X5,WR.P1    FILE IS OPEN 
* 
          OPENM  X1,I-O,N    OPEN FILE
          SA1    T.A0 
          SA0    X1          RESTORE A0 
          SA1    X1          RESTORE FIT ADDRESS
* 
 WR.P1    SA2    A0+W.BUFR   BLOCK ADDRESS
          SA3    T.OUTREC    COUNT
          SX2    X2 
          PUT    X1,X2,X3,,,,,SQ
* 
 WR.P2    SX5    0           FLAG AS GOOD 
 WR.P3    SA1    T.A0        RESTORE A0, FIT ADDRESS, B6
          SA2    T.SAVEB6 
          SA0    X1 
          SA1    X1 
          SB6    X2 
          SB5    X5          SAVE X5
          STORE  X1,EX=WR.ERRX
          STORE  X1,B8F=NO   TURN OFF 8-BIT ROUND-DOWN
* 
          SA1    A0+W.BUFR
          SA2    A0+W.TPAR
          SX7    X1          BLOCK ADDRESS
          SX0    X2          RECFM
          SB2    60 
          AX2    S.BLKSZ     BLOCK SIZE (CHARS) 
          SB3    X7 
          SX2    X2 
          AX0    2           MAJOR RECORD TYPE
          SX6    B0 
          LX2    36+3        BLOCK SIZE (BITS)
          SX0    X0-2        CHECK FOR V-- RECORD TYPE
          IX7    X2+X7       BLOCK POINTER
          AX2    36 
          NZ     X0,WR.P4    NOT V--
          MX5    18          SKIP 32 BITS FOR BLOCK HEADER
          LX5    36+5        =32S36 - 32S18 
          IX7    X7-X5
 WR.P4    SB4    X2 
          SA7    A0+W.RESBLK
 WR.P5    SA6    B3          ZERO BLOCK AREA
          SB4    B4-B2        BITS LEFT TO GO 
          SB3    B3+B1
          GT     B4,B0,WR.P5
          SX5    B5          RETURN STATUS
          NZ     B5,WR.E2    JP IF ERROR OCCURRED 
          JP     B6          RETURN 
* 
* ERROR ACTION
* 
 WR.ERR   PS     0
          SA1    T.A0 
          SA1    X1 
          SX1    X1 
          FETCH  X1,IRS,X5   FETCH ERROR STATUS 
          SB2    X5-101B     =LAST RECORD INCOMPLETE
          ZR     B2,WR.ERR    YES, NOT FATAL
          SX5    B1          FLAG ERROR 
          EQ     WR.P3        AND CLEAN UP BLOCK
* 
          SPACE  2
* 
 WR.ERRXT VFD    42/7H*ERROR*,18/WR.ERRX
 WR.ERRX  PS     0
          SX6    WR.ERRXT 
          SA6    T.ENTRY
          EQ     WR.E2
          SPACE  2
* 
* DATA AREA 
* 
 D.FMT    CON    SPACE.A,ZERO.A,MINUS.A          FOR 1,2,3 SPACE FORMAT 
* 
 WR.MSK1  LETMASK L,,(4B,5B,6B,7B,10B,14B,16B)
*                      F FB FS FSB V   U   US, NOT VB,VS,VSB,UB,USB 
* 
          SPACE  2
**    XWRITE ERROR ACTIONS
* 
 WR.E1    SA2    WR.M1
          EQ     ERR.CON
 WR.E2    SA2    WR.M2
          EQ     ERR.IO 
****
* 
 WR.M1    VFD    12/0,18/E.PAR,12/0,18/*+1
          DATA    C/FILE NOT SPECIFIED AS WRITE MODE/ 
 WR.M2    VFD    12/0,18/E.IO,12/0,18/*+1 
          DATA    C/UNRECOVERABLE ERROR ON WRITE FILE/
****
          END 
