TITLE  'ICATS GET-DATA-FROM-A-UTS-AND-WRITE-IT-TO-A-CMS-FILE ROUTINE' WRI00010
*********************************************************************** WRI00020
*                                                                     * WRI00030
*  MODULE NAME =  WRITE                                               * WRI00040
*                                                                     * WRI00050
*  FUNCTION =  IF THIS REQUEST CAME FROM A UTS MACHINE, THEN          * WRI00060
*              RETRIEVE DATA FROM THE REQUESTING UTS MACHINE AND      * WRI00070
*              WRITE IT TO A CMS FILE.                                * WRI00080
*              IF THIS IS A SMSG REQUEST, THEN LINK TO SOMEBODY'S     * WRI00090
*              DISK, ACCESS IT, AND COPY A FILE FROM THAT DISK TO     * WRI00100
*              ONE OF MY OWN DISKS.                                   * WRI00110
*              IF THIS IS A CONSOLE COMMAND, REJECT IT.               * WRI00120
*                                                                     * WRI00130
*  ENTRY POINTS =  WRITE                                              * WRI00140
*                                                                     * WRI00150
*  LINKAGE =  BALR R14,R15 FROM ICATS MAINLINE.                       * WRI00160
*                                                                     * WRI00170
*  REGISTER CONTENTS UPON ENTRY =                                     * WRI00180
*      R2  = POINTS TO THE ICATS COMMON DATA AREA, AS ALWAYS.         * WRI00190
*      R14 = RETURN ADDRESS BACK TO ICATS MAINLINE                    * WRI00200
*      R15 = ENTRY POINT TO THIS MODULE                               * WRI00210
*                                                                     * WRI00220
*  REGISTER USAGE =                                                   * WRI00230
*      R0-R1 = USED TO PASS PARAMETERS TO SUBROUTINES.                * WRI00240
*      R2 =  USED TO ADDRESS THE ICATS COMMON DATA AREA.              * WRI00250
*      R3  = TEMPORARILY USED TO ADDRESS THE FILE STATUS TABLE (FST), * WRI00260
*            THEN DROPPED.  LATER, AFTER THE FILE IS OPENED, IT'S     * WRI00270
*            USED TO ADDRESS THE FILE SYSTEM CONTROL BLOCK (FSCB).    * WRI00280
*      R4 =  USED TO ADDRESS CURRENT UTS CONTROL BLOCK.               * WRI00290
*      R5 =  USED TO ADDRESS CURRENT USER CONTROL BLOCK.              * WRI00300
*      R6 =  USED TO ADDRESS CURRENT DISK CONTROL BLOCK.              * WRI00310
*      R7 =  USED TO COUNT THE NUMBER OF RECORDS I'VE WRITTEN.        * WRI00320
*      R8 =  NUMBER OF BYTES LEFT TO DO IN THE INPUT BUFFER.          * WRI00330
*      R9 =  USED TO ADDRESS THE CURRENT RECORD IN THE INPUT BUFFER.  * WRI00340
*      R11 = MY BASE REGISTER                                         * WRI00350
*      R14 = MY RETURN ADDRESS WHEN I CALL SOMEBODY                   * WRI00360
*      R15 = SUBROUTINE ADDRESS                                       * WRI00370
*                                                                     * WRI00380
*                                                                     * WRI00390
*  MODULE LOGIC:                                                      * WRI00400
*      I)  IF THIS IS A CONSOLE COMMAND, REJECT IT.                   * WRI00410
*     II)  IF THIS IS AN SMSG COMMAND,                                * WRI00420
*          A)  CALL THE ACCESS ROUTINE TO                             * WRI00430
*              1)  LOCATE THE CORRECT UTSCB,                          * WRI00440
*              2)  LOCATE THE CORRECT USERCB,                         * WRI00450
*              3)  LOCATE THE CORRECT DISKCB,                         * WRI00460
*              4)  AND TO ACCESS THE CORRECT MINIDISK.                * WRI00470
*          B)  CHECK THE WRITE PASSWORD HE GAVE ME,                   * WRI00480
*          C)  LINK TO THIS GUYS MINIDISK,                            * WRI00490
*          D)  ACCESS IT,                                             * WRI00500
*          E)  COPY THE FILE OVER TO MY DISK.                         * WRI00510
*          F)  RELEASE AND DETACH THIS GUYS MINIDISK.                 * WRI00520
*                                                                     * WRI00530
*    III)  ELSE THIS MUST BE A UTS REQUEST.                           * WRI00540
*      A)  CALL THE ACCESS ROUTINE TO                                 * WRI00550
*          1)  LOCATE THE CORRECT UTSCB,                              * WRI00560
*          2)  LOCATE THE CORRECT USERCB,                             * WRI00570
*          3)  LOCATE THE CORRECT DISKCB,                             * WRI00580
*          4)  AND TO ACCESS THE CORRECT MINIDISK.                    * WRI00590
*      B)  CHECK THE WRITE PASSWORD THE UTS USER SUPPLIED WITH        * WRI00600
*          THE ONE HE'S SUPPOSE TO SUPPLY FOR THIS MINIDISK.          * WRI00610
*          1)  CL8'ALL' = HE DOESN'T NEED A PASSWORD TO WRITE.        * WRI00620
*          2)  CL8'NONE' = HE CAN'T WRITE NO MATTER WHAT              * WRI00630
*                          PASSWORD HE GAVE US.                       * WRI00640
*          3)  ELSE VERIFY THE PASSWORD HE GAVE US.                   * WRI00650
*      C)  INSURE A VALID SUBFUNCTION WAS SPECIFIED AND SET FLAGS     * WRI00660
*          ACCORDINGLY.  DETERMINE THE FILE NAME TO BE USED           * WRI00670
*          (THIS DETERMINATION DEPENDS ON THE SUBFUNCTION             * WRI00680
*          SPECIFIED).  THE VALID SUBFUNCTIONS INCLUDE;               * WRI00690
*          1)  CREATE (THIS IS THE DEFAULT IF LEFT BLANK).  THIS      * WRI00700
*              WILL ABORT THIS WRITE REQUEST IF A FILE ALREADY        * WRI00710
*              EXISTS WITH THIS FILENAME.                             * WRI00720
*          2)  REPLACE.  WE'LL DO AN ERASE OF THIS FILE FIRST.        * WRI00730
*          3)  INCRVL.  THIS WILL SEARCH THE SPECIFIED MINIDISK TO    * WRI00740
*              DETERMINE THE FILENAME TO BE USED FOR THIS NEW FILE.   * WRI00750
*              IF THE FILENAME HE REQUESTED IS BEING USED BY SOME     * WRI00760
*              OTHER FILE, WE'LL CHANGE THE FILENAME TO THE FIRST     * WRI00770
*              FREE FILENAME WE FIND USING THIS SEARCH ORDER;         * WRI00780
*              XXXXX000 - XXXXX999  WHERE XXXXX = THE FIRST FIVE      * WRI00790
*                                   CHARACTERS OF THE GIVEN FILENAME. * WRI00800
*          4)  APPEND.  IF A FILE WITH THIS FILENAME ALREADY EXISTS   * WRI00810
*              THEN THIS DATA WILL BE APPENDED TO THAT FILE.  ELSE    * WRI00820
*              A BRAND NEW FILE WILL BE CREATED WITH THIS FILENAME    * WRI00830
*              AND THIS DATA.                                         * WRI00840
*          5)  DA (DIRECT ACCESS WRITE).  ALLOWS THE USER TO          * WRI00850
*              SPECIFY THE STARTING RECORD NUMBER OF CMS FILE TO      * WRI00860
*              START WRITING TO.  THE CMS FILE MUST HAVE A FIXED      * WRI00870
*              LENGTH RECORD FORMAT.                                  * WRI00880
*      D)  GO GET THE DATA FROM THE UTS MACHINE.  THIS IS A           * WRI00890
*          SEPARATE SIO THAN THE ONE USED TO GET THE REQUEST          * WRI00900
*          CONTROL BLOCK.                                             * WRI00910
*      E)  OPEN THE FILE AND, IF THIS IS A DA WRITE, THEN DO A        * WRI00920
*          FSPOINT TO START WRITING AT THE SPECIFIED RECORD.          * WRI00930
*      F)  START WRITING UNTIL YOU'VE WRITTEN ALL THE DATA HE'S       * WRI00940
*          PASSED US.                                                 * WRI00950
*          1)  DETERMINE THE LENGTH OF THE NEXT INPUT RECORD.         * WRI00960
*          2)  DETERMINE THE LENGTH OF THE NEXT OUTPUT RECORD.        * WRI00970
*          3)  PAD OR TRUNCATE THE INPUT RECORD AS NEEDED.            * WRI00980
*          4)  WRITE THIS RECORD INTO THE CMS FILE.                   * WRI00990
*      G)  CLOSE THE CMS FILE.                                        * WRI01000
*      H)  GIVE A REPLY TO THE UTS MACHINE TELLING WHAT HAPPENED.     * WRI01010
*          INCLUDE STARTING RECORD # FOR NEXT WRITE,                  * WRI01020
*          CMS FILE CHARACTERISTICS (RECORD FORMAT, LOGICAL           * WRI01030
*          RECORD LENGTH, AND NUMBER OF RECORDS IN THE FILE),         * WRI01040
*          AND THE BIGGEST RECORD I FOUND IN THE INPUT DATA.          * WRI01050
*                                                                     * WRI01060
*  NORMAL EXIT =                                                      * WRI01070
*      R15 = 0                                                        * WRI01080
*                                                                     * WRI01090
*  EXTERNAL REFERENCES = NONE                                         * WRI01100
*                                                                     * WRI01110
*  MACROS =  ICDATA = ICATS COMMON DATA AREA                          * WRI01120
*            ETTE   = ENTER TRACE TABLE ENTRY SUBROUTINE              * WRI01130
*                                                                     * WRI01140
*  CHANGE ACTIVITY                                                    * WRI01150
*    DATE        NAME       REASON FOR CHANGE                         * WRI01160
*  02/25/83  RICK JASPER    INITIAL PROGRAM CREATION                  * WRI01170
*  05/03/83  RICK JASPER    ADDED UTS SOURCE RECORD FORMAT SUPPORT    * WRI01180
*  09/16/83  RICK JASPER    WRITE FROM SMSG IS NOW DEFINED.           * WRI01190
*                                                                     * WRI01200
*********************************************************************** WRI01210
         PRINT GEN,NODATA                                               WRI01220
WRITE    CSECT                                                          WRI01230
         USING ICDATA,R2            ADDRESS ICATS COMMON DATA AREA      WRI01240
         USING CBUTS,R4          USE R4 TO ADDRESS UTS CONTROL BLOCK    WRI01250
         USING CBUSER,R5         USE R5 TO ADDRESS USER CONTROL BLOCK   WRI01260
         USING CBDISK,R6         USE R6 TO ADDRESS DISK CONTROL BLOCK   WRI01270
         USING *,R15      USE R15 FOR BASE REG NEXT INSTRUCTION ONLY    WRI01280
         STM   R0,R14,REGSAVE       SAVE CALLER'S REGISTERS             WRI01290
         DROP  R15                                                      WRI01300
         USING WRITE,R11            R11 WILL BE BASE REGISTER           WRI01310
         LR    R11,R15              ESTABLISH BASE REGISTER             WRI01320
*                                                                       WRI01330
         TM    FLAGB,CONSCMD     REJECT THIS REQUEST IF IT              WRI01340
         BNO   CON10             CAME FROM THE CONSOLE.                 WRI01350
         L     R15,AREJECT       GO TO REJECT-THIS-COMMAND ROUTINE      WRI01360
         BALR  R14,R15                                                  WRI01370
         B     WRITEBYE                                                 WRI01380
*                                                                       WRI01390
*     II)  IF THIS IS AN SMSG COMMAND,                                * WRI01400
*          A)  CALL THE ACCESS ROUTINE TO                             * WRI01410
*              1)  LOCATE THE CORRECT UTSCB,                          * WRI01420
*              2)  LOCATE THE CORRECT USERCB,                         * WRI01430
*              3)  LOCATE THE CORRECT DISKCB,                         * WRI01440
*              4)  AND TO ACCESS THE CORRECT MINIDISK.                * WRI01450
*          B)  CHECK THE WRITE PASSWORD HE GAVE ME,                   * WRI01460
*          C)  LINK TO THIS GUYS MINIDISK,                            * WRI01470
*          D)  ACCESS IT,                                             * WRI01480
*          E)  COPY THE FILE OVER TO MY DISK.                         * WRI01490
*          F)  RELEASE AND DETACH THIS GUYS MINIDISK.                 * WRI01500
*                                                                     * WRI01510
CON10    DS    0H                                                       WRI01520
         TM    FLAGB,UTSCMD      IF IT'S A UTS REQUEST,                 WRI01530
         BO    CON50             GO HANDLE THAT.                        WRI01540
         L     R4,CBFIRST                                               WRI01550
*    LOOP THROUGH THE UTSCB CHAIN TO SEE WHICH UTS THIS GUY IS          WRI01560
*    REFERENCING.  KEY ON THE UTS UNIQUE ID (CBUTSUID).                 WRI01570
         L     R4,CBFIRST          GET ADDRESS OF FIRST UTSCB           WRI01580
UTSLOOPA LTR   R4,R4               ARE WE PAST THE END-OF-CHAIN ??      WRI01590
         BZ    CMSERR1             YEP, WE DIDN'T FIND A MATCH.         WRI01600
         TM    CBUTSFGA,INTISIN    ELSE, SEE IF THIS IS THE ONE         WRI01610
         BO    CMSGOTIT            YEP, IT IS.  CONTINUE ON.            WRI01620
         L     R4,CBUTSFP          HAVEN'T FOUND IT YET.                WRI01630
         B     UTSLOOPA            GO CHECK THE NEXT ONE.               WRI01640
CMSGOTIT DS    0H                                                       WRI01650
*    PREPARE FOR ACCESS ROUTINE.                                        WRI01660
         ST    R4,THISUTS        SAVE UTSCB ADDRESS                     WRI01670
         MVC   THISUSER,PARM7    MOVE IN UTS USER ID                    WRI01680
         MVC   THISDISK,PARM10   MOVE IN THE DISK HE WANTED             WRI01690
         L     R15,AACCESS       GET ADDRESS OF ACCESS ROUTINE          WRI01700
         BALR  R14,R15           GO FIND ALL THE CONTROL BLOCKS         WRI01710
*    UPON RETURN, IF THERE WAS AN ERROR, THEN R15 > 0,                  WRI01720
*                 ELSE R15 = 0 AND R4, R5, AND R6 ALL POINT TO THE      WRI01730
*                 CORRECT UTSCB, USERCB, AND DISKCB RESPECTIVELY.       WRI01740
                                                                        WRI01750
                                                                        WRI01760
*    INITIALIZE EVERYTHING.                                             WRI01770
CON50    DS    0H                                                       WRI01780
         XC    UTSPARMS,UTSPARMS       CLEAR ALL THE PARMS AT ONCE      WRI01790
         MVI   RITFLAGA,X'00'          CLEAR WRITE STATUS FLAG          WRI01800
         MVI   RITFLAGB,X'00'          CLEAR THE OTHER ONE              WRI01810
         CLI   PARM4,C'›'                                               WRI01820
         BNE   NOCENT                                                   WRI01830
         MVI   PARM4,C'#'                                               WRI01840
NOCENT   DS    0H                                                       WRI01850
*    PREPARE FOR ACCESS ROUTINE.                                        WRI01860
         MVC   THISUSER,PARM0    MOVE IN UTS USER ID                    WRI01870
         MVC   THISDISK,PARM6    MOVE IN THE DISK HE WANTED             WRI01880
         L     R15,AACCESS       GET ADDRESS OF ACCESS ROUTINE          WRI01890
         BALR  R14,R15           GO FIND ALL THE CONTROL BLOCKS         WRI01900
*    UPON RETURN, IF THERE WAS AN ERROR, THEN R15 > 0,                  WRI01910
*                 ELSE R15 = 0 AND R4, R5, AND R6 ALL POINT TO THE      WRI01920
*                 CORRECT UTSCB, USERCB, AND DISKCB RESPECTIVELY.       WRI01930
         LTR   R15,R15                                                  WRI01940
         BNZ   ERROR1            GO FIGURE OUT WHAT THE ERROR WAS       WRI01950
*    NOW CHECK THE WRITE PASSWORD THIS GUY GAVE ME FOR THIS DISK        WRI01960
         CLC   CBDSKWPW,=CL8'ALL'    DOES HE REQUIRE A PASSWORD ??      WRI01970
         BE    CON100                NOPE, CONTINUE ON                  WRI01980
         CLC   CBDSKWPW,=CL8'NONE'   IS HE ALLOWED TO WRITE ON THIS     WRI01990
         BE    ERROR2                DISK ??  NOPE, TELL HIM SO         WRI02000
         CLC   CBDSKWPW,PARM7   NOT SPECIAL CASE - COMPARE PASSWORD     WRI02010
         BNE   ERROR3           PASSWORD IS INCORRECT                   WRI02020
CON100   DS    0H                                                       WRI02030
*    OK, THE PASSWORD CHECKS.  NOW MAKE SURE HE'S GIVEN US A VALID      WRI02040
*   SUBFUNCTION.  CHECK FOR CREATE, REPLACE, INCRVL, APPEND, OR DA      WRI02050
*   (THE DEFAULT IF BLANK, IS CREATE).  ANYTHING ELSE WILL BE           WRI02060
*   REJECTED.  ONCE YOU'VE GOT A VALID SUBFUNCTION, DETERMINE THE       WRI02070
*   FILE NAME TO BE USED AND TAKE CARE OF ANY OTHER PARAMETERS          WRI02080
*   PECULIAR TO THIS SUBFUNCTION.                                       WRI02090
         CLC   PARM2,=CL8' '        CHECK FOR DEFAULT OF CREATE         WRI02100
         BE    CON110                                                   WRI02110
         CLC   PARM2,=CL8'CREATE'   CHECK FOR CREATE                    WRI02120
         BNE   CON120               NOPE, CHECK NEXT SUBFUNCTION        WRI02130
CON110   DS    0H                                                       WRI02140
         OI    RITFLAGB,CREATE      THIS IS A CREATE WRITE              WRI02150
*   SEE IF THERE'S ALREADY A FILE WITH THIS FILE ID.  IF SO, THEN       WRI02160
*   REJECT THIS REQUEST.  DO A FSSTATE.  THE FSSTATE WILL ALSO          WRI02170
*   LET US KNOW IF THE FILENAME OR FILETYPE CONTAINS INVALID            WRI02180
*   CHARACTERS.                                                         WRI02190
         LA    R8,PARM4        GET ADDRESS OF FILE ID (FN FT FM)        WRI02200
         FSSTATE (R8)          DOES THIS FILE EXIST ??                  WRI02210
         LTR   R15,R15                                                  WRI02220
         BZ    ERROR4          YES, IT DOES.  REJECT THIS WRITE.        WRI02230
         C     R15,=F'28'      WAS THE FILE NOT FOUND ??  (EXPECTED)    WRI02240
         BE    CON200          YEP, IT WASN'T FOUND.  CONTINUE ON       WRI02250
         C     R15,=F'20'      INVALID CHARACTER IN FILE ID ??          WRI02260
         BE    ERROR5                                                   WRI02270
         B     ERROR6          SOME OTHER FSSTATE ERROR.                WRI02280
*   CONTINUE CHECKING FOR VALID SUBFUNCTIONS.                           WRI02290
CON120   DS    0H                                                       WRI02300
         CLC   PARM2,=CL8'REPLACE'  CHECK FOR REPLACE WRITE             WRI02310
         BNE   CON130                                                   WRI02320
         OI    RITFLAGB,REPLACE      THIS IS A REPLACE WRITE            WRI02330
*   DO AN FSERASE FOR THIS FILE ID.  IGNORE A RC = 28 = FILE-NOT-FOUND  WRI02340
*   RETURN CODE.  DON'T IGNORE A RC = 20 = INVALID FILE ID RETURN CODE. WRI02350
*   FLAG THAT AS AN ERROR.                                              WRI02360
         LA    R8,PARM4           GET ADDRESS OF FILE ID (FN FT FM)     WRI02370
         FSERASE (R8)             ERASE THE FILE IF IT EXISTS           WRI02380
         LTR   R15,R15            DID THINGS GO OK ??                   WRI02390
         BZ    CON125             YEP, THE FILE DID EXIST               WRI02400
         C     R15,=F'28'                                               WRI02410
         BE    CON125             IT'S OK IF THE FILE DID NOT EXIST     WRI02420
         C     R15,=F'20'         CHECK FOR INVALID FILE ID             WRI02430
         BE    ERROR5             TSK TSK                               WRI02440
         B     ERROR7             SOME OTHER ERROR WITH THE FSERASE     WRI02450
CON125   DS    0H                                                       WRI02460
         B     CON200      OTHERWISE, EVERYTHING'S GREAT.  CONTINUE ON  WRI02470
*   CONTINUE CHECKING FOR VALID SUBFUNCTIONS.                           WRI02480
CON130   DS    0H                                                       WRI02490
         CLC   PARM2,=CL8'INCRVL'   CHECK FOR WRITE AND INCREMENT       WRI02500
         BNE   CON140               THE VERSION LEVEL                   WRI02510
         OI    RITFLAGB,INCRVL      THAT'S WHAT THIS IS                 WRI02520
*   THIS IS WHERE I'VE GOT TO WORK.  FIRST SEE IF THIS FILE EXISTS OR   WRI02530
*   NOT.  IF IT DOESN'T, FINE - USE THIS FILE ID.                       WRI02540
*   OTHERWISE, FIND THE FIRST BLANK CHARACTER IN THE FILENAME OR THE    WRI02550
*   FIFTH CHARACTER, WHATEVER COMES FIRST.  CHANGE THE FILENAME         WRI02560
*      FROM HISNAME  ==>  TO HISNA000                                   WRI02570
*   OR FROM NAME     ==>  TO NAME000.  REMEMBER WHERE THE 000'S START.  WRI02580
*   NOW, DOES THAT FILE EXIST ??  IF SO, USE THAT FILE ID.              WRI02590
*   IF NOT, INCREMENT THE 000'S TO 001, THEN 002, ETC. UNTIL YOU FIND   WRI02600
*   A FILE ID THAT ISN'T BEING USED OR YOU GO PAST 999.  IF YOU GO      WRI02610
*   PAST 999, THEN REJECT THIS WRITE REQUEST (THE BLOODY FOOL'S GOT     WRI02620
*   1,001 FILES ON HIS DISK, HE DESERVES THIS 1,002ND TO BE REJECTED).  WRI02630
         LA    R8,PARM4        GET ADDRESS OF FILE ID (FN FT FM)        WRI02640
         FSSTATE (R8)          DOES THIS FILE EXIST ??                  WRI02650
         C     R15,=F'28'      WAS THE FILE NOT FOUND ??  (EXPECTED)    WRI02660
         BE    CON139          GOOD, WE CAN USE HIS ORIGINAL FILE ID.   WRI02670
         C     R15,=F'20'      IS THIS FILE ID INVALID ??               WRI02680
         BE    ERROR5          YEP, BAD CHARACTER IN FILENAME OR TYPE.  WRI02690
         LTR   R15,R15         WAS THE FILE FOUND ??                    WRI02700
         BNZ   ERROR6          NO, SOME OTHER FSSTATE ERROR             WRI02710
*    OK, HIS ORIGINAL FILE ID IS BEING USED BY ANOTHER FILE.  WE'RE     WRI02720
*    GOING TO HAVE TO START LOOPING, CHANGING THE FILENAME, UNTIL WE    WRI02730
*    FIND AN UNUSED ONE.  FIND WHERE TO PUT THE 000'S IN HIS FILE NAME. WRI02740
         LA    R9,PARM4+1      START AT SECOND CHARACTER OF FILENAME    WRI02750
         LA    R0,1            INCREMENT 1 CHARACTER AT A TIME AND      WRI02760
         LA    R1,PARM4+4      QUIT AFTER THE FOURTH CHARACTER          WRI02770
UP2      CLI   0(R9),C' '    FIND THE FIRST BLANK IN THE FILENAME OR    WRI02780
         BE    CON131        THE FIFTH CHARACTER, WHICHEVER COMES FIRST WRI02790
         BXLE  R9,R0,UP2                                                WRI02800
CON131   DS    0H          NOW, R9 = ADDRESS OF WHERE TO PUT THE 000'S  WRI02810
         MVC   VL,=PL4'0'  INITIALIZE VERSION LEVEL COUNTER TO ZEROES   WRI02820
CON132   DS    0H                                                       WRI02830
         UNPK  TEMPA,VL            UNPACK VERSION LEVEL COUNTER         WRI02840
         OI    TEMPA+7,X'F0'                                            WRI02850
         MVC   0(3,R9),TEMPA+5     MOVE IN THE LAST 3 CHARACTERS        WRI02860
         FSSTATE (R8)              CHECK FOR THE EXISTENCE OF THIS FILE WRI02870
         LTR   R15,R15             IS THIS FILENAME FREE ??             WRI02880
         BNZ   CON139              YEP, FINALLY FOUND ONE WE CAN USE.   WRI02890
         AP    VL,=PL1'1'          ELSE INCREMENT THE VERSION LEVEL     WRI02900
         CP    VL,=P'999'          ARE WE AT THE END YET ??             WRI02910
         BNH   CON132              NOPE, STILL OK.  KEEP CHECKING.      WRI02920
         B     ERROR8     ALL 1,001 FILE ID'S ARE USED UP.  REJECT.     WRI02930
CON139   DS    0H                                                       WRI02940
         B     CON200     WE'VE GOT THE FILE ID.  CONTINUE ON           WRI02950
*   CONTINUE CHECKING FOR VALID SUBFUNCTIONS.                           WRI02960
CON140   DS    0H                                                       WRI02970
         CLC   PARM2,=CL8'APPEND'   CHECK FOR WRITE AND APPEND          WRI02980
         BNE   CON150                                                   WRI02990
         OI    RITFLAGB,APPEND                                          WRI03000
*   THERE'S NO CHECKING NEEDED HERE.  IF THE FILE EXISTS, GREAT,        WRI03010
*   EVERYTHING'S FINE.  IF IT DOESN'T EXIST, THEN THE FILE WILL BE      WRI03020
*   CREATED.  EITHER WAY, THINGS WILL WORK AS EXPECTED.  LET THE        WRI03030
*   FSOPEN MACRO DETERMINE IF THIS FILE ID IS VALID OR NOT.             WRI03040
         B     CON200               EVERYTHING'S GREAT.  CONTINUE ON    WRI03050
*   CONTINUE CHECKING FOR VALID SUBFUNCTIONS.  ONE LAST CHANCE.         WRI03060
CON150   DS    0H                                                       WRI03070
         CLC   PARM2,=CL8'DA'       CHECK FOR DIRECT ACCESS WRITE       WRI03080
         BNE   ERROR9               THAT WAS THE LAST CHANCE, BUB       WRI03090
         OI    RITFLAGB,DA                                              WRI03100
*   MAKE SURE THIS FILE EXISTS.  IF NOT, HE BLEW IT.                    WRI03110
*   IF IT DOES EXIST, CHECK TO MAKE THIS IS A FIXED LENGTH FILE.        WRI03120
*   IF NOT, THEN REJECT THIS REQUEST.  I'M NOT GOING TO SUPPORT         WRI03130
*   WRITING IN THE MIDDLE OF A VARIABLE LENGTH FILE.  TO MESSY.         WRI03140
*   IF WE GOT THIS FAR, CHECK THE STARTING RECORD NUMBER.  IF BIGGER    WRI03150
*   THAN THE NUMBER OF RECORDS IN THE FILE BY MORE THAN ONE, THEN       WRI03160
*   HE BLEW IT (I WILL ALLOW HIM TO START AT THE END OF THE FILE).      WRI03170
         LA    R8,PARM4        GET ADDRESS OF FILE ID (FN FT FM)        WRI03180
         FSSTATE (R8)          DOES THIS FILE EXIST ??                  WRI03190
         LTR   R15,R15                                                  WRI03200
         BZ    CON151          YES IT DOES.  CONTINUE ON.               WRI03210
         C     R15,=F'28'      WAS THE FILE NOT FOUND ??  (EXPECTED)    WRI03220
         BE    ERROR10         YES, IT WAS NOT FOUND.                   WRI03230
         C     R15,=F'20'      INVALID FILE ID ??                       WRI03240
         BE    ERROR5          YEP                                      WRI03250
         B     ERROR6          SOME OTHER ERROR WITH FSSTATE            WRI03260
CON151   DS    0H                                                       WRI03270
         USING FSTD,R3         R1 IS POINTING TO THE FILE STATUS TABLE  WRI03280
         LR    R3,R1           SHIFT FST BASE REGISTER TO R3            WRI03290
         CLI   FSTRECFM,C'F'   MAKE SURE THIS IS A FIXED-LENGTH FILE    WRI03300
         BNE   ERROR11         WE DON'T HANDLE VARIABLE-LENGTH FILES    WRI03310
*    CONVERT THE STARTING RECORD NUMBER TO A DECIMAL NUMBER             WRI03320
         LA    R1,PARM10       PARM10 IS THE STARTING RECORD NUMBER     WRI03330
         L     R15,ACONDEC     GO TO THE CONVERT-TO-DECIMAL ROUTINE     WRI03340
         BALR  R14,R15                                                  WRI03350
         LTR   R15,R15         HOW'D THINGS GO ??                       WRI03360
         BNZ   ERROR12         ERROR IF ALL BLANK OR INVALID            WRI03370
         LTR   R0,R0           IF HE SAID START AT RECORD NUMBER 0,     WRI03380
         BNZ   CON154          HE REALLY MEANS START AT RECORD 1        WRI03390
         LA    R0,1                                                     WRI03400
CON154   EQU   *                                                        WRI03410
         LH    R1,FSTRECCT     ADD ONE TO THE NUMBER OF RECORDS         WRI03420
         LA    R1,1(R1)        IN THE FILE.                             WRI03430
         CR    R0,R1           IS THE STARTING RECORD NUMBER GREATER    WRI03440
         BH    ERROR13         THAN THE NUMBER OF RECORDS + 1 ??        WRI03450
         ST    R0,STARTRCD     SAVE THE STARTING RECORD NUMBER          WRI03460
         DROP  R3              DON'T NEED THE FST ANYMORE               WRI03470
CON200   EQU   *                                                        WRI03480
*    FIND OUT HOW MANY BYTES ARE COMING OVER.                           WRI03490
         LA    R1,PARM3        PARM3 IS THE BYTE COUNT                  WRI03500
         L     R15,ACONDEC     GO TO THE CONVERT-TO-DECIMAL ROUTINE     WRI03510
         BALR  R14,R15                                                  WRI03520
         LTR   R15,R15         DID THE BYTE COUNT CONVERT OK ??         WRI03530
         BNZ   ERROR14         ERROR IF NOT                             WRI03540
         LTR   R0,R0           IT'S ALSO INVALID IF ZERO                WRI03550
         BZ    ERROR14                                                  WRI03560
         ST    R0,BYTECNT      IF IT'S OK, THEN STORE IT AWAY           WRI03570
*    IS THIS INPUT GOING TO BE IN FIXED, VARIABLE, OR SOURCE FORMAT ??  WRI03580
         CLI   PARM8,C'S'      PARM8 DETERMINES INPUT FORMAT            WRI03590
         BNE   CON210          BRANCH IF NOT IN SOURCE FORMAT           WRI03600
         OI    RITFLAGA,SFORMAT     ELSE, IT'LL BE IN SOURCE FORMAT     WRI03610
         B     CON212                     CONTINUE ON                   WRI03620
*    IS THIS INPUT GOING TO BE IN FIXED OR VARIABLE FORMAT ??           WRI03630
CON210   DS    0H                                                       WRI03640
         CLI   PARM8,C'V'      PARM8 DETERMINES FIXED OR VARIABLE       WRI03650
         BE    CON212          BRANCH IF IT'LL BE IN VARIABLE FORMAT    WRI03660
         OI    RITFLAGA,FIXEDUTS    ELSE, IT'LL BE IN FIXED FORMAT      WRI03670
*    FIND OUT WHAT THE INPUT DATA'S LRECL (OR BLOCKING FACTOR) IS.      WRI03680
         LA    R1,PARM9        PARM 9 IS THE RECORD BLOCKING FACTOR     WRI03690
         L     R15,ACONDEC     GO TO THE CONVERT-TO-DECIMAL ROUTINE     WRI03700
         BALR  R14,R15                                                  WRI03710
         LTR   R15,R15               DID IT CONVERT OK ??               WRI03720
         BNZ   ERROR15               ERROR IF NOT                       WRI03730
         LTR   R0,R0                 IT'S ALSO INVALID IF ZERO          WRI03740
         BZ    ERROR15                                                  WRI03750
         ST    R0,UTSLRECL           IF IT'S OK, THEN STORE IT AWAY     WRI03760
CON212   DS    0H                                                       WRI03770
*    NOW GO GET THE SPECIFIED NUMBER OF BYTES FROM THE UTS.             WRI03780
         L     R0,BYTECNT            NUMBER OF BYTES FROM THE UTS       WRI03790
         L     R1,ABUFFER            BUFFER ADDRESS                     WRI03800
         L     R15,AREADUTS                                             WRI03810
         BALR  R14,R15                                                  WRI03820
*    ESTABLISH THE OUTPUT BUFFER.  THIS'LL BE RIGHT AFTER ALL THE       WRI03830
*    INPUT DATA AND WILL BE USED TO MOVE A RECORD TO, PAD IT TO THE     WRI03840
*    LRECL OF THE CMS FILE, AND WRITE IT OUT TO THE CMS FILE.           WRI03850
         L     R9,ABUFFER      START OF INPUT BUFFER                    WRI03860
         A     R9,BYTECNT    + NUMBER OF BYTES IN INPUT                 WRI03870
         ST    R9,OUTBUFR    = START OF OUTPUT BUFFER                   WRI03880
*    OPEN THE CMS FILE.  IF THIS HAPPENS TO BE A NEW FILE, THEN         WRI03890
*    SET UP THE RECORD FORMAT (FIXED OR VARIABLE) AND THE LRECL OF      WRI03900
*    THE CMS FILE.  MAKE IT THE SAME AS THE INPUT DATA FORMAT.          WRI03910
         IC    R10,=C'V'              ASSUME VARIABLE LENGTH UNTIL      WRI03920
         LA    R9,0                   PROVEN WRONG                      WRI03930
         TM    RITFLAGA,FIXEDUTS      WAS I RIGHT ??                    WRI03940
         BNO   CON215                 YEP, IT IS GOING TO BE VARIABLE   WRI03950
         IC    R10,=C'F'              OTHERWISE CHANGE TO FIXED FORMAT  WRI03960
         L     R9,UTSLRECL            AND USE THE CORRECT LRECL         WRI03970
CON215   DS    0H                                                       WRI03980
         MVC   PADCHAR,PARM6+7        REMEMBER THE PAD CHARACTER        WRI03990
*    R9  = LOGICAL RECORD LENGTH                                        WRI04000
*    R10 = C'F' IF FIXED FORMAT, ELSE C'V' FOR VARIABLE FORMAT          WRI04010
         USING FSCBD,R3        TIME TO SET UP MY FSCB BASE REGISTER     WRI04020
         LA    R3,MYFSCB                                                WRI04030
         LA    R8,PARM4        GET FILE ID (FILE NAME, TYPE, AND MODE)  WRI04040
         FSOPEN (R8),FSCB=(R3),RECFM=(R10),BSIZE=(R9)                   WRI04050
         LTR   R15,R15               DID IT WORK ??                     WRI04060
         BZ    CON305                YEA, WE'RE ALL SET.                WRI04070
         C     R15,=F'28'            IS THIS A NEW FILE ??              WRI04080
         BE    CON300                YEP, REMEMBER THAT FACT.           WRI04090
         C     R15,=F'20'            INVALID FILE ID ??                 WRI04100
         BE    ERROR5                YEP                                WRI04110
         B     ERROR16               NO, SOME OTHER ERROR WITH FSOPEN.  WRI04120
CON300   DS    0H                                                       WRI04130
         OI    RITFLAGA,NEW          REMEMBER WE'RE CREATING A NEW FILE WRI04140
CON305   DS    0H        THE FILE IS OPENED, AND EVERYTHING'S GROOVY    WRI04150
         CLI   FSCBFV,C'V'           IS THE CMS FILE VARIABLE LENGTH ?? WRI04160
         BE    CON310                SKIP NEXT INSTRUCTION IF SO        WRI04170
         OI    RITFLAGA,FIXEDCMS     REMEMBER THE CMS FILE IS FIXED     WRI04180
CON310   DS    0H                                                       WRI04190
*    IF THIS IS A DA WRITE, THEN DO A FSPOINT TO START WRITING          WRI04200
*    AT THE CORRECT STARTING RECORD NUMBER.                             WRI04210
         TM    RITFLAGB,DA           IS IT A DA WRITE ??                WRI04220
         BNO   CON400                NOPE, CONTINUE ON.                 WRI04230
         L     R9,STARTRCD           GET THE STARTING RECORD NUMBER     WRI04240
         FSPOINT FSCB=MYFSCB,WRPNT=(R9)                                 WRI04250
         LTR   R15,R15               THERE SHOULD NEVER BE ANY ERROR,   WRI04260
         BNZ   ERROR17               BUT JUST IN CASE ....              WRI04270
CON400   DS    0H                                                       WRI04280
*                                                                       WRI04290
*    NOW START DOING THE WRITING INTO THE CMS FILE.                     WRI04300
*                                                                       WRI04310
         L     R9,ABUFFER         COMPUTE AND SAVE THE ADDRESS OF THE   WRI04320
         A     R9,BYTECNT         FIRST BYTE OUTSIDE THE INPUT BUFFER   WRI04330
         ST    R9,EOBUFFER                                              WRI04340
         XC    RCDCNTR,RCDCNTR    SET TOTAL RECORDS WRITTEN IN FILE=0   WRI04350
         SR    R7,R7              INITIALIZE # RECORDS WRITTEN THUS FAR WRI04360
         TM    RITFLAGA,SFORMAT      UTS SOURCE FORMAT ??               WRI04370
         BO    CON410                YES, GO HANDLE THAT FORMAT         WRI04380
         L     R8,BYTECNT   INITIALIZE # BYTES LEFT IN INPUT BUFFER     WRI04390
         L     R9,ABUFFER   INITIALIZE INPUT BUFFER POINTER             WRI04400
         B     RITELOOP     CONTINUE ON                                 WRI04410
CON410   DS    0H                                                       WRI04420
         L     R9,ABUFFER         INITIALIZE NEXT BLOCK ADDRESS         WRI04430
         B     CON411             SKIP NEXT LINE FIRST TIME THROUGH     WRI04440
DONEXTB  DS    0H                                                       WRI04450
         L     R9,NEXTBLOK  SET INPUT BUFFER POINTER TO START OF BLOCK  WRI04460
CON411   LA    R10,1740(R9)     COMPUTE ADDRESS OF FOLLOWING BLOCK      WRI04470
         ST    R10,NEXTBLOK     REMEMBER START OF NEXT BLOCK            WRI04480
         MVC   SAVERCNT,1722(R9)    SAVE COUNT OF # RCDS IN THIS BLOCK  WRI04490
         LH    R8,8(R9)     INITIALIZE # BYTES LEFT IN THIS BLOCK       WRI04500
         SLL   R8,1         MULTIPLY BY 2 TO GET BYTE COUNT             WRI04510
         LA    R9,10(R9)    SET INPUT BUFFER POINTER TO START OF DATA   WRI04520
         A     R7,RCDCNTR   ADD NUMBER RECORDS WRITTEN IN LAST BLOCK    WRI04530
         ST    R7,RCDCNTR   TO TOTAL WRITTEN IN CMS FILE THUS FAR       WRI04540
         SR    R7,R7        SET # RCDS WRITTEN THIS BLOCK THUS FAR = 0  WRI04550
RITELOOP DS    0H                                                       WRI04560
         C     R9,EOBUFFER      ARE WE PAST END OF THE INPUT BUFFER ??  WRI04570
         BNL   EXITLOOP                                                 WRI04580
*    FIRST FIND THE LENGTH OF THE INPUT RECORD.  PUT IN R10             WRI04590
         TM    RITFLAGA,FIXEDUTS     IS THE INPUT IN FIXED FORMAT ??    WRI04600
         BNO   CON413                NOPE, GO HANDLE VARIABLE LENGTH    WRI04610
         L     R10,UTSLRECL     INPUT RECORD LENGTH IS ALWAYS THE SAME  WRI04620
         B     CON419           CONTINUE ON                             WRI04630
CON413   DS    0H                                                       WRI04640
         SH    R8,=H'2'         DECREMENT 2 BYTES FOR RECORD LENGTH     WRI04650
         BM    ERROR18          THERE WASN'T 2 BYTES THERE TO TAKE      WRI04660
         CLC   0(2,R9),=X'FFFF'   IS THIS AN END-OF-BLOCK MARKER ??     WRI04670
         BE    QUITLOOP           ABORT OUT OF THIS WRITE LOOP IF SO    WRI04680
         TM    RITFLAGA,SFORMAT                                         WRI04690
         BNO   CON414                                                   WRI04700
         CLC   0(2,R9),=X'0000'     IF SOURCE FORMAT AND I SEE A        WRI04710
         BE    DONEXTB              ZERO LENGTH, GO TO NEXT BLOCK.      WRI04720
CON414   DS    0H                                                       WRI04730
         CLC   0(2,R9),=X'0000'     IF NOT SOURCE FORMAT & ZERO LENGTH, WRI04740
         BE    QUITLOOP             THEN THAT'S AN END-OF-FILE MARKER.  WRI04750
*    IF THE HIGH ORDER BIT IN THE RECORD LENGTH IS ON, THEN THIS RECORD WRI04760
*    GETS "TABBED" OVER 6 POSITIONS.  SO I'LL HAVE TO INSERT THE 6      WRI04770
*    BLANKS IN THE RECORD.  NOTICE THAT A LENGTH OF X'8000' WILL RESULT WRI04780
*    IN A RECORD WITH 6 BLANKS IN IT.                                   WRI04790
         TM    0(R9),X'80'      IS THE TAB BIT ON IN THE INPUT ??       WRI04800
         BNO   CON418           NO, CONTINUE ON                         WRI04810
         NI    0(R9),X'7F'     TURN IT OFF BEFORE YOU PICK IT UP        WRI04820
         LH    R10,0(R9)       GET THE INPUT RECORD'S LENGTH            WRI04830
         SLL   R10,1           MULTIPLY BY 2 TO GET # BYTES IN RECORD   WRI04840
         LA    R10,6(R10)      ADD 6 MORE 'CAUSE OF THE BLANKS          WRI04850
         SH    R9,=H'4'        BACK UP INPUT BUFFER TO ALLOW FOR BLANKS WRI04860
         MVC   0(6,R9),=CL6' ' MOVE IN 6 BLANKS 'CAUSE OF THE TAB       WRI04870
         LA    R8,6(R8)        THERE'S 6 MORE BYTES IN INPUT NOW        WRI04880
         B     CON419                                                   WRI04890
CON418   DS    0H    IT'S NOT A TABBED VARIABLE LENGTH INPUT RECORD     WRI04900
*                    IT'S JUST A NORMAL ONE.  GET THIS RECORD'S LENGTH  WRI04910
         LH    R10,0(R9)                                                WRI04920
         SLL   R10,1            MULTIPLY BY 2 TO GET # BYTES IN RECORD  WRI04930
         LA    R9,2(R9)         BUMP PAST LENGTH IN INPUT STREAM        WRI04940
CON419   DS    0H                                                       WRI04950
*    AT THIS POINT  R8 = NUMBER OF BYTES LEFT IN INPUT STREAM AFTER     WRI04960
*                        GETTING THE LENGTH (MIGHT BE ZERO)             WRI04970
*                   R9 = STARTING ADDRESS OF THE INPUT DATA             WRI04980
*                  R10 = NUMBER OF BYTES IN THIS INPUT RECORD           WRI04990
         C     R10,BIGGEST      IS THIS THE BIGGEST RECORD THUS FAR ??  WRI05000
         BNH   CON420           NOPE, DON'T EXCHANGE                    WRI05010
         ST    R10,BIGGEST      ELSE WE'VE GOT A NEW BIGGEST RECORD     WRI05020
CON420   DS    0H                                                       WRI05030
*    NOW, GET THE OUTPUT RECORD'S LENGTH, WHICH IS GOING TO DEPEND ON   WRI05040
*    THE CMS FILE'S RECORD FORMAT.                                      WRI05050
         LR    R12,R10             ASSUME OUTPUT LRECL = INPUT LRECL    WRI05060
         TM    RITFLAGA,FIXEDCMS   I.E. ASSUME VARIABLE LENGTH CMS FILE WRI05070
         BNO   CON421              BRANCH IF I GUESSED RIGHT            WRI05080
         L     R12,FSCBSIZE        ELSE PICK UP THE OUTPUT RECORD SIZE  WRI05090
         CR    R10,R12       IS THE INPUT RECORD > THE OUTPUT RECORD ?? WRI05100
         BNH   CON421        IF NOT, THEN IT WON'T GET TRUNCATED        WRI05110
         OI    RITFLAGA,TRUNC      REMEMBER WE'VE TRUNCATED A RECORD    WRI05120
CON421   DS    0H                                                       WRI05130
*    AT THIS POINT  R8 = NUMBER OF BYTES LEFT IN INPUT STREAM AFTER     WRI05140
*                        GETTING THE LENGTH (STILL MIGHT BE ZERO)       WRI05150
*                   R9 = STARTING ADDRESS OF THE INPUT DATA             WRI05160
*                  R10 = NUMBER OF BYTES IN THIS INPUT RECORD           WRI05170
*                  R12 = NUMBER OF BYTES IN THE OUTPUT RECORD           WRI05180
*              OUTBUFR = STARTING ADDRESS OF THE OUTPUT BUFFER          WRI05190
*    NOW MOVE THIS INPUT RECORD TO THE OUTPUT BUFFER.  IF THE RECORD    WRI05200
*    IS GOING TO NEED PADDING, THE MVCL INSTRUCTION WILL DO IT FOR US.  WRI05210
*    FOR THE MVCL,                                                      WRI05220
*        R14 = DESTINATION ADDRESS (OUTBUFR)                            WRI05230
*        R15 = DESTINATION LENGTH (R12)                                 WRI05240
*        R0  = SOURCE ADDRESS (R9)                                      WRI05250
*        R1  = PAD CHARACTER (PADCHAR) IN THE HIGH ORDER BYTE AND       WRI05260
*              THE SOURCE LENGTH IN THE OTHER THREE BYTES               WRI05270
*              (SMALLER OF R10 AND R8).                                 WRI05280
         L     R14,OUTBUFR     GET THE ADDRESS OF THE OUTPUT BUFFER     WRI05290
         LR    R15,R12         AND THE OUTPUT RECORD LENGTH             WRI05300
         LR    R0,R9           SHIFT INPUT RECORD STARTING ADDRESS      WRI05310
         LR    R1,R10          GET LENGTH OF INPUT RECORD               WRI05320
         CR    R10,R8          HAVE WE RUN OUT OF INPUT DATA YET ??     WRI05330
         BNH   CON422          NOPE, WE'RE STILL OK                     WRI05340
         LR    R1,R8           ELSE WE DON'T HAVE ENOUGH INPUT DATA     WRI05350
         OI    RITFLAGA,LASTINC      TO COMPLETE THIS OUTPUT RECORD     WRI05360
CON422   DS    0H                                                       WRI05370
*    R1 = LENGTH OF THIS INPUT RECORD.  UPDATE OUR INPUT BUFFER         WRI05380
         SR    R8,R1           POINTERS BEFORE PUTTING IN THE PAD CHAR. WRI05390
         AR    R9,R1           POINT TO THE NEXT INPUT RECORD           WRI05400
 TM TEST0108,TEST3                                                      WRI05410
 BNO GOGO                                                               WRI05420
 STM R13,R2,JUNK                                                        WRI05430
 LINEDIT TEXT='MVCL TO ......, LENGTH = ..........',SUB=(HEXA,JUNK+4,DE-WRI05440
               CA,JUNK+8),RENT=NO                                       WRI05450
 LINEDIT TEXT='   FROM ......, LENGTH = ..........',SUB=(HEXA,JUNK+12,D-WRI05460
               ECA,JUNK+16),RENT=NO                                     WRI05470
  LM R13,R2,JUNK                                                        WRI05480
  B GOGO                                                                WRI05490
JUNK DS 6F                                                              WRI05500
GOGO DS  0H                                                             WRI05510
         ICM   R1,B'1000',PADCHAR        GET THE PAD CHARACTER          WRI05520
         MVCL  R14,R0                    PREPARE THE OUTPUT RECORD      WRI05530
*    AT THIS POINT  OUTBUFR = STARTING ADDRESS OF THE OUTPUT RECORD     WRI05540
*                       R8  = NUMBER OF BYTES REMAINING IN THE INPUT    WRI05550
*                             BUFFER AFTER THIS INPUT RECORD            WRI05560
*                             (MIGHT BE LESS THAN OR EQUAL TO ZERO)     WRI05570
*                       R9  = ADDRESS OF NEXT INPUT RECORD              WRI05580
*                             (IF THERE IS ONE)                         WRI05590
*                       R12 = LENGTH OF THE OUTPUT RECORD               WRI05600
         L     R13,OUTBUFR                                              WRI05610
 TM TEST0108,TEST4                                                      WRI05620
 BNO GOGO2                                                              WRI05630
         LINEDIT TEXT='I''M GOING TO WRITE ...... BYTES STARTING AT ...-WRI05640
               ...',SUB=(DEC,(R12),HEX,(R13)),RENT=NO                   WRI05650
GOGO2    DS    0H                                                       WRI05660
 TM TEST0108,TEST8                                                      WRI05670
 BNO GOGO3                                                              WRI05680
         LINEDIT TEXT='THIS IS RECORD NUMBER .... IN THIS BLOCK AND THE-WRI05690
               RE''S ..... BYTES LEFT TO DO',SUB=(DEC,(R7),DEC,(R8)),RE-WRI05700
               NT=NO                                                    WRI05710
GOGO3    DS    0H                                                       WRI05720
         FSWRITE FSCB=(R3),BUFFER=(R13),BSIZE=(R12)                     WRI05730
         LTR   R15,R15         I TRUST EVERYTHING WENT OK.  DID IT ??   WRI05740
         BZ    CON500          GOOD.                                    WRI05750
         C     R15,=F'13'      WAS THE DISK FULL ??                     WRI05760
         BE    ERROR19         GO HANDLE FULL DISK                      WRI05770
         C     R15,=F'20'      WAS THE FILE NAME INVALID OR BLANK ??    WRI05780
         BE    ERROR20         BLANK FILE NAME GETS CAUGHT HERE.        WRI05790
         C     R15,=F'21'      WAS THE FILE TYPE INVALID OR BLANK ??    WRI05800
         BE    ERROR20         BLANK FILE TYPE GETS CAUGHT HERE.        WRI05810
         C     R15,=F'12'      IS THIS A READ ONLY DISK, MAYBE ??       WRI05820
         BE    ERROR21         AH, THAT'S IT.                           WRI05830
         B     ERROR22         IT THOSE AREN'T IT, THEN I GIVE UP.      WRI05840
CON500   DS    0H                                                       WRI05850
         LA    R7,1(R7)    BUMP RECORD COUNTER                          WRI05860
         TM    RITFLAGA,SFORMAT      UTS SOURCE FORMAT ??               WRI05870
         BO    CON510                YES, GO HANDLE THAT FORMAT         WRI05880
         C     R9,EOBUFFER      ARE WE PAST END OF THE INPUT BUFFER ??  WRI05890
         BL    RITELOOP         NO, CONTINUE WRITING DATA TO CMS FILE.  WRI05900
         B     EXITLOOP         ELSE, EXIT THIS LOOP.  WE'RE DONE.      WRI05910
CON510   DS    0H                                                       WRI05920
         CH    R7,SAVERCNT   HAVE WE DONE ALL THE RCDS IN THIS BLOCK ?? WRI05930
         BNL   DONEXTB       YES, GO DO THE NEXT BLOCK.                 WRI05940
         LTR   R8,R8       IS THERE ANY MORE DATA IN THIS BLOCK ??      WRI05950
         BNP   DONEXTB     NO, GO DO NEXT BLOCK (IF THERE IS ONE).      WRI05960
         B     RITELOOP    ELSE, CONTINUE WRITING INTO CMS FILE.        WRI05970
QUITLOOP DS    0H           WE FOUND A END-OF-FILE OR END-OF-BLOCK      WRI05980
         LTR   R8,R8        DID WE END EXACTLY AT THE END OF THE INPUT? WRI05990
         BZ    CON600       YES, DON'T CALL IT AN ERROR, ELSE IT'S A    WRI06000
         MVC   RETCODE,=X'00000004'     PREMATURE EOF OR EOB            WRI06010
CON600   DS    0H                                                       WRI06020
EXITLOOP DS    0H                                                       WRI06030
         TM    RITFLAGA,LASTINC        IF LAST INPUT RECORD WAS CHOPPED WRI06040
         BNO   LEAVE                                                    WRI06050
         CLC   RETCODE,=F'0'           AND NO OTHER ERROR OCCURRED,     WRI06060
         BNE   LEAVE                                                    WRI06070
         MVC   RETCODE,=X'00000008'    LAST INPUT RECORD WAS INCOMPLETE WRI06080
LEAVE    DS    0H                                                       WRI06090
         A     R7,RCDCNTR       ADD RECORDS WRITTEN THIS BLOCK TO TOTAL WRI06100
         ST    R7,RCDCNTR       REMEMBER TOTAL # RECORDS YOU WROTE      WRI06110
         FSCLOSE FSCB=MYFSCB                                            WRI06120
 TM TEST0108,TEST5                                                      WRI06130
 BNO SKIP2                                                              WRI06140
         LINEDIT TEXT='THE FILE JUST WRITTEN WAS ........ ........ .',S-WRI06150
               UB=(CHARA,PARM4,CHARA,PARM5,CHARA,PARM6),RENT=NO         WRI06160
SKIP2    EQU   *                                                        WRI06170
*    PREPARE REPLY CONTROL BLOCK.  YOU'LL ONLY BE HERE IF THINGS        WRI06180
*    WENT OK WITH NO ERRORS OR PREMATURE END-OF-FILE OR END-OF-BLOCK.   WRI06190
*    1)  IF THIS WAS A DA WRITE, ASSUME HE'S GOING TO CONTINUE          WRI06200
*        TO DA WRITE INTO THIS FILE RIGHT AFTER WHERE HE LEFT OFF.      WRI06210
*        CALCULATE THE STARTING RECORD NUMBER FOR THE NEXT DA           WRI06220
*        WRITE, WHICH'LL BE THE STARTING RECORD NUMBER FOR THIS         WRI06230
*        WRITE + THE NUMBER OF RECORDS I WROTE THIS TIME.               WRI06240
*        CONVERT THIS NUMBER TO EBCDIC AND PUT IT IN PARM10.            WRI06250
*    2)  IF THIS WASN'T A DA WRITE, REPLACE THE SUBFUNCTION             WRI06260
*        WITH 'APPEND', ASSUMING HE'LL WANT TO APPEND, OR               WRI06270
*        CONTINUE TO APPEND, TO THE END OF THIS FILE.                   WRI06280
*    3)  PUT THE CMS FILE'S CHARACTERISTICS (FIXED OR VARIABLE LENGTH,  WRI06290
*        LRECL, AND NUMBER OF RECORDS) IN PARM14.  ALSO PUT THE SIZE    WRI06300
*        OF THE BIGGEST RECORD I FOUND IN THE INPUT STREAM THERE.       WRI06310
*    4)  PUT THE RETURN CODE IN PLACE AND SET THE NUMBER OF DATA        WRI06320
*        BYTES FOLLOWING THIS CONTROL BLOCK TO ZERO, BOTH IN            WRI06330
*        PARM15.                                                        WRI06340
*    |       |       |       |       |       |       |       |       |  WRI06350
*    |       |       |       |       |       |       |       |       |  WRI06360
*    |---------------------------------------------------------------|  WRI06370
*    |             TODAY'S DATE IN MM/DD/YY FORMAT                   |  WRI06380
*    |---------------------------------------------------------------|  WRI06390
*    |             CURRENT TIME IN HH:MM:SS FORMAT                   |  WRI06400
*    |---------------------------------------------------------------|  WRI06410
*    | F | V | FREE  |    CMS FILE   |  # RECORDS IN |    BIGGEST    |  WRI06420
*    |       |       |     LRECL     |    CMS FILE   |  INPUT RECORD |  WRI06430
*    |---------------------------------------------------------------|  WRI06440
*    |  RETCODE  |    NUMBER OF DATA BYTES FOLLOWING THIS = 0        |  WRI06450
*    |---------------------------------------------------------------|  WRI06460
         TM    RITFLAGB,DA                                              WRI06470
         BO    CON900              GO DO WHAT YOU HAVE TO FOR DA WRITE  WRI06480
         MVC   PARM2,=CL8'APPEND'  ASSUME NEXT WRITE WILL BE AN APPEND  WRI06490
         B     CON910                                                   WRI06500
CON900   EQU   *                                                        WRI06510
         L     R12,STARTRCD        COMPUTE THE NEXT STARTING RECORD #   WRI06520
         A     R12,RCDCNTR                                              WRI06530
         CVD   R12,TEMPA                                                WRI06540
         OI    TEMPA+7,X'0F'                                            WRI06550
         UNPK  TEMPB,TEMPA                                              WRI06560
         MVC   PARM10,TEMPB        MOVE IN STARTING RCD # FOR NEXT READ WRI06570
CON910   EQU   *                                                        WRI06580
         LA    R8,PARM4        GET ADDRESS OF FILE ID (FN FT FM)        WRI06590
         FSSTATE (R8)          GET THIS FILE'S FST ??                   WRI06600
         LTR   R15,R15         THE FSSTATE SHOULD NEVER FAIL.  WE JUST  WRI06610
         BZ    CON915          GOT THROUGH WRITING THIS FILE.  BUT IF   WRI06620
         XC    PARM14,PARM14   IT DOES, JUST ZERO OUT PARM14 AND        WRI06630
         B     CON990          CONTINUE ON                              WRI06640
CON915   EQU   *                                                        WRI06650
         USING FSTD,R1         R1 IS POINTING TO THE FILE STATUS TABLE  WRI06660
         MVC   PARM14(1),FSTRECFM         THIS'LL BE C'F' OR C'V'       WRI06670
         MVC   PARM14+2(2),FSTLRECL+2     CMS FILE'S LRECL              WRI06680
         MVC   PARM14+4(2),FSTRECCT       # RECORDS IN CMS FILE         WRI06690
         MVC   PARM14+6(2),BIGGEST+2      BIGGEST INPUT RECORD I SAW    WRI06700
         DROP  R1              DON'T NEED THE FST ANYMORE               WRI06710
CON990   EQU   *                                                        WRI06720
*    FALL THROUGH TO PUT THE DATE, TIME, AND THE RETURN CODE IN THE     WRI06730
*    REPLY CONTROL BLOCK, AND THEN GIVE IT TO THE UTS MACHINE.          WRI06740
*    IF THERE WAS AN ERROR, WE COME TO HERE.                            WRI06750
*                                                                       WRI06760
*-------------------------------------------------------------*         WRI06770
*    GET THE TIME AND DATE FROM CP                            *         WRI06780
*-------------------------------------------------------------*         WRI06790
         LA    R1,CPDATA           ADDRESS OF DATA FROM DIAG            WRI06800
         DIAG  R1,R0,X'000C'       REQUEST DATE AND TIME FROM CP        WRI06810
*-------------------------------------------------------------*         WRI06820
*    CPDATA IS NOW IN THE FORMAT OF                           *         WRI06830
*           DC    CL8'MM/DD/YY'                               *         WRI06840
*           DC    CL8'HH:MM:SS'                               *         WRI06850
*           DS    2D     THE REST IS JUNK                     *         WRI06860
*-------------------------------------------------------------*         WRI06870
         MVC   PARM12,CPDATA                                            WRI06880
         MVC   PARM13,CPDATA+8                                          WRI06890
 TM TEST0108,TEST6                                                      WRI06900
 BNO SKIP1                                                              WRI06910
         LINEDIT TEXT='AFTER ........ RECORDS, THE RETURN CODE IS .....-WRI06920
               .',SUB=(DECA,RCDCNTR,HEXA,RETCODE),RENT=NO               WRI06930
SKIP1    DS    0H                                                       WRI06940
         MVC   PARM15(2),RETCODE+2                                      WRI06950
         MVC   PARM15+2(6),=X'000000000000'                             WRI06960
         LA    R0,128           REPLY CONTROL BLOCK = 128 BYTES BIG     WRI06970
         LA    R1,PARM0         STARTING AT PARM0                       WRI06980
         L     R15,AWRITUTS                                             WRI06990
         BALR  R14,R15          GO GIVE THE REPLY TO THE UTS MACHINE    WRI07000
WRITEBYE EQU   *                                                        WRI07010
         LM    R0,R14,REGSAVE     RESTORE CALLER'S REGISTERS            WRI07020
         BR    R14                                                      WRI07030
         EJECT                                                          WRI07040
ERROR1   DS    0H                                                       WRI07050
*    WE GOT AN ERROR FROM THE ACCESS ROUTINE.                           WRI07060
*    IF R15 = 04, THEN THIS UTS WAS NOT FOUND IN THE UTSCB CHAIN        WRI07070
*                 (CAN NEVER HAPPEN).  RETCODE = X'6004'                WRI07080
*    IF R15 = 08, THEN THIS USER WAS NOT FOUND IN THE USERCB CHAIN      WRI07090
*                 FOR THIS UTS.  RETCODE = X'4004'                      WRI07100
*    IF R15 = 12, THEN THIS DISK WAS NOT FOUND IN THE DISKCB CHAIN      WRI07110
*                 FOR THIS USER.  RETCODE = X'100C'                     WRI07120
*    IF R15 = 16, THEN THE DISK WAS FOUND, BUT THERE'S NOT A MINIDISK   WRI07130
*                 AT THAT ADDRESS (CONFIGURATION ERROR).                WRI07140
*                 RETCODE = X'4008'                                     WRI07150
*    IF R15 = 20, THEN SOME OTHER ERROR HAPPENED IN THE ACCESS          WRI07160
*                 ROUTINE.  RETCODE = X'5004'                           WRI07170
*    IF R15 = ??, THEN PROGRAMMING ERROR.  RETCODE = X'7004'            WRI07180
         OI    RITFLAGA,ERROR          YES, WE HAD AN ERROR             WRI07190
         C     R15,=F'4'                                                WRI07200
         BNE   ERR1A                                                    WRI07210
         MVC   RETCODE,=X'00006004'    UTS NOT FOUND (CAN'T HAPPEN)     WRI07220
         B     ERR1BYE                                                  WRI07230
ERR1A    C     R15,=F'8'                                                WRI07240
         BNE   ERR1B                                                    WRI07250
         MVC   RETCODE,=X'00004004'    USER NOT FOUND IN USERCB CHAIN   WRI07260
         B     ERR1BYE                                                  WRI07270
ERR1B    C     R15,=F'12'                                               WRI07280
         BNE   ERR1C                                                    WRI07290
         MVC   RETCODE,=X'0000100C'    DISK NOT FOUND IN DISKCB CHAIN   WRI07300
         B     ERR1BYE                                                  WRI07310
ERR1C    C     R15,=F'16'                                               WRI07320
         BNE   ERR1D                                                    WRI07330
         MVC   RETCODE,=X'00004008'    NO MINIDISK AT THAT ADDRESS      WRI07340
         B     ERR1BYE                                                  WRI07350
ERR1D    C     R15,=F'20'                                               WRI07360
         BNE   ERR1E                                                    WRI07370
         MVC   RETCODE,=X'00005004'    OTHER ERROR IN ACCESS ROUTINE    WRI07380
         B     ERR1BYE                                                  WRI07390
ERR1E    MVC   RETCODE,=X'00007004'    PROGRAMMING ERROR                WRI07400
ERR1BYE  B     CON990                                                   WRI07410
         EJECT                                                          WRI07420
ERROR2   DS    0H                                                       WRI07430
*    THIS GUY ISN'T ALLOWED TO WRITE ON THIS DISK.  IT PROBABLY IS A    WRI07440
*    READ ONLY DISK (I.E. THE WRITE PASSWORD = 'NONE').  REJECT THIS    WRI07450
*    WRITE REQUEST WITH A RETURN CODE = X'2004'                         WRI07460
         MVC   RETCODE,=X'00002004'                                     WRI07470
         B     CON990                                                   WRI07480
         SPACE 3                                                        WRI07490
ERROR3   DS    0H                                                       WRI07500
*    THIS GUY GAVE ME THE WRONG PASSWORD FOR THIS DISK.  REJECT THIS    WRI07510
*    WRITE REQUEST WITH A RETURN CODE = X'1010'                         WRI07520
         MVC   RETCODE,=X'00001010'                                     WRI07530
         B     CON990                                                   WRI07540
         SPACE 3                                                        WRI07550
ERROR4   DS    0H                                                       WRI07560
*    HE TOLD ME TO CREATE THIS FILE BUT THE FILE ALREADY EXISTS.        WRI07570
*    REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'201C'             WRI07580
         MVC   RETCODE,=X'0000201C'                                     WRI07590
         B     CON990                                                   WRI07600
         SPACE 3                                                        WRI07610
ERROR5   DS    0H                                                       WRI07620
*    THE FILE ID (FILE NAME OR FILE TYPE) HE GAVE ME HAS AN INVALID     WRI07630
*    CHARACTER IN IT.  REJECT THIS REQUEST WITH A RETURN CODE = X'1008' WRI07640
         MVC   RETCODE,=X'00001008'                                     WRI07650
         B     CON990                                                   WRI07660
         SPACE 3                                                        WRI07670
ERROR6   DS    0H                                                       WRI07680
*    WE GOT SOME KIND OF ERROR I DON'T UNDERSTAND WITH THE FSSTATE      WRI07690
*    MACRO.  REPORT THE ERROR WITH A RETURN CODE = X'5008'              WRI07700
         MVC   RETCODE,=X'00005008'                                     WRI07710
         B     CON990                                                   WRI07720
         SPACE 3                                                        WRI07730
ERROR7   DS    0H                                                       WRI07740
*    WE GOT SOME KIND OF ERROR WITH THE FSERASE MACRO.                  WRI07750
*    FIRST CHECK FOR A RETURN CODE = 36 = THIS IS A READ ONLY DISK.     WRI07760
*    IF SO,  REPORT THE ERROR WITH A RETURN CODE = X'400C'              WRI07770
*                       ELSE, IT'S A RETURN CODE = X'501C'              WRI07780
         C     R15,=F'36'         CHECK FOR READ ONLY DISK              WRI07790
         BE    ERR7CONT           GOTCHA                                WRI07800
         MVC   RETCODE,=X'0000501C'   WHO KNOWS WHAT IT IS ??           WRI07810
         B     CON990                                                   WRI07820
ERR7CONT MVC   RETCODE,=X'0000400C'                                     WRI07830
         B     CON990                                                   WRI07840
         SPACE 3                                                        WRI07850
ERROR8   DS    0H                                                       WRI07860
*    I COULDN'T FIND AN UNUSED FILENAME FOR THIS INCRVL WRITE REQUEST.  WRI07870
*    THE FOOL'S GOT OVER 1000 FILES ON THIS DISK ALL STARTING WITH THE  WRI07880
*    SAME CHARACTERS.  REPORT THE ERROR WITH A RETURN CODE = X'2018'    WRI07890
         MVC   RETCODE,=X'00002018'                                     WRI07900
         B     CON990                                                   WRI07910
         SPACE 3                                                        WRI07920
ERROR9   DS    0H                                                       WRI07930
*    INVALID SUBFUNCTION IN THIS REQUEST CONTROL BLOCK.  HE'S GOT       WRI07940
*    'WRITE' IN THE FUNCTION PARM (PARM1), BUT PARM2 IS NOT BLANK,      WRI07950
*    'CREATE', 'REPLACE', 'INCRVL', 'APPEND', OR 'DA'.  REJECT THIS     WRI07960
*    WRITE REQUEST WITH A RETURN CODE = X'101C'                         WRI07970
         MVC   RETCODE,=X'0000101C'                                     WRI07980
         B     CON990                                                   WRI07990
         SPACE 3                                                        WRI08000
ERROR10  DS    0H                                                       WRI08010
*    HE TRIED TO DO A DA WRITE AND THE CMS FILE DOES NOT EXIST.         WRI08020
*    WHAT CAN I DO NOW, BUT REJECT THIS WRITE REQUEST ??                WRI08030
*    RETURN CODE = X'2008'                                              WRI08040
         MVC   RETCODE,=X'00002008'                                     WRI08050
         B     CON990                                                   WRI08060
         SPACE 3                                                        WRI08070
ERROR11  DS    0H                                                       WRI08080
*    HE TRIED TO DO A DA WRITE INTO A VARIABLE LENGTH CMS FILE.  I      WRI08090
*    DON'T WANT TO SUPPORT THIS CAPABILITY.  IF HE WANTS TO DO THIS,    WRI08100
*    HE SHOULD MAKE THE CMS FILE FIXED LENGTH, NOT VARIABLE LENGTH.     WRI08110
*    REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'2014'             WRI08120
         MVC   RETCODE,=X'00002014'                                     WRI08130
         B     CON990                                                   WRI08140
         SPACE 3                                                        WRI08150
ERROR12  DS    0H                                                       WRI08160
*    THIS IS A DA WRITE AND THE STARTING RECORD NUMBER IS MISSING OR    WRI08170
*    INVALID.  I DON'T WANT TO DEFAULT TO THE BEGINNING OR THE END OF   WRI08180
*    THE FILE, 'CAUSE IF HE WENT TO THE TROUBLE TO DO A DA WRITE, THEN  WRI08190
*    I'M NOT GOING TO TRY TO SECOND GUESS HIM.  JUST REJECT THIS WRITE  WRI08200
*    REQUEST WITH A RETURN CODE = X'1014'                               WRI08210
         MVC   RETCODE,=X'00001014'                                     WRI08220
         B     CON990                                                   WRI08230
         SPACE 3                                                        WRI08240
ERROR13  DS    0H                                                       WRI08250
*    THIS IS A DA WRITE AND THE STARTING RECORD NUMBER IS LARGER THAN   WRI08260
*    THE NUMBER OF RECORDS IN THIS CMS FILE + 1 (THAT + 1 IS TO ALLOW   WRI08270
*    HIM TO DA WRITE AFTER THE END OF THIS FILE (I.E. APPEND)).         WRI08280
*    REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'200C'             WRI08290
         MVC   RETCODE,=X'0000200C'                                     WRI08300
         B     CON990                                                   WRI08310
         SPACE 3                                                        WRI08320
ERROR14  DS    0H                                                       WRI08330
*    PARM3, THE NUMBER OF BYTES THE UTS IS GOING TO SEND OVER IS        WRI08340
*    MISSING OR INVALID.                                                WRI08350
*    REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'1004'             WRI08360
         MVC   RETCODE,=X'00001004'                                     WRI08370
         B     CON990                                                   WRI08380
         SPACE 3                                                        WRI08390
ERROR15  DS    0H                                                       WRI08400
*    THE UTS INPUT WAS GOING TO BE IN FIXED LENGTH FORMAT AND PARM9,    WRI08410
*    THE LRECL OF THE INPUT, WAS INVALID, MISSING, OR ZERO.             WRI08420
*    REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'1018'             WRI08430
         MVC   RETCODE,=X'00001018'                                     WRI08440
         B     CON990                                                   WRI08450
         SPACE 3                                                        WRI08460
ERROR16  DS    0H                                                       WRI08470
*    WE GOT SOME KIND OF ERROR I DON'T UNDERSTAND WITH THE FSOPEN       WRI08480
*    MACRO.  REPORT THE ERROR WITH A RETURN CODE = X'500C'              WRI08490
         MVC   RETCODE,=X'0000500C'                                     WRI08500
         B     CON990                                                   WRI08510
         SPACE 3                                                        WRI08520
ERROR17  DS    0H                                                       WRI08530
*    WE GOT SOME KIND OF ERROR I DON'T UNDERSTAND WITH THE FSPOINT      WRI08540
*    MACRO.  THIS SHOULDN'T EVER HAPPEN 'CAUSE I CHECK FOR ALL          WRI08550
*    POSSIBLE ERRORS BEFORE I DO A FSPOINT.                             WRI08560
*    REPORT THE ERROR WITH A RETURN CODE = X'600C'                      WRI08570
         MVC   RETCODE,=X'0000600C'                                     WRI08580
         B     CON990                                                   WRI08590
         SPACE 3                                                        WRI08600
ERROR18  DS    0H                                                       WRI08610
*    I WAS GOING THROUGH THE VARIABLE LENGTH INPUT AND EVERYTHING       WRI08620
*    WAS FINE, UNTIL I CAME TO THE END OF THE INPUT AND THERE WAS       WRI08630
*    ONLY 1 BYTE LEFT.  NOT ENOUGH TO PICK UP THE LENGTH OF THE         WRI08640
*    NEXT RECORD.  REPORT THIS CONDITION WITH A RETURN CODE = X'2010'   WRI08650
         MVC   RETCODE,=X'00002010'                                     WRI08660
         B     LEAVE                                                    WRI08670
         SPACE 3                                                        WRI08680
ERROR19  DS    0H                                                       WRI08690
*    I FOUND OUT THIS DISK IS FULL WHEN I TRIED TO DO A WRITE TO IT.    WRI08700
*    REPORT THIS ERROR WITH A RETURN CODE = X'5024'                     WRI08710
         MVC   RETCODE,=X'00005024'                                     WRI08720
         B     LEAVE                                                    WRI08730
         SPACE 3                                                        WRI08740
ERROR20  DS    0H                                                       WRI08750
*    THE FSWRITE DETECTED AN INVALID FILE ID (EITHER FILE NAME OR FILE  WRI08760
*    TYPE).  THIS ERROR SHOULD HAVE ALREADY BEEN CAUGHT BEFORE A WRITE  WRI08770
*    WAS ATTEMPTED TO THIS FILE, BUT A BLANK FN OR FT DOES GET THIS     WRI08780
*    FAR.  REJECT THIS REQUEST WITH A RETURN CODE = X'1008' AND GO TO   WRI08790
*    LEAVE TO CLOSE THE FILE, NOT CON990 LIKE ERROR5 DID.               WRI08800
         MVC   RETCODE,=X'00001008'                                     WRI08810
         B     LEAVE                                                    WRI08820
         SPACE 3                                                        WRI08830
ERROR21  DS    0H                                                       WRI08840
*    THIS GUY TRIED TO WRITE TO A FILE THAT I ONLY HAVE READ ACCESS     WRI08850
*    TO.  IT'S ONLY A READ ONLY DISK TO ME, SO IT CAN'T BE READ/WRITE   WRI08860
*    TO HIM.  THIS IS A CONFIGURATION ERROR, SINCE THIS DISK SHOULDN'T  WRI08870
*    HAVE BEEN ALLOCATED TO THIS GUY IN R/W MODE IN THE FIRST PLACE.    WRI08880
*    REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'400C' AND         WRI08890
*    GO TO LEAVE TO CLOSE THE FILE.                                     WRI08900
         MVC   RETCODE,=X'0000400C'                                     WRI08910
         B     LEAVE                                                    WRI08920
         SPACE 3                                                        WRI08930
ERROR22  DS    0H                                                       WRI08940
*    I GOT SOME OTHER KIND OF ERROR (NOT ANY OF THE ABOVE) FROM THE     WRI08950
*    FSWRITE MACRO.  REPORT THIS ERROR WITH A RETURN CODE = X'5020'     WRI08960
         MVC   RETCODE,=X'00005020'                                     WRI08970
         B     LEAVE                                                    WRI08980
         EJECT                                                          WRI08990
CPDATA   DS    4D        FOR CP TO PUT THE CURRENT DATE AND TIME        WRI09000
REGSAVE  DS    15F       READ ROUTINE SAVE AREA                         WRI09010
SAVEAREA DS    20F       MY SAVE AREA FOR WHEN I CALL OTHER SUBROUTINES WRI09020
UTSPARMS DS    CL28      SENT TO THE UTS IN THE REPLY CONTROL BLOCK     WRI09030
         ORG   UTSPARMS                                                 WRI09040
STARTRCD DS    F         STARTING RECORD NUMBER IN THE CMS FILE         WRI09050
BYTECNT  DS    F         NUMBER OF BYTES THE UTS WILL SEND              WRI09060
UTSLRECL DS    F         LRECL OF FIXED-LENGTH UTS DATA                 WRI09070
RETCODE  DS    F         RETURN CODE                                    WRI09080
RCDCNTR  DS    F         RECORD COUNTER (# OF RECORDS I'VE WRITTEN)     WRI09090
BIGGEST  DS    F         BIGGEST RECORD SIZE IN INPUT STREAM            WRI09100
NEXTSR#  DS    F         STARTING RECORD NUMBER FOR THE NEXT WRITE      WRI09110
         ORG                                                            WRI09120
TEMPA    DS    D         TEMPORARY WORK AREAS FOR UNPACKING, ETC        WRI09130
TEMPB    DS    D         TEMPORARY WORK AREAS FOR UNPACKING, ETC        WRI09140
OUTBUFR  DS    F         STARTING ADDRESS OF THE OUTPUT BUFFER          WRI09150
NEXTBLOK DS    F         ADDRESS OF NEXT SOURCE FORMAT INPUT BLOCK      WRI09160
EOBUFFER DS    F         ADDRESS OF LAST BYTE IN INPUT BUFFER + 1       WRI09170
VL       DS    PL4                                                      WRI09180
SAVERCNT DS    H         COUNT OF # RECORDS IN THIS SOURCE FORMAT BLOCK WRI09190
PADCHAR  DS    C         PAD CHARACTER IN CASE WE'RE WRITING A FIXED    WRI09200
*                        LENGTH CMS FILE AND THIS INPUT RECORD LENGTH   WRI09210
*                        IS LESS THAN THE CMS FILE'S LRECL              WRI09220
RITFLAGA DC    X'00'        STATUS FLAG FOR WRITE ROUTINE               WRI09230
FIXEDCMS     EQU   X'80'      1 = THE CMS FILE HAS FIXED LENGTH RECORDS WRI09240
*                                 ELSE IT HAS VARIABLE LENGTH RECORDS   WRI09250
FIXEDUTS     EQU   X'40'      1 = THE INPUT DATA IS IN UTS FIXED        WRI09260
*                                 FORMAT ELSE IT'S IN VARIABLE FORMAT   WRI09270
TRUNC        EQU   X'20'      1 = TRUNCATION OF INPUT DATA HAS OCCURRED WRI09280
LASTINC      EQU   X'10'      1 = THE LAST INPUT RECORD WAS INCOMPLETE  WRI09290
NEW          EQU   X'08'      1 = I'M CREATING A NEW FILE               WRI09300
ERROR        EQU   X'04'      1 = I GOT SOME KIND OF ERROR              WRI09310
SFORMAT      EQU   X'02'      1 = THIS INPUT IS IN UTS SOURCE FORMAT    WRI09320
*                                                                       WRI09330
RITFLAGB DC    X'00'        ANOTHER FLAG FOR THE WRITE ROUTINE          WRI09340
CREATE       EQU   X'80'      1 = THIS IS A CREATE WRITE                WRI09350
REPLACE      EQU   X'40'      1 = THIS A WRITE AND REPLACE              WRI09360
INCRVL       EQU   X'20'      1 = THIS IS A WRITE AND INCREMENT THE     WRI09370
*                                 VERSION LEVEL                         WRI09380
APPEND       EQU   X'10'      1 = THIS IS A WRITE AND APPEND            WRI09390
DA           EQU   X'08'      1 = THIS IS A DIRECT ACCESS WRITE         WRI09400
MYFSCB   FSCB                                                           WRI09410
         FSCBD                                                          WRI09420
WRITE    CSECT            GO BACK TO NORMAL CSECT                       WRI09430
         LTORG                                                          WRI09440
*                                                                       WRI09450
         FSTD                                                           WRI09460
WRITE    CSECT            GO BACK TO NORMAL CSECT                       WRI09470
         ICDATA                                                         WRI09480
         END                                                            WRI09490