//PRINTOFF  JOB (TSO),
//             'Install PRINTOFF',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//*
//*                                                                     00020000
//*------------------------------------------------------------------*  00030000
//*  INSTALL THE PRINTOFF TSO COMMAND FROM CBT -                     *  00040000
//*    ASSEMBLE AND LINK TO TSO COMMAND LIBRARY (SYS2.CMDLIB)        *  00050000
//*    COPY HELP TEXT TO TSO HELP LIBRARY (SYS2.HELP)                *  00060000
//*------------------------------------------------------------------*  00070000
//*                                                                     00080000
//*                                                                     00090000
//ASM     EXEC ASMFC,PARM.ASM='NODECK,LOAD,LIST'                        00100000
//SYSLIB   DD  DSN=SYS1.MACLIB,DISP=SHR                                 00110000
//         DD  DSN=SYS1.AMODGEN,DISP=SHR                                00120000
//SYSPRINT DD  SYSOUT=*                                                 00130000
//SYSIN    DD  *                                                        00140000
*                                                                               
*  NOTE TO FUTURE ASSEMBLERS ... PRINTOFF NORMALLY RESIDES IN                   
*  A LINKLIB WITH  A L I A S E S  PRINTO AND PO.                                
*  THE HELP ENTRY SHOULD BE ASSIGNED THE SAME ALIASES.                          
*                                                                               
PRINTOFF TITLE 'IPO-SUPPLIED PRINT COMMAND - MODIFIED BY GTEL, ARAMCO, C        
               WFB      '                                           WFB         
***********************************************************************         
*                                                                     *         
*             MODULE NAME = PRINTOFF                                  *         
*                                                                     *         
*             DESCRIPTIVE NAME =  IPO SUPPLIED PRINT COMMAND FOR      *         
*                TSO FOREGROUND EXECUTION                             *         
*                                                                     *         
*             COPYRIGHT = NONE                                        *         
*                                                                     *         
*             STATUS = RELEASE 01.0 OF IPO                            *         
*                                                                     *         
*             FUNCTION =                                              *         
*                PRINTS A DATASET(S) WHICH IS SEQUENTIAL OR PARTIONED *         
*                ALLOWING THE USER TO SPECIFY OUTPUT CLASS, COPIES,   *         
*                DESTINATION AND HOLD/NOHOLD.  ALSO ALLOWS THE USER   *         
*                TO SPECIFY LIST/NOLIST, PRINT/NOPRINT, VOLUME,       *         
*                FOLD/NOFOLD, DS/SS, LINELENGTH AND PAGELENGTH     GTEL         
*                LIST IF PDS MEMBER NAMES ARE ONLY TO BE LISTED.      *         
*                PRINT IF PDS MEMBERS ARE ONLY TO BE PRINTED.         *         
*                SEE 'CHANGE ACTIVITY' FOR ADDITIONAL OPTIONS.      WFB         
*                                                                     *         
*                OPERATION =                                          *         
*                   BUILD PARS, DAIR, AND PUTLINE PARAMETER LISTS.    *         
*                   CALL PARS TO PARSE COMMAND BUFFER.                *         
*                   ALLOCATE DATASET AND DETERMINE IF PDS OR          *         
*                      SEQUENTIAL.                                    *         
*                   DETERMINE WHAT FUNCTIONS WERE TO BE PERFORMED     *         
*                      FOR THIS DATASET IF PDS.                       *         
*                   ALLOCATE SYSOUT DATASETS WHEN SOMETHING IS        *         
*                      FOUND TO BE PRINTED.                           *         
*                   PROCESS NEXT DATASET IN LIST.                     *         
*                   AT END OF LIST CLOSE DATASETS AND FREE ANY        *         
*                      SYSOUT DATASETS AND INPUT DATASETS.         GTEL         
*                   DATSETS WILL BE PRINTED AS EITHER VBA OR VBM.     *         
*                                                                     *         
*              NOTES =                                                *         
*                                                                     *         
*                 DEPENDENCIES = CHARACTER SET IS EBCDIC.  REASSEMBLE *         
*                    IF A DIFFERENT CHARACTER SET IS NEEDED.          *         
*                                                                     *         
*                                                                     *         
*                 RESTRICTIONS = DATASETS MUST HAVE LRECL NOT       WFB         
*                    GREATER THAN 32,760 AND MUST NOT               WFB         
*                    CONTAIN SPANNED RECORDS.  IN ADDITION,        GTEL         
*                    IF PAGELEN, DS, OR SS IS SPECIFIED, ALL       GTEL         
*                    OTHER CARRIAGE CONTROL WILL BE IGNORED.       GTEL         
*                                                                     *         
*                 REGISTER CONVENTIONS = STANDARD CONVENTIONS.        *         
*                    REGISTERS 0 TO 10 = WORK REGISTERS               *         
*                    REGISTERS 11,12   = ADDRESSIBILITY TO         GTEL         
*                                        PRINTOFF CSECT            GTEL         
*                    REGISTER  13      = SAVE AREA REGISTER AND       *         
*                                        ADDRESSABILITY TO GETMAINED  *         
*                                        WORK AREA                    *         
*                    REGISTERS 14,15   = WORK REGISTERS               *         
*                                                                     *         
*                PATCH LABEL = PATCH, UNUSED AND INTIALIZED TO        *         
*                   DC 20S(*)                                      WFB*         
*                                                                     *         
*                TSO COMMAND SYNTAX                                 WFB         
* PRINTOFF (DSLIST)/*  DDNAME(DDNAME)/FILE(DDNAME)                    *         
*          UNIT(UNIT-TYPE)  VOLUME(VOLSER)     NOMESSAGES/NOMSGS      *         
*          CLASS(CLASS)     DEST(DESTINATION)  COPIES(NNN)            *         
*          HOLD/NOHOLD      LIST/NOLIST        PRINT/NOPRINT          *         
*          FORMS(FORM)      FCB(FCB)           TRAIN(IMAGE)/UCS(IMAGE)*         
*          HEADING/NOHEADING                   CAPS/ASIS/FOLD/NOFOLD  *         
*          NOCC/SINGLESPACE/SS/DOUBLESPACE/DS  ASA                    *         
*          LINELENGTH(NNN)/LL(NNN)             PAGELENGTH(NNN)/PL(NNN)*         
*          BURST/NOBURST    FLASH(FLASH-NAME)  CHARS(CHARSET-NAME(S)) *         
*          PROG(PROGNAME)   UDKFONT(FONT-NAME)                        *         
* REQUIRED -- DSLIST OR * IF DDNAME(...)                              *         
* ALIASES  -- PRINTO, PO                                              *         
* DEFAULTS -- CLASS(A), COPIES(1), NOHOLD, LIST, PRINT, FORM($TST),   *         
*             HEADING, ASIS, LINELENGTH(132), PAGELENGTH(60), NOBURST,*         
*             SINGLESPACE IF PAGELENGTH(...) OR IF INPUT RECFM NOT A/M*         
*                                                                     *         
*             MODULE TYPE = PROCEDURE                                 *         
*                                                                     *         
*                PROCESSOR = ASM                                      *         
*                                                                     *         
*                MODULE SIZE = 13K BYTES                              *         
*                                                                     *         
*                ATTRIBUTES = SCHEDULER KEY 8, REENTRANT,             *         
*                   PROBLEM PROGRAM STATE                             *         
*                                                                     *         
*             ENTRY POINTS = PRINTOFF (ONLY ENTRY POINT)              *         
*                                                                     *         
*                LINKAGE =                                            *         
*                   FROM TERMINAL MONITOR PROGRAM AS A COMMAND        *         
*                                                                     *         
*             INPUT = REGISTER 1 POINTS TO COMMAND PROCESSOR          *         
*                PARAMETER LIST MAPPED BY IKJCPPL MACRO               *         
*                                                                     *         
*             OUTPUT = NONE                                           *         
*                                                                     *         
*             EXIT - NORMAL = AT PROGRAM END VIA BRANCH REGISTER 14   *         
*                                                                     *         
*                OUTPUT = NONE                                        *         
*                                                                     *         
*                RETURN CODE = ZERO                                   *         
*                                                                     *         
*             EXIT - ERROR = NONE - PROGRAM WILL DISPLAY DECIMAL      *         
*                RETURN CODE AND RETURN VIA BRANCH REGISTER 14        *         
*                                                                     *         
*                OUTPUT = NONE                                        *         
*                                                                     *         
*                RETURN CODE = ZERO                                   *         
*                                                                     *         
*             EXTERNAL REFERENCES =                                   *         
*                                                                     *         
*                ROUTINES = IKJPARS, DAIRFAIL, GNRLFAIL, PUTLINE      *         
*                   IKJEFLPA  (SEE NOTE IN 'CHANGE ACTIVITY')       WFB         
*                                                                     *         
*                DATA AREAS = NONE                                    *         
*                                                                     *         
*                CONTROL BLOCKS = CPPL, PPL, DAPL, DCB, DAPB, CVT,    *         
*                   S99RBP, S99RB, S99TUPL, S99TUNIT, S99TUFLD,       *         
*                   GFPARMS, DFPARMS, IOPL, IOPB                      *         
*                                                                     *         
*             TABLES = DATA AREA TO BE GETMAINED.  MAPPED BY DSECT    *         
*                BEGINNING AT LABEL WORKAREA                        WFB         
*                                                                     *         
*             MACROS = SAVE, GETMAIN, CALLTSSR, LINK, TPUT, FREEMAIN, *         
*                   OPEN, PUT, GET, CLOSE, RDJFCB, IKJRLSA, DYNALLOC, *         
*                   DCB, IKJPARM, IKJPOSIT, IKJKEYWD, IKJNAME,        *         
*                   IKJSUBF, IKJIDENT, IKJENDP, IKJDAP08, IKJDAP18,   *         
*                   IKJDAPL, IKJCPPL, IKJPPL, CVT, IEFZB4D0, IKJIOPL, *         
*                   IEFZB4D2, DCBD, IKJEFFGF, IKJEFFDF, PUTLINE       *         
*                                                                     *         
*             CHANGE ACTIVITY = 3800 SUPPORT ADDED VIA SETPRT   ARAMCO*         
*                               MAY 1981                        ARAMCO*         
*                                                                     *         
*             MODIFIED BY SAM LEPORE, WFB: 01/86                    WFB         
*               * CORRECT ERROR, 'NOHEAD' CAUSED BLANK FIRST PAGE   WFB         
*               * CORRECT ERRORS IN LENGTH OF TEXTG THROUGH TEXTJ   WFB         
*               * INCREASE INPUT RECORD LIMIT TO 32,760             WFB         
*               * CHANGE DSNAME POSIT TO DSTHING TO ALLOW FOR DDN() WFB         
*               * CHANGE DEST KEYWORD TO ACCEPT 8 CHAR VALUE        WFB         
*               * CHANGE DEST KEYWORD TO ACCEPT NODE AND USERID     WFB         
*               * ADD DDNAME(...) KEYWORD TO ALLOW TEMP OR VIO DSNS WFB         
*               * ADD UNIT(...) KEYWORD FOR USE WITH VOLUME(...)    WFB         
*               * ADD 'VOLUME: VOLSER' TO HEADING WHEN SPECIFIED    WFB         
*    +--------> * ADD TIME AND 'MONTHNAME DAY, YEAR' TO DSN HEADING WFB         
*    :          * ADD NOMSGS KEYWORD TO STOP NON-ERROR MSGS TO TERM WFB         
*    :          * ADD DSECT=YES TO CVT MACRO FOR CLEAN XA ASSEMBLY  WFB         
*    :          * MOVE ALL PUTLINE TEXT TO SEPARATE MESSAGES CSECT  WFB         
*    :                (FOLLOWING CHANGES ARE WFB SPECIFIC)          WFB         
*    :          * MAKE WFB DEFAULT FORM($TST)                       WFB         
*    :                                                              WFB         
*    +-- NOTE ==> THE TIME-DATE ROUTINE IKJEFLPA NORMALLY RESIDES   WFB         
*                 ONLY IN SYS1.AOST4. THIS LIBRARY MUST BE INCLUDED WFB         
*                 IN THE LINKEDIT SYSLIB FOR PROPER RESOLUTION.     WFB         
*                                                                   WFB         
*             MODIFIED BY SAM LEPORE, WFB: 01/87                    WFB         
*                                                                   WFB         
*               * CORRECT ERROR, 'NOHEAD' OFFSET LINE COUNT PAGE 1  WFB         
*               * ADD ASA KEYWORD TO ACCEPT CC WHEN RECFM NOT ..A   WFB         
*               * ADD NOCC KEYWORD ALIAS OF SINGLESPACE             WFB         
*               * ADD UDKFONT(...) KEYWORD FOR XEROX 2700/3700 FONT WFB         
*               * DELETE OLD LINES MARKED *DELETED OR 'DELETED CODE'WFB         
*                                                                     *         
*                                                                     *         
*             MESSAGES =                                              *         
*                                                                     *         
*                BOTH THE DARIFAIL AND GNRLFAIL SERVICE ROUTINES ARE  *         
*                USED TO ISSUE MESSAGES.                              *         
*                THOSE ISSUED BY THE COMMAND ARE FOUND FOLLOWING THE  *         
*                LABEL GNRLERR AND ARE ISSUED USING PUTLINE.          *         
*                                                                     *         
*             ABEND CODES = NONE                                      *         
*                                                                     *         
***********************************************************************         
*                                                                               
PRINTOFF CSECT                                                                  
R0       EQU   0                                                                
R1       EQU   1                                                                
R2       EQU   2                                                                
R3       EQU   3                                                                
R4       EQU   4                                                                
R5       EQU   5                                                                
R6       EQU   6                                                                
R7       EQU   7                                                                
R8       EQU   8                                                                
R9       EQU   9                                                                
R10      EQU   10                                                               
R11      EQU   11                                                               
R12      EQU   12                                                               
R13      EQU   13                                                               
R14      EQU   14                                                               
R15      EQU   15                                                               
         SAVE  (14,12),,HARDCOPY.IPO.&SYSTIME_&SYSDATE SAVE REGISTERS           
         LR    R12,R15                 LOAD REGISTER 12 WITH ENTRY              
*                                      ADDRESS                                  
         USING PRINTOFF,R12            ESTABLISH ADDRESSABILITY TO              
*                                      PROGRAM CSECT                            
         LA    R11,4095(R12)           LOAD REGISTER 11 WITH ENTRY              
*                                      ADDRESS 4095                             
         USING PRINTOFF+4095,R11       ESTABLISH ADDRESSABILITY TO THE          
*                                      REST OF THE PROGRAM CSECT                
         LR    R8,R1                   LOAD REGISTER 8 TO PRESERVE              
*                                      POINTER TO COMMAND PROCESSOR             
*                                      PARAMETER LIST                           
         GETMAIN R,LV=LDYNAMIC         GETMAIN DYNAMIC WORKAREA                 
         LR    R10,R1                  LOAD REGISTER 10 TO PRESERVE             
*                                      POINTER TO WORKAREA                      
         ST    R13,4(R10)              STORE ADDRESS OF PREVIOUS                
*                                      SAVEAREA                                 
         ST    R10,8(,R13)             STORE ADDRESS OF CURRENT                 
*                                      SAVEAREA IN PREVIOUS SAVEAREA            
         LR    R13,R10                 LOAD REGISTER 13 WITH ADDRESS OF         
*                                      CURRENT SAVEAREA                         
         USING WORKAREA,R13            ESTABLISH ADDRESSABILITY TO              
*                                      DYNAMIC WORKAREA                         
         GETMAIN R,LV=RECSIZE          GETMAIN RECORD AREA          WFB         
         ST    R1,ALNDSECT             SAVE ADDRESS OF RECORD      GTEL         
*                                                                               
***********************************************************************         
*                                                                     *         
*        BUILD PARSE AND DAIR PARAMETER LISTS USING COMMAND           *         
*           PROCESSOR PARAMETER LIST                                  *         
*        INITIALIZE OUTPUT DATA CONTROL BLOCKS IN WORKAREA            *         
*                                                                     *         
***********************************************************************         
*                                                                               
         USING CPPL,R8                 ESTABLISH ADDRESSABILITY TO CPPL         
         LA    R4,PPLSECT              LOAD ADDRESS OF PARSE PARAMETER          
*                                      LIST                                     
         USING PPL,R4                  ESTABLISH ADDRESSABILITY TO PPL          
         LA    R6,DAPLSECT             LOAD ADDRESS OF DAIR PARAMETER           
*                                      LIST                                     
         USING DAPL,R6                 ESTABLISH ADDRESSABILITY TO DAPL         
         LA    R5,IOPLSECT             LOAD ADDRESS OF PUTLINE                  
*                                      PARAMETER LIST                           
         USING IOPL,R5                 ESTABLISH ADDRESSABILITY TO IOPL         
         L     R1,CPPLUPT              LOAD POINTER TO USER PROFILE             
*                                      TABLE FROM CPPL                          
         L     R2,CPPLECT              LOAD POINTER TO ENVIRONMENT              
*                                      CONTROL TABLE FROM CPPL                  
         SLR   R3,R3                   ZERO REGISTER 3                          
         ST    R3,ECB                  STORE REGISTER AS ECB FOR PPL            
         LA    R3,ECB                  LOAD ADDRESS OF ECB                      
         STM   R1,R3,DFPLSECT          STOR UPT,ECT,ECB IN DFPL    GTEL         
         STM   R1,R3,PPLSECT           STORE ADDRESS OF UPT, ECT, AND           
*                                      ECB IN PPL                               
         STM   R1,R3,DAPLSECT          STORE ADDRESS OF UPT, ECT, AND           
*                                      ECB IN DAPL                              
         STM   R1,R3,IOPLSECT          STORE ADDRESS OF UPT, ECT, AND           
*                                      ECB IN IOPL                              
         LA    R3,IOPB                 LOAD ADDRESS OF PUTLINE                  
*                                      PARAMETER BLOCK                          
         ST    R3,IOPLIOPB             STORE IOPB ADDRESS IN IOPL               
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** START OF GTEL MOD ************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
*   INITIALIZE DFPL AND DFPB SO REST OF NAME CAN BE DETERMINED                  
         LA    R3,DFPBSECT             GET ADDRESS OF DFPB                      
         ST    R3,DFPLSECT+12          PUT IT IN THE CNTL BLK                   
         USING  DFPB,R3                TELL ASSEMBLER                           
         LA     R2,DFPBDSL             GET ADDRESS OF DSN LENGTH                
         ST     R2,DFPBDSN             SAVE IT                                  
         LA     R2,DFPBQUA             GET ADDRESS OF QUAL                      
         ST     R2,DFPBQUAL            STORE IT                                 
         MVI    DFPBCODE,DFPB04        MOVE IN TYPE                             
         MVC    DFPBPSCB,CPPLPSCB      MOVE IN PSCB ADDRESS                     
         MVI    DFPBCNTL,DFPBRET       MOVE IN DFPBRET                          
         XC     DFPBCAT(8),DFPBCAT     CLEAR AREA                               
         DROP    R3                                                             
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** END OF GTEL MOD **************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
         MVC   PPLPCL,PCLADDR          MOVE POINTER TO PARAMETER                
*                                      CONTROL LIST INTO PPL                    
         LA    R2,PARSBACK             LOAD ADDRESS OF FULLWORD TO              
*                                      CONTAIN ADDRESS OF PDE RETURNED          
*                                      BY PARS                                  
         ST    R2,PPLANS               STORE POINTER TO RETURN ADDRESS          
         MVC   PPLCBUF,CPPLCBUF        MOVE POINTER TO COMMAND BUFFER           
*                                      INTO PPL                                 
*DELETED LA    R2,PPLUWA               LOAD ADDR OF USER WORK AREA  WFB         
*DELETED ST    R2,PPLUWA               STORE ADDRESS IN PPL         WFB         
         ST    R13,PPLUWA              PASS THE DYNAMIC WORK AREA   WFB         
*                                      TO PARSE VALIDITY CHECK RTNE WFB         
         MVC   DAPLPSCB,CPPLPSCB       MOVE POINTER TO PSCB INTO DAPL           
         DROP  R4,R5,R6,R8             DROP ADDRESSABILITY TO CPPL,             
*                                      IOPL, DAPL, AND PPL                      
         MVC   OUTPUTA(OUTPUTAL),OUTPUTAC  MOVE ASA DCB CONSTANT INTO           
*                                      ASA DCB IN WORKAREA                      
         MVC   OUTPUTM(OUTPUTML),OUTPUTMC  MOVE MACHINE DCB CONSTANT            
*                                      INTO MACHINE DCB IN WORKAREA             
*                                                                               
***********************************************************************         
*                                                                     *         
*        CALLTSSR TO PARSE (ENTRY NAME IKJPARS)                       *         
*        ON RETURN PARSBACK -> PDL                                    *         
*        HANDLE ALL ERROR CODES RETURNED BY PARS                      *         
*        IF NECESSARY CALL GENERAL FAIL SERVICE ROUTINE               *         
*                                                                     *         
***********************************************************************         
*                                                                               
         CALLTSSR  EP=IKJPARS,MF=(E,PPLSECT)                                    
*                                      CALL PARS TO PARSE COMMAND               
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO               
         BZ    GOODPARS                YES....GO TO GOOD PARS ROUTINE           
         C     R15,FULL4               SEE IF RETURN CODE IS FOUR               
         BE    RETURN                  YES....PARS ISSUED ERROR                 
*                                      MESSAGE.  GO CLEANUP AND RETURN          
         C     R15,FULL20              SEE IF RETURN CODE IS TWENTY             
         BE    RETURN                  YES....VALIDITY CHECKING                 
*                                      ROUTINE ISSUED ERROR MESSAGE.            
*                                      GO CLEANUP AND RETURN                    
         XC    GFPARMS(GFLENGF),GFPARMS  INITIALIZE PARMLIST FOR                
*                                      GENERAL FAIL TO ZEROS                    
         LA    R1,GFPARMS              LOAD ADDRESS OF PARMLIST                 
         ST    R1,GFPARMP              STORE ADDRESS AS POINTER TO              
*                                      PARMLIST                                 
         ST    R15,GFRCODE             STORE RETURN CODE IN PARMLIST            
         LA    R1,GFPARSE              LOAD CALLER ID FOR PARS                  
         STH   R1,GFCALLID             STORE CALLER ID IN PARMLIST              
         L     R1,SAVEAREA+4           LOAD ADDRESS OF PEVIOUS                  
*                                      SAVEAREA                                 
         L     R1,24(R1)               LOAD POINTER TO CPPL                     
         ST    R1,GFCPPLP              STORE POINTER TO CPPL IN                 
*                                      PARMLIST                                 
         LA    R1,ECB                  LOAD ADDRESS OF OPTIONAL ECB             
         ST    R1,GFECBP               STORE POINTER TO ECB IN                  
*                                      PARMLIST                                 
         SLR   R1,R1                   ZERO REGISTER 1                          
         ST    R1,ECB                  SET OPTIONAL ECB TO ZERO                 
         LINK  EP=IKJEFF19,MF=(E,GFPARMP)  LINK TO GENERAL FAIL SERVICE         
*                                      ROUTINE TO HANDLE RETURN CODE            
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO               
         BZ    RETURN                  YES....GO CLEANUP AND RETURN             
         LR    R8,R15                  LOAD REGISTER 8 WITH RETURN              
*                                      CODE                                     
         BAL   R14,SETCODE             GO CONVERT CODE TO DECIMAL               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(GNRLERR,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      GENERAL FAIL ERROR MESSAGE               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(RETNCD,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DECIMAL RETURN CODE                      
         DROP  R15                                                  WFB         
         B     RETURN                  GO CLEANUP AND RETURN                    
*                                                                               
***********************************************************************         
*                                                                     *         
*        SET UP ADDRESSABILITY TO PDL                                 *         
*           AND LOAD REGISTER 6 WITH ADDRESS OF DSNAME PDE            *         
*                                                                     *         
***********************************************************************         
*                                                                               
GOODPARS DS    0H                                                               
         L     R9,PARSBACK             LOAD POINTER TO PARS ANSWER              
         USING IKJPARMD,R9             ESTABLISH ADDRESSABILITY TO PDL          
         LA    R6,DSNAMES              LOAD POINTER TO DSNAME LIST              
         MVI   VOLBIT,BLANK            BLANK OUT THE VOLUME WORK AREA           
         MVC   VOLUME,VOLBIT           CONTINUE BLANKING THE VOLUME             
         MVC   VOLHEAD,BLANKS          BLANK OUT THE HEADING CONST  WFB         
         MVC   VOLNAME,BLANKS          BLANK OUT THE HEADING VOLUME WFB         
         MVC   UNIT,BLANKS             BLANK OUT THE UNIT WORK AREA WFB         
         CLC   PNOMSG(2),HALF1         SEE IF NOMSG SPECIFIED       WFB         
         BNE   CHKDSN                  NO, GO SEE IF DSNAME GIVEN   WFB         
         OI    VOLBIT,NOMSG            YES, TURN ON FLAG FOR LATER  WFB         
CHKDSN   DS    0H                                                   WFB         
         L     R1,0(,R6)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BNE   CHKVSER                 NO, GO SEE IF VOLUME GIVEN   WFB         
         CLC   PDDNAME(2),HALF1        SEE IF DDNAME SPECIFIED      WFB         
         BE    CHKFOLD                 YES, SKIP UNIT VOL, CHK FOLD WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(NODSNDD,SINGLE,DATA),MF=(E,IOPLSECT)       WFB         
*                                      NO DSN OR DD GIVEN MESSAGE   WFB         
         DROP  R15                                                  WFB         
         B     RETURN                                               WFB         
CHKVSER  DS    0H                                                   WFB         
         CLC   PVOL(2),HALF1           SEE IF VOLUME SPECIFIED                  
         BNE   CHKFOLD                 NO.....GO SEE IF FOLD IS DESIRED         
         L     R7,SVOL                 LOAD POINTER TO VOLUME                   
         LH    R8,SVOL+4               LOAD LENGTH OF VOLUME                    
         BCTR  R8,0                    DECREMENT LENGTH FOR EXECUTE OF          
*                                      MOVE                                     
         EX    R8,MOVEVOL              MOVE VOLUME INTO WORK AREA               
         OI    VOLBIT,HIGH             INDICATE VOLUME PRESENT                  
         MVC   VOLHEAD,VOLCONST        MOVE '   VOLUME: ' TO HEAD   WFB         
         MVC   VOLNAME,VOLUME          MOVE VOLUME SER TO HEADING   WFB         
         CLC   PUNIT(2),HALF1          SEE IF UNIT SPECIFIED        WFB         
*                                 ===> O N L Y  IF VOLUME SPECIFIED WFB         
         BNE   CHKFOLD                 NO,GO SEE IF FOLD IS DESIRED WFB         
         L     R7,SUNIT                LOAD POINTER TO UNIT         WFB         
         LH    R8,SUNIT+4              LOAD LENGTH OF UNIT          WFB         
         BCTR  R8,0                    DECREMENT LENGTH FOR EXECUTE WFB         
         EX    R8,MOVEUNIT             MOVE UNIT INTO WORK AREA     WFB         
         OI    VOLBIT,MID1             INDICATE UNIT PRESENT        WFB         
CHKFOLD  DS    0H                                                               
         CLC   PFOLD(2),HALF1          SEE IF FOLD SPECIFIED                    
         BNE   CHKHEAD                 NO.....GO LOOP THROUGH DSNS GTEL         
         OI    VOLBIT,LOW              INDICATE FOLD PRESENT                    
CHKHEAD  DS    0H                                                               
         CLC   PHEAD(2),HALF1          SEE IF NOHEAD SPECIFIED                  
         BNE   NEXT                    NO.....GO LOOP THROUGH DSNAMES           
         OI    VOLBIT,MID2             INDICATE NOHEAD PRESENT     GTEL         
         DROP  R9                      DROP ADDRESSABILITY TO PDL               
*                                                                               
***********************************************************************         
*                                                                     *         
*        LOOP THROUGH DSNAME LIST RETURNED BY PARS                    *         
*                                                                     *         
***********************************************************************         
*                                                                               
NEXT     DS    0H                                                               
         LA    R1,PRINTI               LOAD POINTER TO DDNAME TO BE             
*                                      FREED                                    
         BAL   R2,FREEDD               BRANCH TO FREE ROUTINE                   
         LTR   R8,R8                   SEE IF RETURN CODE FROM FREE IS          
*                                      ZERO                                     
         BNZ   CLOSDCBS                NO.....GO CLOSE DCBS AND RETURN          
         L     R5,0(R6)                LOAD POINTER TO DSNAME                   
         CLI   0(R5),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BE    ALLOCDDN                YES, GO PROCESS DDNAME       WFB         
         LH    R4,4(R6)                LOAD LENGTH OF DSNAME                    
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** START OF GTEL MOD ************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
*   DETERMINE THE FULL DATASET NAME GIVEN                                       
         STH   R4,DFPBDSL              STORE LENGTH OF DSN                      
         TM    6(R6),X'40'             IN QUOTES                                
         BO    GTENOQ                  YES, SKIP                                
         BCTR  R4,0                    DECREMENT COUNT                          
         MVC   DFPBNAME,BLANKS         MOVE IN BLANKS                           
         EX    R4,DFPBMVE              MOVE IN DSN GIVEN                        
         LA    R4,1(R4)                BUMP COUNT                ARAMCO         
         LA    R1,DFPLSECT             GET ADDRESS OF ECT                       
         MVC   DFPBQUA,BLANKS          BLANK QUALIFIER                          
         CALLTSSR  EP=IKJEHDEF         GO TO DEFAULT ROUTINE                    
GTEDEF   LTR    R15,R15                TEST RETURN CODE                         
         BNZ    GTENOQ                 NON ZERO SKIP                            
GTEOK    LA     R5,DFPBNAME            RESTORE REGS                             
         LH     R4,DFPBDSL             GET NEW LENGTH                           
GTENOQ   DS    0H                                                               
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** END OF GTEL MOD **************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
         STCM  R4,3,DSNLEN             STORE LENGTH OF DSNAME                   
         BCTR  R4,0                    DECREMENT LENGTH FOR EXECUTE OF          
*                                      MOVE                                     
         LA    R8,DAP08                LOAD ADDRESS OF DAPB FOR 08              
         USING DAPB08,R8               ESTABLISH ADDRESSABILITY TO DAPB         
         MVC   DAPB08(DAPB08L),DAPB08C MOVE CONSTANTS INTO DAPB                 
         LA    R1,DSNLEN               LOAD POINTER TO DSN BUFFER               
         ST    R1,DA08PDSN             STORE POINTER TO DSN BUFFER IN           
*                                      DAPB                                     
         MVI   DSNBUF,BLANK            BLANK OUT THE DSNAME BUFFER              
         MVC   DSNBUF+1(43),DSNBUF     FINISH BLANKING OUT THE BUFFER           
         EX    R4,MOVEDSN              MOVE IN THE DSNAME                       
         TM    14(R6),HIGH             SEE IF MEMBER NAME IS PRESENT            
         BNO   CHKPASS                 NO.....GO CHECK IF THERE IS A            
*                                      PASSWORD                                 
         L     R5,8(R6)                LOAD POINTER TO THE MEMBER NAME          
         LH    R4,12(R6)               LOAD LENGTH OF MEMBER NAME               
         BCTR  R4,0                    DECREMENT LENGTH FOR EXECUTE OF          
*                                      MOVE                                     
         EX    R4,MOVEMEM              MOVE IN THE MEMBER NAME                  
CHKPASS  DS    0H                                                               
         MVC   MEMNAME,DA08MNM         MOVE MEMBER NAME INTO HEADER 2           
         TM    22(R6),HIGH             SEE IF PASSWORD IS PRESENT               
         BNO   CHKVOL                  NO.....GO SEE IF VOLUME PRESENT          
         L     R5,16(R6)               LOAD POINTER TO THE PASSWORD             
         LH    R4,20(R6)               LOAD LENGTH OF PASSWORD                  
         BCTR  R4,0                    DECREMENT LENGTH FOR EXECUTE OF          
*                                      MOVE                                     
         EX    R4,MOVEPASS             MOVE IN THE PASSWORD                     
CHKVOL   DS    0H                                                               
         TM    VOLBIT,HIGH             SEE IF VOLUME IS PRESENT                 
         BNO   ALLOCDD                 NO.....GO ALLOCATE DATA SET              
         MVC   DA08SER,VOLUME          MOVE IN THE VOLUME SERIAL                
         TM    VOLBIT,MID1             SEE IF UNIT IS PRESENT       WFB         
*                                 ===> O N L Y  IF VOLUME SPECIFIED WFB         
         BNO   ALLOCDD                 NO.....GO ALLOCATE DATA SET  WFB         
         MVC   DA08UNIT,UNIT           MOVE IN THE UNIT TYPE        WFB         
ALLOCDD  DS    0H                                                               
         SLR   R4,R4                   ZERO REGISTER 4                          
         ST    R4,ECB                  STORE REGISTER 4 AS ECB                  
         LA    R1,DAPLSECT             LOAD ADDRESS OF DAPL                     
         USING DAPL,R1                 ESTABLISH ADDRESSABILITY TO DAPL         
         ST    R8,DAPLDAPB             STORE ADDRESS OF DAPB IN DAPL            
         DROP  R1                      DROP ADDRESSABILITY TO DAPL              
         CALLTSSR EP=IKJDAIR           CALL DAIR TO ALLOCATE DATASET            
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO               
         BZ    OUTPUT                  YES....GO PRINT DATASET                  
         MVI   DFID+1,DFDAIR           SET DAIRFAIL ID TO INDICATE DAIR         
         BAL   R2,DAIRFAIL             GO TO DAIRFAIL ROUTINE TO HAVE           
*                                      ERROR MESSAGE PUT OUT                    
NOTPMESS DS    0H                                                               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(DSNNOTP,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      DATASET NOT PRINTED MESSAGE              
         DROP  R15                                                  WFB         
         B     EXITMSG                 GO PUT OUT DATASET AND MEMBER            
*                                      NAMES                                    
*                                                                               
***********************************************************************         
*                                                                     *         
*        DETERMINE DATASET TYPE AND CALL PRINT ROUTINE                *         
*                                                                     *         
***********************************************************************         
*                                                                               
OUTPUT   DS    0H                                                               
         TM    DA08DSO,DSOPS           X'40' PHYSICAL SEQUENTIAL                
         BO    PRINTIT                 YES....GO PRINT DATASET                  
         CLC   DA08MNM,BLANKS          SEE IF MEMBER NAME IS BLANK              
         BNE   PRINTIT                 NO.....GO TREAT AS SEQUENTIAL            
         TM    DA08DSO,DSOPO           X'02' PARTITIONED                        
         BO    SCROLLIT                YES....GO SCROLL DIRECTORY               
         DROP  R8                      DROP ADDRESSABILITY TO DAPB              
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(NOTPSPO,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      NOT PARTITIONED OR SEQUENTIAL            
*                                      MESSAGE                                  
         DROP  R15                                                  WFB         
         B     NOTPMESS                GO PUT NOT PRINTED MESSAGE               
*                                                                   WFB         
ALLOCDDN DS    0H                                                   WFB         
         L     R1,24(,R6)              LOAD POINTER TO NEXT DSN     WFB         
         C     R1,ENDCHAIN             IS DSN=* LAST OR ONLY NAME ? WFB         
         BE    CHKINFO                 YES, GO GET DSN, DSORG INFO  WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(NOTLAST,SINGLE,DATA),MF=(E,IOPLSECT)  PUT  WFB         
*                                      DSN=* IS NOT LAST OR ONLY    WFB         
*                                      MESSAGE                      WFB         
         DROP  R15                                                  WFB         
         B     NOTPMESS                GO PUT NOT PRINTED MESSAGE   WFB         
CHKINFO  DS    0H                                                   WFB         
         LA    R8,REQBLK               GET POINTER TO REQUEST BLOCK WFB         
         ST    R8,RBPTR                INITIALIZE REQUEST BLOCK PTR WFB         
         MVI   RBPTR,S99RBPND          INDICATE END OF PARM LIST    WFB         
         USING S99RB,R8                ESTABLISH ADDRESSABILITY TO  WFB         
*                                      REQUEST BLOCK                WFB         
         MVC   S99RBLN(RBLEN),REQBLKC  INITALIZE RB                 WFB         
         MVI   S99VERB,S99VRBIN        SET VERB TO INFO RETRIEVAL   WFB         
         LA    R1,TEXTPTRS             GET POINTER TO TEXT POINTERS WFB         
         ST    R1,S99TXTPP             STORE POINTER IN RB          WFB         
         DROP  R8                      DROP ADDRESSABILITY TO RB    WFB         
         USING S99TUPL,R1              ESTABLISH ADDRESSABILITY TO  WFB         
*                                      TEXT UNIT POINTER LIST       WFB         
         LA    R2,TEXTL                ADDRESS PREALLOC DDNAME TEXT WFB         
         ST    R2,S99TUPTR             STORE POINTER IN TUPL        WFB         
         USING S99TUNIT,R2             ESTABLISH ADDRESSABILITY TO  WFB         
*                                      TEXT UNIT                    WFB         
         MVC   S99TUKEY(TEXTLLEN),TEXTLC  INITIALIZE TEXT UNIT L    WFB         
         L     R9,PARSBACK             LOAD POINTER TO PARS ANSWER  WFB         
         USING IKJPARMD,R9             ESTABLISH ADDRESSABILITY     WFB         
         L     R5,SDDNAME              GET ADDRESS OF DDNAME        WFB         
         LH    R4,SDDNAME+4            GET LENGTH OF DDNAME         WFB         
         DROP  R9                                                   WFB         
         BCTR  R4,0                    DECREMENT FOR EXECUTE        WFB         
         EX    R4,MOVEDDN              MOVE DDNAME INTO TEXT UNIT   WFB         
         MVC   PREALDDN,S99TUPAR       SAVE PREALLOC DDN FOR LATER  WFB         
         LA    R1,4(,R1)               POINT TO NEXT TEXT UNIT PTR  WFB         
         LA    R2,TEXTM                ADDRESS RETURN DSNAME TEXT U WFB         
         ST    R2,S99TUPTR             STORE POINTER IN TUPL        WFB         
         MVC   S99TUKEY(TEXTMLEN),TEXTMC  INITIALIZE TEXT UNIT M    WFB         
         LA    R1,4(,R1)               POINT TO NEXT TEXT UNIT PTR  WFB         
         LA    R2,TEXTN                ADDRESS RETURN MEMBER TEXT U WFB         
         ST    R2,S99TUPTR             STORE POINTER IN TUPL        WFB         
         MVC   S99TUKEY(TEXTNLEN),TEXTNC  INITIALIZE TEXT UNIT N    WFB         
         LA    R1,4(,R1)               POINT TO NEXT TEXT UNIT PTR  WFB         
         LA    R2,TEXTO                ADDRESS RETURN DSORG TEXT U  WFB         
         ST    R2,S99TUPTR             STORE POINTER IN TUPL        WFB         
         MVC   S99TUKEY(TEXTOLEN),TEXTOC  INITIALIZE TEXT UNIT O    WFB         
         MVI   S99TUPTR,S99TUPLN       INDICATE END TEXT UNIT PTRS  WFB         
         DROP  R1,R2                   DROP ADDRESSABILITY          WFB         
         LA    R1,RBPTR                ADDRESS SVC99 REQUEST BLOCK  WFB         
         DYNALLOC                      ISSUE DYNAMIC ALLOCATION SVC WFB         
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO   WFB         
         BZ    CHKDDORG                YES....GO CHECK DSORG TYPE   WFB         
         LA    R1,REQBLK               ADDRESS SVC99 REQUEST BLOCK  WFB         
         MVI   DFID+1,DFSVC99          SET DAIRFAIL ID = DYNALLOC   WFB         
         BAL   R2,DAIRFAIL             GO TO DAIRFAIL ROUTINE TO    WFB         
         B     NOTPMESS                GO PUT NOT PRINTED MESSAGE   WFB         
CHKDDORG DS    0H                                                   WFB         
         LA    R1,TEXTM                ADDRESS RETURNED DSNAME TEXT WFB         
         USING S99TUNIT,R1             ESTABLISH ADDRESSABILITY     WFB         
         MVC   DFPBDSL,S99TULNG        SAVE DSN LEN WHERE EXPECTED  WFB         
         MVC   DSNAME,S99TUPAR         MOVE RETURN DSN INTO HEADER  WFB         
         LA    R1,TEXTN                ADDRESS RETURNED MEMBER TEXT WFB         
         MVC   MEMNAME,S99TUPAR        MOVE RETURN MEM INTO HEADER  WFB         
         MVC   VOLHEAD,DDNCONST        MOVE '   DDNAME: ' TO HEADER WFB         
         MVC   VOLNAME,PREALDDN        MOVE DDNAME TO HEADING       WFB         
         LA    R1,TEXTO                ADDRESS RETURNED DSORG TEXT  WFB         
         TM    S99TUPAR,DSOPS          X'40' PHYSICAL SEQUENTIAL    WFB         
         BO    PRINTIT                 YES....GO PRINT DATASET      WFB         
         CLI   MEMNAME,BLANK           SEE IF MEMBER NAME IS BLANK  WFB         
         BNE   PRINTIT                 NO.....GO TREAT AS SEQUENTIALWFB         
         TM    S99TUPAR,DSOPO          X'02' PARTITIONED            WFB         
         BO    SCROLLIT                YES....GO SCROLL DIRECTORY   WFB         
         DROP  R1                      DROP ADDRESSABILITY TO S99TU WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(NOTPSPO,SINGLE,DATA),MF=(E,IOPLSECT)  PUT  WFB         
*                                      NOT PARTITIONED OR SEQUENTIALWFB         
*                                      MESSAGE                      WFB         
         DROP  R15                                                  WFB         
         B     NOTPMESS                GO PUT NOT PRINTED MESSAGE   WFB         
*                                                                               
***********************************************************************         
*                                                                     *         
*        READS RECORDS USING GET MOVE                                 *         
*           AND ATTRIBUTES OF GIVEN DATASET                           *         
*        WRITES THESE SAME RECORDS USING PUT MOVE                     *         
*           AND THE INPUT DATASET ATTRIBUTES                          *         
*                                                                     *         
***********************************************************************         
*                                                                               
PRINTIT  DS    0H                                                               
         LA    R8,INPUT                LOAD POINTER TO INPUT DCB                
         USING IHADCB,R8               ESTABLISH ADDRESSABILITY TO DCB          
         MVC   INPUT(INPUTL),INPUTC    MOVE INPUT DCB CONSTANT INTO             
*                                      INPUT DCB IN WORKAREA                    
         L     R1,0(,R6)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BNE   OPENINP                 NO, GO OPEN INPUT            WFB         
         MVC   DCBDDNAM,PREALDDN       YES, USE PREALLOCATED DDN(.) WFB         
OPENINP  DS    0H                                                   WFB         
         MVC   OPENLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO OPEN LIST IN WORKAREA               
         OPEN  ((R8),INPUT),MF=(E,OPENLST)  OPEN INPUT DCB                      
PRINTS   DS    0H                      BRANCH ADDRESS FOR PRINTING              
*                                      MEMBERS                                  
         TM    DCBOFLGS,DCBOFOPN       SEE IF DCB OPENED SUCCESSFULLY           
         BNO   NOTPMESS                NO.....GO PUT OUT NOT PRINTED            
*                                      MESSAGE                                  
CHKCNTRL DS    0H                                                               
         MVC   HEADER,HEADERC          MOVE HEADER INTO DATA AREA               
         TM    DCBRECFM,DCBRECCM       SEE IF CONTROL IS MACHINE                
         BNO   USEA                    NO.....GO TO USE ASA CONTROL             
         LA    R5,OUTPUTM              LOAD ADDRESS OF OUTPUT DCB FOR           
*                                      MACHINE CODE                             
         LA    R4,EJECTM               LOAD ADDRESS OF EJECT DATA               
         MVI   HDRCNTL,SKIPM           MOVE INTO HEADER MACHINE CODE            
*                                      FOR SPACE                                
         TM    48(R5),DCBOFOPN         SEE IF DCB IS ALREADY OPEN               
         BO    PUTDSN                  YES....GO PUT OUT HEADERS                
         LA    R3,PRINTM               LOAD POINTER TO PRINTM                   
         LA    R14,PUTDSN              LOAD ADDRESS FROM RETURN FROM            
*                                      SYSOUT ALLOCATION                        
         B     ALLOCOUT                GO TO ALLOCATE SYSOUT                    
USEA     DS    0H                                                               
         LA    R5,OUTPUTA              LOAD ADDRESS OF OUTPUT DCB FOR           
*                                      ASA CODE                                 
         LA    R4,EJECTA               LOAD ADDRESS OF EJECT DATA               
         TM    48(R5),DCBOFOPN         SEE IF DCB IS ALREADY OPEN               
         BO    PUTDSN                  YES....GO PUT OUT HEADERS                
         LA    R3,PRINTA               LOAD POINTER TO PRINTA                   
         BAL   R14,ALLOCOUT            LOAD ADDRESS FOR RETURN AND GO           
*                                      DO SYSOUT ALLOCATION                     
PUTDSN   DS    0H                                                               
         TM    VOLBIT,UDKDONE          UDKS WRITTEN ALREADY ?       WFB         
         BO    NOUDK                   YES, SKIP                    WFB         
         L     R9,PARSBACK             LOAD POINTER TO PARS ANSWER  WFB         
         USING IKJPARMD,R9             ESTABLISH ADDRESABILITY      WFB         
         CLC   PUDKFONT(2),HALF1       IS UDK FONT SPECIFIED ?      WFB         
         BNE   NOUDK                   NO, SKIP                     WFB         
         PUT   (R5),UDKRESET           PUT OUT UDK RESET TEXT       WFB         
         PUT   (R5),UDKSET             PUT OUT UDK SET TEXT         WFB         
         L     R15,ALNDSECT            POINT TO RECORD WORK AREA    WFB         
         USING LINDSECT,R15            ESTABLISH ADDRESSABILITY     WFB         
         MVC   RECORD(8),UDKFHEAD      MOVE UDK FONT NAME HEADER    WFB         
         L     R14,SUDKFONT            POINT TO UDK FONT NAME       WFB         
         LH    R1,SUDKFONT+4           GET LENGTH OF UDK FONT NAME  WFB         
         BCTR  R1,0                    DECREMENT FOR EXECUTE        WFB         
         EX    R1,MOVEUDK              MOVE UDK FONT NAME TO RECORD WFB         
         LA    R1,9(,R1)               ADD HEADER LEN TO ACTUAL LEN WFB         
         STH   R1,RECLEN               SAVE IN OUTPUT RECORD        WFB         
         PUT   (R5),(R15)              PUT OUT UDK FONT NAME        WFB         
         DROP  R9,R15                                               WFB         
         PUT   (R5),UDKFSEL            PUT OUT UDK FONT SELECT TEXT WFB         
         OI    VOLBIT,UDKDONE          INDICATE UDKS WRITTEN        WFB         
NOUDK    DS    0H                                                   WFB         
         TM    VOLBIT,MID2             TEST FOR NOHEAD             GTEL         
         BO    NOHEAD                  YES                         GTEL         
         PUT   (R5),(R4)               PUT OUT PAGE EJECT           WFB         
         MVC   HDRTIME(HDRTDLEN),BLANKS  BLANK OUT TIME DATE AREAS  WFB         
         CALL  IKJEFLPA,(HDRTIME,HDRDATE),VL,MF=(E,CALLMFL)         WFB         
         MVC   HDRTIME(4),BLANKS       BLANK OUT BUFFER PREFIX      WFB         
         MVC   HDRDATE(4),BLANKS       BLANK OUT BUFFER PREFIX      WFB         
         PUT   (R5),HEADER             PUT OUT PAGE 1 HEADER                    
         MVC   HEADER2,LDSNAME         MOVE LENGTH AND 'DSNAME=' INTO           
*                                      INTO SECOND HEADER                       
         MVC   HEADER2+4(1),HDRCNTL    MOVE IN CONTROL BYTE                     
         CLI   MEMNAME,BLANK           SEE IF MEMBER NAME IS BLANK              
         BE    NOMEM                   YES....NO NEED TO PUT IN PARENS          
         MVI   OPENPRN,C'('            MOVE OPEN PAREN INTO DSNAME              
         MVI   CLOSEPRN,C')'           MOVE CLOSE PAREN INTO DSNAME             
         B     PUTHDR2                 GO PUT OUT HEADER 2                      
NOMEM    DS    0H                                                               
         MVI   OPENPRN,BLANK           MOVE BLANK INSTEAD OF OPEN AND           
         MVI   CLOSEPRN,BLANK          CLOSE PARENS                             
PUTHDR2  DS    0H                                                               
         PUT   (R5),HEADER2            PUT OUT PAGE 1 HEADER 2                  
         MVC   HEADER2(4),SPACE        CHANGE HEADER 2 FOR PUT OF BLANK         
*                                      LINE                                     
         PUT   (R5),HEADER2            PUT OUT BLANK LINE                       
NOHEAD   STM   R9,R10,SAVMR9           SAVE REGS 9 AND 10                       
         STM   R6,R7,SAVMR6            SAVE REGS 6 AND 7                        
         STM   R2,R3,SAVMR2            SAVE REGS 2 AND 3                        
         L     R9,ALNDSECT             SET UP RECORD ADDRESS.                   
         USING LINDSECT,R9             *                                        
         SLR   R10,R10                 ZERO OUT R10                             
         LH    R7,PAGELEN              MOVE IN PAGELEN                          
         TM    VOLBIT,MID2             NOHEAD SPECIFIED ?           WFB         
         BO    NOSUB4                  YES, SKIP SUBTRACTION        WFB         
         SH    R7,HALF4                SUBTRACT FOR HEADER       ARAMCO         
NOSUB4   DS    0H                                                   WFB         
         MVC   RECCC,HDRCNTL           MOVE IN SPACE AS CONTROL                 
*                                      CHARACTER                                
         TM    DCBRECFM,DCBRECU        SEE IF RECFM U                           
         BO    COPYU                   YES....GO HANDLE RECFM U                 
         TM    DCBRECFM,DCBRECV        SEE IF RECFM V                           
         BO    COPYV                   YES....GO HANDLE RECFM V                 
COPYF    DS    0H                                                               
         TM    DCBRECFM,DCBRECCC       CONTROL CHARACTER?                       
         BNZ   COPYFCC                 YES...                                   
         TM    CCBIT,FORCEASA          USER SAYS CC IN DATA ?       WFB         
         BO    COPYFCC                 YES, PROCESS AS SO           WFB         
COPYFNC  OI    CCBIT,LOW               TURN ON NOCC BIT                         
         LH    R4,DCBLRECL             GET LRECL                                
         A     R4,FULL5                ADD LENGTH FOR VB HEADER                 
         STH   R4,RECLEN               PUT INTO RECORD HEADER                   
         GET   INPUT,RECDATA           GET INPUT                                
         BAL   R10,PUTLL               PUT OUT LINE                             
         L     R9,ALNDSECT             RELOAD DSECT POINTER                     
         B     COPYFNC                 GET NEXT RECORD                          
COPYFCC  LH    R4,DCBLRECL             GET LRECL                                
         A     R4,FULL4                ADD LENGTH FOR VB HEADER                 
         STH   R4,RECLEN               PUT INTO RECORD HEADER                   
         GET   INPUT,RECCC             GET INPUT                                
         BAL   R10,PUTLL               PUT INTO RECORD HEADER                   
         L     R9,ALNDSECT             RELOAD DSECT POINTER                     
         B     COPYFCC                 GET NEXT RECORD                          
COPYV    DS    0H                                                               
         TM    DCBRECFM,DCBRECCC       CONTROL CHARACTER?                       
         BNZ   COPYVCC                 IF YES...                                
         TM    CCBIT,FORCEASA          USER SAYS CC IN DATA ?       WFB         
         BO    COPYVCC                 YES, PROCESS AS SO           WFB         
COPYVNC  GET   INPUT,RECLEN+1          GET INPUT                                
         OI    CCBIT,LOW               TURN ON NOCC BIT                         
         SLR   R15,R15                 ZERO R15                                 
         ICM   R15,7,RECLEN+1          GET LENGTH                               
         A     R15,FULL256             ADD ONE FOR CC                           
         STCM  R15,7,RECLEN            REPLACE LENGTH OVER 1                    
         MVC   RECCC,HDRCNTL           ADD HDRCNTL                              
         BAL   R10,PUTLL               PUT OUT RECORD                           
         L     R9,ALNDSECT             RESTORE DSECT ADDRESS                    
         B     COPYVNC                 GET NEXT RECORD                          
COPYVCC  GET   INPUT,RECLEN            GET INPUT                                
         BAL   R10,PUTLL               PUT OUT RECORD                           
         L     R9,ALNDSECT             RESTORE DSECT ADDRESS                    
         B     COPYVCC                 GET NEXT RECORD                          
COPYU    DS    0H                      PROCESS RECFM=U                          
         TM    DCBRECFM,DCBRECCC       CONTROL CHARACTER?                       
         BNZ   COPYUCC                 YES...                                   
         TM    CCBIT,FORCEASA          USER SAYS CC IN DATA ?       WFB         
         BO    COPYUCC                 YES, PROCESS AS SO           WFB         
COPYUNC  GET   INPUT,RECDATA           GET RECORD                               
         OI    CCBIT,LOW               TURN ON NOCC BIT                         
         LH    R4,DCBLRECL             GET LRECL                                
         A     R4,FULL5                ADD VB HEADER LENGTH                     
         STH   R4,RECLEN               PUT INTO RECORD HEADER                   
         BAL   R10,PUTLL               PUT OUT LINE                             
         L     R9,ALNDSECT             RELOAD DSECT POINTER                     
         B     COPYUNC                 GET NEXT RECORD                          
COPYUCC  GET   INPUT,RECCC             GET INPUT                                
         LH    R4,DCBLRECL             GET LRECL                                
         A     R4,FULL4                ADD VB HEADER LENGTH                     
         STH   R4,RECLEN               STORE INTO RECORD HEADER                 
         BAL   R10,PUTLL               PUT INTO RECORD HEADER                   
         L     R9,ALNDSECT             RELOAD DSECT POINTER                     
         B     COPYUCC                 GET NEXT RECORD                          
PUTLL    DS    0H                                                               
         TM    CCBIT,X'99'             NOCC, DS, SS, OR PAGELEN ON?             
         BZ    NOSKIP                  NO, IGNORE LINE-COUNTING                 
         LTR   R7,R7                   ANY LINES LEFT ON PAGE?                  
         BNZ   LINECT                  YES, DON'T PUT IN PAGE SKIP CC           
         MVI   4(R9),HEXF1             MOVE IN PAGE SKIP CC                     
         LH    R7,PAGELEN              RESET LINE COUNT                         
         B     NOSKIP                  CONTINUE WITH PUT                        
LINECT   TM    CCBIT,MID2              WAS DOUBLE SPACE SPECIFIED?              
         BO    LINEDS                  YES, CHECK LINES LEFT     ARAMCO         
         MVI   4(R9),BLANK             PUT IN SINGLE SPACE CONTROL CHAR         
         B     NOSKIP                  YES, DON'T SKIP TO NEXT PAGE             
LINEDS   BCTR  R7,0                    DECREMENT ONE MORE FOR DS                
         MVI   4(R9),HEXF0             PUT IN DOUBLE SPACE CONTROL CHAR         
         SLR   R2,R2                   EMPTY R2 FOR DIVIDE                      
         SLR   R3,R3                   EMPTY R3 FOR DIVIDE                      
         SLR   R15,R15                 EMPTY R15 FOR DIVIDE                     
         LH    R15,LINELEN             LOAD LINELEN INTO R15                    
         LH    R3,RECLEN               PUT REC LENGTH IN R2                     
         SH    R3,HALF5                SUBTRACT VB HEADER LENGTH                
         DR    R2,R15                  DIVIDE BY LINELEN                        
         CR    R3,R7                   GREATER THAN LINES LEFT ON PAGE?         
         BNH   NOSKIP                  IF NOT....DON'T START NEW PAGE           
         MVI   4(R9),HEXF1             MOVE IN PAGE SKIP CC                     
         LH    R7,PAGELEN              RESET LINE COUNT                         
NOSKIP   LH    R4,RECLEN               PUT REC LENGTH IN R4                     
         TM    VOLBIT,LOW              SEE IF FOLD IS REQUESTED                 
         BO    FOLDLOOP                YES....GO FOLD OUTPUT                    
PUTLOOP  CH    R4,VBLEN                COMPARE WITH LL                          
         BNH   PUTLAST                 WRITE LAST RECORD                        
         MVC   0(2,R9),VBLEN           INSERT LENGTH FOR PUT                    
         PUT   (R5),(R9)               PUT OUT OUTPUT LINE                      
         SH    R4,LINELEN              DECREMENT FOR COMPARE                    
         AH    R9,LINELEN              INCREMENT RECORD LOCATN                  
         MVI   4(R9),BLANK             MOVE IN NEXT LINE CC                     
         TM    CCBIT,X'99'             NOCC, PAGELEN, DS, OR SS SPEC?           
         BZ    PUTLOOP                 NO, DON'T COUNT LINES                    
         BCT   R7,PUTLOOP              END OF PAGE?                             
         MVI   4(R9),HEXF1             YES, START NEW PAGE                      
         LH    R7,PAGELEN              RELOAD PAGELEN                           
         B     PUTLOOP                 WRITE NEXT LINE                          
FOLDLOOP CH    R4,VBLEN                COMPARE WITH LL                          
         BNH   FOLDLAST                WRITE LAST RECORD                        
         LH    R15,LINELEN             LOAD LINE LENGTH                         
         SH    R15,HALF1               DECREMENT FOR EXECUTE                    
         EX    R15,FOLDLINE            EXECUTE FOLD OF LINE                     
         MVC   0(2,R9),VBLEN           INSERT LENGTH FOR PUT                    
         PUT   (R5),(R9)               PUT OUT OUTPUT LINE                      
         SH    R4,LINELEN              DECREMENT FOR COMPARE                    
         AH    R9,LINELEN              INCREMENT RECORD LOCATION                
         MVI   4(R9),BLANK             MOVE IN NEXT LINE CC                     
         TM    CCBIT,X'99'             NOCC, PAGELEN, DS, OR SS SPEC?           
         BZ    FOLDLOOP                NO, DON'T COUNT LINES                    
         BCT   R7,FOLDLOOP             END OF PAGE?                             
         MVI   4(R9),HEXF1             YES, START NEW PAGE                      
         LH    R7,PAGELEN              RELOAD PAGELEN                           
         B     FOLDLOOP                WRITE NEXT LINE                          
FOLDLAST LR    R15,R4                  LOAD REMAINING LINE LENGTH               
         SH    R15,HALF6               DECREMENT FOR EXECUTE                    
         EX    R15,FOLDLINE            EXECUTE FOLD OF LINE                     
PUTLAST  STH   R4,0(R9)                INSERT LENGTH FOR PUT                    
         PUT   (R5),(R9)               PUT OUT OUTPUT LINE                      
         BCTR  R7,0                    DECREMENT PAGELEN                        
         BR    R10                     GO GET NEXT RECORD                       
EXITI    DS    0H                                                               
         DROP  R9                                                               
         LM    R9,R10,SAVMR9           RESTORE R9 AND R10                       
         LM    R6,R7,SAVMR6            RESTORE R6 AND R7                        
         LM    R2,R3,SAVMR2            RESTORE R2 AND R3                        
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** END OF GTEL MOD **************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
EXIT     DS    0H                                                               
         TM    DCBOFLGS,DCBOFOPN       SEE IF INPUT DCB IS OPEN                 
         BNO   EXITMSG                 NO....GO PUT OUT DATASET AND             
*                                      MEMBER NAMES                             
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST IN WORKAREA              
         CLOSE ((R8),),MF=(E,CLOSLST)  CLOSE INPUT DCB                          
EXITMSG  DS    0H                                                               
         L     R1,0(,R6)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BE    EXNOFREE                YES, DO NOT FREE DDN(...)    WFB         
         LA    R1,PRINTI               FREE INPUT DATASET          GTEL         
         BAL   R2,FREEDD               FREE INPUT DATASET          GTEL         
EXNOFREE DS    0H                                                   WFB         
         TM    VOLBIT,NOMSG            IS NOMSG SPECIFIED ?         WFB         
         BO    CONTINUE                YES, CONTINUE WITH NEXT DSN  WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(DSNMSG,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DATA SET NAME MESSAGE                    
         DROP  R15                                                  WFB         
         LH    R4,DFPBDSL              LOAD LENGTH OF DSNAME       GTEL         
         A     R4,FULL4                INCREMENT LENGTH FOR PUTLINE             
         SLL   R4,16                   SHIFT LENGTH TO HIGH ORDER BYTES         
         STCM  R4,15,DSNLENP           STORE LENGTH OF PUTLINE                  
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(DSNLENP,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      DATA SET NAME MESSAGE                    
         DROP  R15                                                  WFB         
         CLI   MEMNAME,BLANK           MEMBER NAME BLANK ?          WFB         
         BE    CONTINUE                YES, SKIP MEMBER MESSAGE     WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(MEMMSG,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DATA SET NAME MESSAGE                    
         DROP  R15                                                  WFB         
         MVC   MEMNAMEL(2),HALF12      FORCE MEMNAME LENGTH 8 (+4)  WFB         
         MVC   MEMNAMEL+2(2),HALF0     (REQUIRED ZERO FOR PUTLINE)  WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(MEMNAMEL,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT         
*                                      MEMBER NAME                              
         DROP  R15                                                  WFB         
         B     CONTINUE                GO CONTINUE WITH NEXT DATASET            
         DROP  R8                      DROP ADDRESSABILITY TO INPUT DCB         
ERRI     DS    0H                                                               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(SYNADI,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DATASET NOT PRINTED DUE TO SYNAD         
*                                      ERROR ON INPUT DATASET MESSAGE           
         DROP  R15                                                  WFB         
         B     EXIT                    GO SEE IF INPUT DCB IS OPEN              
ERRO     DS    0H                                                               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(SYNADO,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DATASET NOT PRINTED DUE TO               
*                                      SYNAD ERROR MESSAGE          WFB         
         DROP  R15                                                  WFB         
         B     CLOSDCBS                GO CLOSE OPEN DCBS AND RETURN            
*                                                                     *         
***********************************************************************         
*                                                                     *         
*        READ THE DIRECTORY OF A PDS                                  *         
*           THEN EITHER LIST MEMBER NAMES,                            *         
*           PRINT MEMBERS,                                            *         
*           OR LIST MEMBER NAMES AND PRINT MEMBERS                    *         
*                                                                     *         
***********************************************************************         
*                                                                               
SCROLLIT DS    0H                                                               
         ST    R6,SAVER6               SAVE REGISTER 6                          
         L     R9,PARSBACK             LOAD ADDRESS PARS ANSWER                 
         USING IKJPARMD,R9             ESTABLISH ADDRESSABILITY TO PDL          
         CLC   PLIST,HALF2             SEE IF NOLIST SPECIFIED                  
         BL    CONTSCR                 LOW....CONTINUE WITH SCROLL              
         CLC   PPRINT,HALF2            SEE IF NOPRINT SPECIFIED                 
         BE    CONTINUE                YES....SKIP SCROLL                       
         DROP  R9                      DROP ADDRESSABILITY TO PDL               
CONTSCR  DS    0H                                                               
         LA    R8,DIRECT               LOAD POINTER TO DIRECTORY DCB            
         USING IHADCB,R8               ESTABLISH ADDRESSABILITY TO DCB          
         MVC   DIRECT(DIRECTL),DIRECTC MOVE DIRECTORY DCB CONSTANT INTO         
*                                      DIRECTORY DCB IN WORKAREA                
         L     R1,0(,R6)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BNE   OPENDIR                 NO, GO OPEN INPUT DIRECTORY  WFB         
         MVC   DCBDDNAM,PREALDDN       YES, USE PREALLOCATED DDN(.) WFB         
OPENDIR  DS    0H                                                   WFB         
         MVC   OPENLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO OPEN LIST IN WORKAREA               
         OPEN  ((R8),INPUT),MF=(E,OPENLST)  OPEN DIRECTORY DCB                  
         TM    DCBOFLGS,DCBOFOPN       SEE IF DCB OPENED SUCCESSFULLY           
         BNO   NOTPMESS                NO.....GO PUT OUT NOT PRINTED            
*                                      MESSAGE                                  
         DROP  R8                      DROP ADDRESSABILITY TO DCB               
*                                                                     *         
***********************************************************************         
*                                                                     *         
*        GETMAIN MEMBER TABLE FOR STORAGE OF DIRECTORY NAMES, ETC.    *         
*           INITIALIZE TABLE                                          *         
*                                                                     *         
***********************************************************************         
*                                                                               
         L     R0,MEMDATL              LOAD LENGTH OF GETMAIN FOR               
*                                      MEMBER TABLE                             
         LR    R2,R0                   SAVE IN REGISTER 2                       
         GETMAIN R,LV=(0)              GETMAIN MEMBER TABLE STORAGE             
         ST    R1,MEMTABLE             SAVE ADDRESS OF MEMBER TABLE             
         ST    R1,PRESENT              ALSO SAVE ADDRESS AS TABLE               
*                                      IN USE                                   
         LA    R3,0(R2,R1)             LOAD ADDRESS OF END OF TABLE             
         ST    R3,ENDTABLE             STORE ADDRESS OF TABLE END               
         SLR   R4,R4                   ZERO REGISTER 4                          
         ST    R4,0(R1)                STORE AS FIRST WORD OF MEMBER            
*                                      TABLE                                    
         LA    R4,8(R1)                LOAD REGISTER 4 AS POINTER TO            
*                                      THE FIRST ENTRY                          
         USING MEMDSECT,R4             ESTABLISH ADDRESSABILITY TO              
*                                      MEMBER TABLE DSECT                       
         SLR   R5,R5                   INITIALIZE MEMBER COUNT TO ZERO          
*                                                                     *         
***********************************************************************         
*                                                                     *         
*        READ DIRECTORY AND BUILD MEMBER TABLE                        *         
*                                                                     *         
***********************************************************************         
*                                                                               
GETDIR   EQU   *                                                                
         GET   (R8),DATA               GET A DIRECTORY BLOCK                    
         CLC   DATA,HALF12             SEE IF BLOCK IS UNUSED                   
         BL    FREEBLK                 YES....GO HANDLE DIRECTORY END           
         LA    R9,DATA+2               LOAD POINTER TO FIRST DIRECTORY          
*                                      ENTRY                                    
         SLR   R7,R7                   ZERO REGISTER 7 FOR INSERT               
         ICM   R7,3,DATA               INSERT LENGTH USED OF THIS BLOCK         
         LA    R7,DATA-1(R7)           LOAD LAST USED BYTE OF BLOCK             
UNBLOCK  DS    0H                                                               
         MVC   MEMNTTR,0(R9)           PUT NAME AND TTR IN TABLE                
         MVC   CFIELD,11(R9)           PUT C FIELD IN TABLE                     
         CLI   MEMBER,HEXFF            SEE IF LAST MEMBER                       
         BE    FREEBLK                 YES....GO HANDLE DIRECTORY END           
         IC    R6,CFIELD               INSERT CFIELD INTO REGISTER 6            
         SLL   R6,27                   SHIFT OUT HIGH ORDER BITS                
         SRL   R6,26                   SHIFT RIGHT TO GET LENGTH OF             
*                                      USER DATA                                
         LA    R6,12(R6)               ADD STANDARD ENTRY LENGTH                
         LA    R4,MEMSECTN             LOAD PINTER TO NEXT TABLE ENTRY          
         LA    R5,1(R5)                INCREMENT NUMBER OF MEMBERS IN           
*                                      TABLE                                    
         C     R4,ENDTABLE             SEE IF END OF TABLE                      
         BL    NEXTNTRY                LOW.....GO PROCESS NEXT ENTRY            
         LR    R0,R2                   LOAD LENGTH OF TABLE FOR GETMAIN         
         GETMAIN R,LV=(0)              GET NEXT TABLE                           
         L     R14,PRESENT             LOAD REGISTER 14 WITH ADDRESS OF         
*                                      LAST TABLE                               
         ST    R1,0(R14)               CHAIN MEMBER TABLES TOGETHER             
         ST    R1,PRESENT              ALSO SAVE ADDRESS AS TABLE               
*                                      IN USE                                   
         LA    R3,0(R2,R1)             LOAD ADDRESS OF TABLE END                
         ST    R3,ENDTABLE             STORE ADDRESS OF TABLE END               
         SLR   R4,R4                   ZERO REGISTER 4                          
         ST    R4,0(R1)                STORE AS FIRST WORD OF MEMBER            
*                                      TABLE                                    
         LA    R4,8(R1)                LOAD REGISTER 4 AS POINTER TO            
*                                      THE FIRST ENTRY                          
         STH   R5,4(R14)               STORE MEMBER COUNT IN OLD TABLE          
         SLR   R5,R5                   INITIALIZE MEMBER COUNT TO ZERO          
NEXTNTRY DS    0H                                                               
         BXLE  R9,R6,UNBLOCK           INCREMENT REGISTER 9 WITH                
*                                      REGISTER 6 AND BRANCH                    
*                                      LESS THAN OR EQUAL TO                    
*                                      REGISTER 7 TO UNBLOCK                    
         B     GETDIR                  NO.....GO GET NEXT DIRECTORY             
*                                      BLOCK                                    
         DROP  R4                      DROP ADDRESSABILITY TO TABLE             
*                                                                               
***********************************************************************         
*                                                                     *         
*        LIST MEMBERS IF:                                             *         
*           LIST SPECIFIED OR                                         *         
*           BOTH PRINT AND NOLIST WERE NOT SPECIFIED                  *         
*                                                                     *         
***********************************************************************         
*                                                                               
FREEBLK  DS    0H                                                               
         MVC   OPENLST,OPENCLOS        MOVE CONSTANT INTO CLOSE LIST            
         CLOSE ((R8),),MF=(E,OPENLST)  CLOSE DIRECTORY DCB                      
         L     R2,PRESENT              LOAD POINTER TO LAST TABLE               
         STH   R5,4(R2)                STORE COUNT OF MEMBERS                   
         L     R4,MEMTABLE             LOAD POINTER TO FIRST TABLE              
         CLC   4(2,R4),HALF0           SEE IF THERE WERE ANY MEMBERS            
         BE    ENDMEMB                 ZERO...GO FREE MEMBER TABLE              
         LA    R8,INPUT                LOAD POINTER TO INPUT DCB                
         USING IHADCB,R8               ESTABLISH ADDRESSABILITY TO DCB          
         MVC   INPUT(INPUTL),INPUTC    MOVE INPUT DCB CONSTANT INTO             
*                                      INPUT DCB IN WORKAREA                    
         L     R1,SAVER6               GET SAVED ADDRESS OF DSN PDE WFB         
         L     R1,0(,R1)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BNE   OPENMEM                 NO, GO OPEN AGAIN FOR MEMBER WFB         
         MVC   DCBDDNAM,PREALDDN       MOVE DDNAME INTO INPUT DCB   WFB         
OPENMEM  DS    0H                                                   WFB         
         MVC   OPENLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO OPEN LIST IN WORKAREA               
         LA    R1,XLIST                LOAD ADDRESS OF EXIT LIST                
         ST    R1,DCBEXLST             STORE ADDRESS OF EXIT LIST IN            
*                                      DCB                                      
         LA    R1,SEXIT                LOAD ADDRESS OF EODAD EXIT               
         ST    R1,DCBEODAD             STORE ADDRESS EODAD IN DCB               
         LA    R2,JFCBAREA             LOAD ADDRESS OF JFCBAREA                 
         ST    R2,XLIST                STORE ADDRESS IN EXIT LIST               
         MVI   XLIST,X'87'             SET END OF LIST AND JFCB BYTE            
         MVC   RDJL,OPENCLOS           MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO READJFCB LIST IN                    
*                                      WORKAREA                                 
         RDJFCB (INPUT,),MF=(E,RDJL)   READ JFCB INTO JFCBAREA                  
         MVC   JFCBELNM,8(R4)          MOVE MEMBER NAME INTO JFCB               
         OI    JFCBIND1,JFCPDS         SET JFCB TO INDICATE PDS MEMBER          
         MVI   JFCDSRG1,HEX00          SET JFCB TO REMOVE OTHER DSORG           
*                                      INDICATORS                               
         OPEN  ((R8),INPUT),TYPE=J,MF=(E,OPENLST)  OPEN INPUT DCB               
         L     R9,PARSBACK             LOAD ADDRESS PARS ANSWER                 
         USING IKJPARMD,R9             ESTABLISH ADDRESSABILITY TO PDL          
         CLC   PLIST,HALF2             SEE IF NOLIST SPECIFIED                  
         BE    NOLIST                  YES....SKIP LISTING                      
         CLC   PLIST,HALF1             SEE IF LIST SPECIFIED                    
         BE    LISTIT                  YES....GO LISTIT                         
         CLC   PPRINT,HALF1            SEE IF PRINT SPECIFIED                   
         BE    NOLIST                  YES....SKIP LISTING                      
         DROP  R9                      DROP ADDRESSABILITY TO PDL               
LISTIT   DS    0H                                                               
         MVC   HEADER,HEADERM          MOVE HEADER INTO DATA AREA               
         TM    DCBRECFM,DCBRECCM       SEE IF CONTROL IS MACHINE                
         DROP  R8                      DROP ADDRESSABILITY TO DCB               
         BNO   SUSEA                   NO.....GO TO USE ASA CONTROL             
         LA    R5,OUTPUTM              LOAD ADDRESS OF OUTPUT DCB FOR           
*                                      MACHINE CODE                             
         LA    R4,EJECTM               LOAD ADDRESS OF EJECT DATA               
         MVI   HDRCNTL,SKIPM           MOVE INTO HEADER MACHINE CODE            
*                                      FOR SPACE                                
         TM    48(R5),DCBOFOPN         SEE IF DCB IS ALREADY OPEN               
         BO    SPUTDSN                 YES....GO PUT OUT HEADERS                
         LA    R3,PRINTM               LOAD POINTER TO PRINTM                   
         LA    R14,SPUTDSN             LOAD ADDRESS FOR RETURN FROM             
*                                      SYSOUT ALLOCATION                        
         B     ALLOCOUT                GO TO ALLOCATE SYSOUT                    
SUSEA    DS    0H                                                               
         LA    R5,OUTPUTA              LOAD ADDRESS OF OUTPUT DCB FOR           
*                                      ASA CODE                                 
         LA    R4,EJECTA               LOAD ADDRESS OF EJECT DATA               
         TM    48(R5),DCBOFOPN         SEE IF DCB IS ALREADY OPEN               
         BO    SPUTDSN                 YES....GO PUT OUT HEADERS                
         LA    R3,PRINTA               LOAD POINTER TO PRINTA                   
         BAL   R14,ALLOCOUT            LOAD ADDRESS FOR RETURN AND GO           
*                                      DO SYSOUT ALLOCATION                     
SPUTDSN  DS    0H                                                               
         PUT   (R5),(R4)               PUT OUT PAGE EJECT                       
         PUT   (R5),HEADER             PUT OUT PAGE 1 HEADER                    
         MVC   HEADER2,LDSNAME         MOVE LENGTH AND 'DSNAME=' INTO           
*                                      INTO SECOND HEADER                       
         MVC   HEADER2+4(1),HDRCNTL    MOVE IN CONTROL BYTE                     
         MVI   OPENPRN,BLANK           BLANK OUT MEMBER NAME                    
         MVC   MEMNAME(9),OPENPRN      FINISH BLANKING OUT MEMBER NAME          
         PUT   (R5),HEADER2            PUT OUT PAGE 1 HEADER 2                  
         L     R2,MEMTABLE             LOAD ADDRESS OF FIRST TABLE              
         MVC   LENGTH,HALF85           SET LENGTH TO 85 BYTES                   
         MVC   LENGTH+2,HALF0          ZERO RESERVED BYTES                      
         MVC   CNTLBYTE,HDRCNTL        MOVE IN HEADER CONTROL BYTE              
*                                                                               
***********************************************************************         
*                                                                     *         
*        LIST MEMBER NAMES                                            *         
*                                                                     *         
***********************************************************************         
*                                                                               
SCROLLER DS    0H                                                               
         LA    R10,50                  LOAD LINE COUNT                          
         ST    R2,PRESENT              SAVE ADDRESS OF CURRENT TABLE            
         LH    R7,4(R2)                LOAD NUMBER OF MEMBERS IN TABLE          
         LTR   R7,R7                   SEE IF THERE ARE ENTRIES                 
         BZ    NOLIST                  NO.....GO PRINT MEMBERS                  
         LA    R2,8(R2)                LOAD ADDRESS OF FIRST MEMBER             
         USING MEMDSECT,R2             ESTABLISH ADDRESSABILITY TO              
*                                      MEMBER TABLE ENTRY                       
LOOP1    DS    0H                                                               
         LA    R6,DATA                 LOAD ADDRESS OF OUTPUT BUFFER            
         MVI   DATA,BLANK              BLANK OUT OUTPUT BUFFER                  
         MVC   DATA+1(79),DATA         FINISH BLANKING BUFFER                   
         TM    CFIELD,HIGH             SEE IF THIS IS AN ALIAS                  
         BZ    NOTALIAS                NO.....CONTINUE WITH MAIN NAME           
         BAL   R14,LOOKLOOP            GO LOOK FOR MAIN NAME                    
NOTALIAS DS    0H                                                               
         MVC   2(8,R6),MEMBER          PUT MEMBER NAME IN OUTPUT BUFFER         
         ST    R2,SAVER2               SAVE REGISTER 2                          
         LA    R3,2                    LOAD NUMBER OF COLUMNS LEFT              
         LA    R8,1                    LOAD ENTRY NUMBER                        
LOOP2    LA    R8,50(R8)               LOAD POINTER TO NEXT COLUMN              
*                                      ENTRY                                    
         CR    R8,R7                   SEE IF VALID ENTRY                       
         BH    END2                    NO.....GO PRINT LINE                     
         LA    R2,600(R2)              LOAD POINTER TO MEMBER NAME              
         LA    R6,30(R6)               LOAD POINTER TO NEXT OUTPUT              
*                                      BUFFER LOCATION                          
         TM    CFIELD,HIGH             SEE IF THIS IS AN ALIAS                  
         BZ    NOTAL2                  NO.....CONTINUE WITH MAIN NAME           
         BAL   R14,LOOKLOOP            GO LOOK FOR MAIN NAME                    
NOTAL2   DS    0H                                                               
         MVC   2(8,R6),MEMBER          PUT MEMBER NAME IN OUTPUT BUFFER         
         BCT   R3,LOOP2                DECREMENT COLUMN COUNT                   
END2     DS    0H                                                               
         PUT   (R5),LINE               PUT OUT OUTPUT LINE                      
         L     R2,SAVER2               RELOAD REGISTER 2                        
         LA    R2,MEMSECTN             LOAD POINTER TO NEXT MEMBER NAME         
         BCT   R10,MOREROW             DECREMENT ROW COUNT                      
         PUT   (R5),(R4)               PUT OUT PAGE EJECT WHEN ZERO             
         B     LOOP3                   RESET COUNTERS                           
MOREROW  DS    0H                                                               
         BCT   R7,LOOP1                DECREMENT MEMBER COUNT FOR               
*                                      CURRENT TABLE                            
LOOP3    L     R2,PRESENT              LOAD POINTER TO CURRENT TABLE            
         L     R2,0(R2)                LOAD POINTER TO NEXT TABLE               
         LTR   R2,R2                   SEE IF IT WAS THE LAST TABLE             
         BNZ   SCROLLER                NO.....GO LIST OUT NEXT TABLE            
*                                                                               
***********************************************************************         
*                                                                     *         
*        PRINT MEMBERS IF:                                            *         
*           PRINT SPECIFIED OR                                        *         
*           BOTH LIST AND NOPRINT WERE NOT SPECIFIED                  *         
*                                                                     *         
***********************************************************************         
*                                                                               
NOLIST   DS    0H                                                               
         L     R9,PARSBACK             LOAD ADDRESS PARS ANSWER                 
         USING IKJPARMD,R9             ESTABLISH ADDRESSABILITY TO PDL          
         CLC   PPRINT,HALF2            SEE IF NOPRINT SPECIFIED                 
         BE    ENDMEMB                 YES....GO SKIP PRINT                     
         CLC   PPRINT,HALF1            SEE IF PRINT SPECIFIED                   
         BE    CONTPRT                 YES....GO PRINT MEMBERS                  
         CLC   PLIST,HALF1             SEE IF LIST SPECIFIED                    
         BE    ENDMEMB                 YES....GO SKIP PRINT                     
         DROP  R9                      DROP ADDRESSABILITY TO PDL               
CONTPRT  DS    0H                                                               
         L     R6,SAVER6               RESTORE REGISTER 6                       
         LA    R8,INPUT                LOAD ADDRESS OF INPUT DCB                
         USING IHADCB,R8               ESTABLISH ADDRESSABILITY TO DCB          
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST IN WORKAREA              
         CLOSE ((R8),),MF=(E,CLOSLST)  CLOSE INPUT DCB                          
         DROP  R8                      DROP ADDRESSABILITY TO INPUT DCB         
         TM    VOLBIT,NOMSG            IS NOMSG SPECIFIED ?         WFB         
         BO    NOMEMMSG                YES, SKIP MEMBER MESSAGE     WFB         
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(PRTMSG,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DATASET PRINT MESSAGE                    
         DROP  R15                                                  WFB         
         LH    R4,DFPBDSL              LOAD LENGTH OF DSNAME       GTEL         
         A     R4,FULL4                INCREMENT LENGTH FOR PUTLINE             
         SLL   R4,16                   SHIFT LENGTH TO HIGH ORDER BYTES         
         STCM  R4,15,DSNLENP           STORE LENGTH OF PUTLINE                  
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(DSNLENP,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      DATA SET NAME MESSAGE                    
         DROP  R15                                                  WFB         
NOMEMMSG DS    0H                                                   WFB         
         L     R2,MEMTABLE             LOAD ADDRESS OF FIRST MEMBER             
*                                      TABLE                                    
         LH    R3,4(R2)                LOAD NUMBER OF MEMBERS IN TABLE          
         LTR   R3,R3                   SEE IF THERE ARE ANY MEMBERS             
         BZ    ENDMEMB                 NO.....GO TO END OF SCROLLER             
         ST    R2,PRESENT              SAVE ADDRESS OF CURRENT TABLE            
         LA    R2,8(R2)                LOAD POINTER TO MEMBER NAME              
NEXTMEMB DS    0H                                                               
         TM    CFIELD,HIGH             SEE IF THIS IS AN ALIAS ENTRY            
         BO    AGAIN                   YES....DO NOT PRINT IT                   
PRINTMEM DS    0H                                                               
         MVC   MEMNAME,MEMBER          MOVE MEMBER NAME INTO HEADER             
         MVC   JFCBELNM,MEMBER         MOVE MEMBER NAME INTO JFCBAREA           
         MVC   OPENLST,OPENCLOS        MOVE CONSTANT INTO OPEN LIST             
         OPEN  ((R8),INPUT),TYPE=J,MF=(E,OPENLST)                               
*                                      OPEN INPUT DCB                           
         STM   R2,R3,SAVER2            SAVE REGISTERS 2 AND 3                   
         B     PRINTS                  GO PRINT MEMBER                          
SEXIT    DS    0H                                                               
         LM    R2,R3,SAVER2            RESTORE REGISTERS 2 AND 3                
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST IN WORKAREA              
         CLOSE ((R8),),MF=(E,CLOSLST)  CLOSE INPUT DCB                          
AGAIN    DS    0H                                                               
         LA    R2,MEMSECTN             LOAD ADDRESS OF NEXT MEMBER              
         BCT   R3,NEXTMEMB             BRANCH TO HANDLE NEXT MEMBER             
         L     R14,PRESENT             ZERO...LOAD CURRENT TABLE                
*                                      ADDRESS                                  
         L     R2,0(R14)               LOAD ADDRESS OF NEXT TABLE               
         LTR   R2,R2                   SEE IF ZERO, LAST TABLE                  
         BZ    ENDMEMB                 NO.....GO HANDLE END OF MEMBERS          
         ST    R2,PRESENT              SAVE ADDRESS OF CURRENT TABLE            
         LH    R3,4(R2)                LOAD NUMBER OF MEMBERS IN NEXT           
*                                      TABLE                                    
         LTR   R3,R3                   SEE IF ANY MEMBERS IN TABLE              
         BZ    ENDMEMB                 NO.....GO HANDLE END OF MEMBERS          
         LA    R2,8(R2)                LOAD POINTER TO MEMBER NAME              
         B     NEXTMEMB                GO GET NEXT MEMBER                       
ENDMEMB  DS    0H                                                               
         L     R2,MEMTABLE             LOAD POINTER TO FIRST TABLE              
FREETABS DS    0H                                                               
         LR    R1,R2                   LOAD AREA TO BE FREED                    
         L     R2,0(R2)                LOAD POINTER TO NEXT TABLE               
         L     R0,MEMDATL              LOAD SIZE OF AREA TO BE FREED            
         FREEMAIN R,LV=(0),A=(1)       FREE STORAGE GETMAINED FOR TABLE         
         LTR   R2,R2                   SEE IF THERE WAS ANOTHER TABLE           
         BNZ   FREETABS                YES....GO FREE NEXT TABLE                
         L     R6,SAVER6               RESTORE REGISTER 6                       
         LA    R8,INPUT                LOAD POINTER TO INPUT DCB                
         USING IHADCB,R8               ESTABLISH ADDRESSABILITY TO DCB          
         TM    DCBOFLGS,DCBOFOPN       SEE IF INPUT DCB IS STILL OPEN           
         BNO   EXITMSG                 NO.....GO HANDLE NEXT DATASET            
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST IN WORKAREA              
         CLOSE ((R8),),MF=(E,CLOSLST)  CLOSE INPUT DCB                          
         DROP  R8                      DROP ADDRESSABILITY TO DCB               
         B     EXITMSG                 GO HANDLE NEXT DATASET                   
*                                                                     *         
***********************************************************************         
*                                                                     *         
*        PUT OUT SYNAD ERROR MESSAGE,                                 *         
*           GO FREE MEMBER TABLES, AND                                *         
*           CONTINUE WITH NEXT DATASET                                *         
*                                                                     *         
***********************************************************************         
*                                                                               
SERRI    DS    0H                                                               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(SYNADI,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DATASET NOT PRINTED DUE TO SYNAD         
*                                      ERROR ON INPUT DATASET MESSAGE           
         DROP  R15                                                  WFB         
         B     ENDMEMB                 GO FREE MEMBER TABLES                    
*                                                                     *         
***********************************************************************         
*                                                                     *         
*        SEARCH FOR MAIN NAME,                                        *         
*           SAME TTR AND NOT AN ALIAS                                 *         
*                                                                     *         
***********************************************************************         
*                                                                               
LOOKLOOP DS    0H                                                               
         STM   R3,R4,SAVER3            SAVE REGISTERS 3 AND 4                   
         L     R3,MEMTABLE             LOAD ADDRESS OF FIRST TABLE              
         USING MEMDSECT,R3             ESTABLISH ADDRESSABILITY TO              
*                                      MEMBER ENTRY                             
LOOP4    DS    0H                                                               
         ST    R3,CURRENT              SAVE ADDRESS OF PRESENT TABLE            
         LH    R4,4(R3)                LOAD NUMBER OF ELEMENTS IN TABLE         
         LTR   R4,R4                   SEE IF THERE ARE ZERO ELEMENTS           
         BZ    NOMAIN                  YES....GO HANDLE MAIN NOT FOUND          
         LA    R3,8(R3)                LOAD ADDRESS OF FIRST MEMBER             
LOOP5    DS    0H                                                               
         CLC   MEMTTR,8(R2)            SEE IF TTRS ARE THE SAME                 
         BE    SAMETTR                 YES....GO SEE IF IT IS AN ALIAS          
ENDLP5   DS    0H                                                               
         LA    R3,MEMSECTN             LOAD ADDRESS OF NEXT MEMBER              
         BCT   R4,LOOP5                DECREMENT MEMBER COUNT                   
         L     R3,CURRENT              LOAD ADDRESS OF THIS TABLE               
         L     R3,0(R3)                LOAD ADDRESS OF NEXT TABLE               
         LTR   R3,R3                   SEE IF IT WAS THE LAST TABLE             
         BNZ   LOOP4                   NO.....GO CHECK NEXT TABLE               
         B     NOMAIN                  GO HANDLE MAIN NOT FOUND                 
SAMETTR  DS    0H                                                               
         TM    CFIELD,HIGH             SEE IF THIS IS ALSO AN ALIAS             
         BO    ENDLP5                  YES....GO LOOK FOR ANOTHER TTR           
         MVC   11(8,R6),MEMBER         MOVE MEMBER NAME INTO OUTPUT             
         B     ENDLOOK                 GO TO RETURN TO CALLER                   
NOMAIN   DS    0H                                                               
         MVC   11(8,R6),ALIAS          INDICATE THIS IS AN ALIAS                
ENDLOOK  DS    0H                                                               
         LM    R3,R4,SAVER3            RESTORE REGISTERS 3 AND 4                
         BR    R14                     RETURN TO CALLER                         
         DROP  R3                      DROP ADDRESSABILITY TO TABLE             
*                                                                               
CONTINUE DS    0H                                                               
         L     R1,0(,R6)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BE    CLOSDCBS                YES, DO NOT FOLLOW CHAIN     WFB         
         L     R6,24(R6)               LOAD POINTER TO NEXT DSNAME ON           
*                                      CHAIN                                    
         C     R6,ENDCHAIN             SEE IF END OF CHAIN IS REACHED           
         BNE   NEXT                    NO.....GO DO NEXT DATASET NAME           
CLOSDCBS DS    0H                                                               
         TM    INPUT+48,DCBOFOPN       SEE IF INPUT DCB IS STILL OPEN           
         BNO   CHKOUTA                 NO.....GO CHECK DCB FOR ASA CODE         
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST WORKAREA                 
         LA    R5,INPUT                LOAD POINTER TO INPUT DCB                
         CLOSE ((R5),),MF=(E,CLOSLST)  CLOSE INPUT DCB                          
         L     R1,0(,R6)               GET ADDRESS OF DSNAME        WFB         
         CLI   0(R1),C'*'              SEE IF DSNAME IS ASTERISK    WFB         
         BE    CHKOUTA                 YES, DO NOT FREE DDN(...)    WFB         
         LA    R1,PRINTI               FREE INPUT DATASET          GTEL         
         BAL   R2,FREEDD               FREE INPUT DATASET          GTEL         
CHKOUTA  DS    0H                                                               
         TM    OUTPUTA+48,DCBOFOPN     SEE IF OUTPUT DCB FOR ASA WAS            
*                                      OPENED                                   
         BNO   CHKOUTM                 NO.....GO CHECK DCB FOR MACHINE          
*                                      CODE                                     
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST WORKAREA                 
         LA    R5,OUTPUTA              LOAD POINTER TO ASA CODE DCB             
         TM    VOLBIT,UDKDONE          WERE UDKS WRITTEN ?          WFB         
         BZ    CLOSEA                  NO, GO CLOSE                 WFB         
         PUT   (R5),UDKRESET           PUT OUT UDK RESET TEXT       WFB         
         NI    VOLBIT,UDKDONE          TURN OFF UDK WRITTEN FLAG    WFB         
CLOSEA   DS    0H                                                   WFB         
         CLOSE ((R5),),MF=(E,CLOSLST)  CLOSE ASA CODE OUTPUT DCB                
         LA    R1,PRINTA               LOAD ADDRESS OF PRINT DDNAME             
         BAL   R2,FREEDD               GO FREE ASA CODE OUTPUT DDNAME           
CHKOUTM  DS    0H                                                               
         TM    OUTPUTM+48,DCBOFOPN     SEE IF OUTPUT DCB FOR MACHINE            
*                                      CODE WAS OPENED                          
         BNO   RETURN                  NO.....GO FREE GETMAINED AREAS           
*                                      AND RETURN                               
         MVC   CLOSLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO CLOSE LIST WORKAREA                 
         LA    R5,OUTPUTM              LOAD POINTER TO MACHINE CODE DCB         
         TM    VOLBIT,UDKDONE          WERE UDKS WRITTEN ?          WFB         
         BZ    CLOSEM                  NO, GO CLOSE                 WFB         
         PUT   (R5),UDKRESET           PUT OUT UDK RESET TEXT       WFB         
         NI    VOLBIT,UDKDONE          TURN OFF UDK WRITTEN FLAG    WFB         
CLOSEM   DS    0H                                                   WFB         
         CLOSE ((R5),),MF=(E,CLOSLST)  CLOSE MACHINE CODE OUTPUT DCB            
         LA    R1,PRINTM               LOAD ADDRESS OF PRINT DDNAME             
         BAL   R2,FREEDD               GO FREE MACHINE CODE OUTPUT              
*                                      DDNAME                                   
*                                                                               
***********************************************************************         
*                                                                     *         
*        CLEANUP AREAS GETMAINED BY PARS,                             *         
*           SET RETURN CODE, RESTORE REGISTERS AND                    *         
*           RETURN TO CALLER                                          *         
*                                                                     *         
***********************************************************************         
*                                                                               
RETURN   DS    0H                                                               
         IKJRLSA PARSBACK              RELEASE AREAS GETMAINED BY PARS          
         L     R1,ALNDSECT                                                      
         FREEMAIN R,LV=RECSIZE,A=(1)                                WFB         
         LR    R1,R13                  LOAD ADDRESS OF GETMAINED AREA           
         L     R13,4(,R13)             RELOAD ADDRESS OF PREVIOUS SAVE          
*                                      AREA                                     
         LA    R0,LDYNAMIC             LOAD LENGTH OF GETMAINED AREA            
         FREEMAIN R,LV=(0),A=(1)       FREE GETMAINED AREA                      
         SLR   R15,R15                 ZERO REGISTER 15.  RETURN CODE           
*                                      CODE WILL ALWAYS BE ZERO                 
         L     R14,12(,R13)            LOAD REGISTER 14 WITH RETURN             
*                                      ADDRESS                                  
         LM    R0,R12,20(R13)          RESTORE REGISTERS                        
         BR    R14                     RETURN                                   
*                                                                               
***********************************************************************         
*                                                                     *         
*        ROUTINE TO CONVERT NONZERO RETURN CODES TO DECIMAL           *         
*           FOR DISPLAY                                               *         
*                                                                     *         
***********************************************************************         
*                                                                               
SETCODE  DS    0H                                                               
         CVD   R8,DEC                  CONVERT RETURN CODE TO DECIMAL           
         UNPK  CONV(8),DEC(8)          UNPACK RETURN CODE                       
         MVZ   CONV+1(7),CONV          MOVE ZONES IN CONVERTED RETURN           
*                                      CODE                                     
         MVC   RETNCD(2),HALF12        MOVE LENGTH OF DATA FOR PUTLINE          
         MVC   RETNCD+2(2),HALF0       MOVE IN ZEROES FOR PUTLINE               
         BR    R14                     RETURN                                   
*                                                                               
***********************************************************************         
*                                                                     *         
*        FREE AND REALOCATE PRINTX FILE AS SYSOUT                     *         
*                                                                     *         
***********************************************************************         
*                                                                               
ALLOCOUT DS    0H                                                               
         STM   14,9,ALCSAVE            SAVE WORK REGISTERS                      
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
         MVC   SETPRTE(SETPRTEL),SETPRTL MOVE SETPRT LIST                       
         MVI   SETFLAG,X'00'             AND CLEAR FLAG                         
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
         LR    R1,R3                   LOAD POINTER TO DDNAME                   
         BAL   R2,FREEDD               BRANCH TO FREE ROUTINE                   
         LTR   R8,R8                   SEE IF RETURN CODE FROM FREE IS          
*                                      ZERO                                     
         BNZ   OPENFAIL                NO.....GO PUT OUT OPEN FAILED            
         LA    R8,REQBLK               LOAD POINTER TO REQUEST BLOCK            
         ST    R8,RBPTR                INITIALIZE REQUEST BLOCK POINTER         
         MVI   RBPTR,S99RBPND          INDICATE END OF PARAMETER LIST           
         USING S99RB,R8                ESTABLISH ADDRESSABILITY TO              
*                                      REQUEST BLOCK                            
         MVC   S99RBLN(RBLEN),REQBLKC  INITALIZE RB                             
         LA    R1,TEXTPTRS             LOAD POINTER TO TEXT POINTERS            
         ST    R1,S99TXTPP             STORE POINTER IN RB                      
         DROP  R8                      DROP ADDRESSABILITY TO RB                
         USING S99TUPL,R1              ESTABLISH ADDRESSABILITY TO              
*                                      TEXT UNIT POINTER LIST                   
         LA    R2,TEXTA                LOAD POINTER TO FIRST TEXT UNIT          
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         USING S99TUNIT,R2             ESTABLISH ADDRESSABILITY TO              
*                                      TEXT UNIT                                
         MVC   S99TUKEY(TEXTALEN),TEXTAC  INITIALIZE TEXT UNIT A                
         MVC   S99TUPAR(8),0(R3)       MOVE IN PARAMETER (DDNAME)               
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTB                LOAD POINTER TO TEXT UNIT B              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTBLEN),TEXTBC  INITIALIZE TEXT UNIT B                
*                                                                               
***********************************************************************         
*                                                                     *         
*        SET UP ADDRESSABILITY TO PDL                                 *         
*           AND SEE IF SYSOUT CLASS/DEST ARE PRESENT                  *         
*           ALSO FORMS/TRAIN/FCB/PROG.                             GTEL         
***********************************************************************         
*                                                                               
         L     R9,PARSBACK             LOAD ADDRESS PARS ANSWER                 
         USING IKJPARMD,R9             ESTABLISH ADDRESSABILITY TO PDL          
         CLC   PCLASS(2),HALF1         SEE IF CLASS SPECIFIED                   
         BNE   NOCLASS                 NO.....GO CHECK FOR DESTINATION          
         L     R7,SCLASS               LOAD POINTER TO SYSOUT CLASS             
         MVC   S99TUPAR,0(R7)          MOVE CLASS INTO TEXT UNIT B              
NOCLASS  DS    0H                                                               
         CLC   PDEST(2),HALF1          SEE IF DEST SPECIFIED                    
         BNE   NODEST                  NO.....GO CHECK FOR HOLD                 
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTC                LOAD POINTER TO TEXT UNIT C              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTCLEN),TEXTCC  INITIALIZE TEXT UNIT C                
         L     R7,SDEST                LOAD POINTER TO DESTINATION              
         CLI   NODELEN+1,0             IS NODE.USERID SPECIFIED ?   WFB         
         BZ    NONODE                  NO, USE TOTAL LENGTH         WFB         
         LH    R6,NODELEN              YES, USE NODE LENGTH         WFB         
         STH   R6,S99TULNG             STORE LENGTH OF DEST IN TU   WFB         
         BCTR  R6,0                    DECREMENT LENGTH FOR EXECUTE WFB         
         EX    R6,MOVEDEST             MOVE NODE INTO TEXT UNIT     WFB         
         LA    R1,4(,R1)               POINT NEXT TEXT UNIT POINTER WFB         
         LA    R2,TEXTK                ADDRESS TEXT UNIT K - USERID WFB         
         ST    R2,S99TUPTR             STORE ADDRESS IN TUPL        WFB         
         MVC   S99TUKEY(TEXTKLEN),TEXTKC  INITIALIZE TEXT UNIT K    WFB         
         LA    R7,2(R6,R7)             POINT PAST 'NODE.' TO USERID WFB         
         LH    R6,SDEST+4              GET TOTAL LENGTH             WFB         
         SH    R6,NODELEN              MINUS NODE LENGTH            WFB         
         SH    R6,HALF2                MINUS 1 FOR DOT, 1 EXECUTE   WFB         
         EX    R6,MOVEDEST             MOVE USERID INTO TEXT UNIT   WFB         
         B     NODEST                                               WFB         
NONODE   DS    0H                                                   WFB         
         LH    R6,SDEST+4              LOAD LENGTH OF DESTINATION ID            
         STH   R6,S99TULNG             STORE LENGTH OF DEST IN TU               
         BCTR  R6,0                    DECREMENT LENGTH FOR EXECUTE OF          
*                                      MOVE                                     
         EX    R6,MOVEDEST             MOVE DEST INTO TU                        
MOVEDEST MVC   S99TUPAR,0(R7)          MOVE TO BE EXECUTED                      
*                                                                               
NODEST   DS    0H                                                               
         CLC   PHOLD(2),HALF1          SEE IF HOLD SPECIFIED                    
         BNE   NOHOLD                  NO.....GO CHECK FOR COPIES               
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTDC               LOAD POINTER TO TEXT UNIT C              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
NOHOLD   DS    0H                                                               
         CLC   PCOPIES(2),HALF1        SEE IF COPY SPECIFIED                    
         BNE   NOCOPY                  NO.....GO ZERO ECB                       
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTE                LOAD POINTER TO TEXT UNIT E              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTELEN),TEXTEC  INITIALIZE TEXT UNIT E                
         L     R7,SCOPIES              LOAD POINTER TO COPY FIELD               
         LH    R6,SCOPIES+4            LOAD LENGTH OF COPY FIELD                
         BCTR  R6,0                    DECREMENT REGISTER 6 FOR EXECUTE         
*                                      OF PACK INSTRUCTION                      
         EX    R6,PACKCOPY             EXECUTE PACK TO CONVERT COPIES           
*                                      TO ZONED DECIMAL                         
         CVB   R6,DEC                  CONVERT ZONED TO BINARY                  
         STCM  R6,1,S99TUPAR           STORE NUMBER OF COPIES IN TU             
NOCOPY   DS    0H                                                               
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** START OF GTEL MOD ************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
         CLC   PFORMS(2),HALF1         SEE IF FORMS SPECIFIED                   
         BNE   NOFORMS                 NO.....GO CHECK TRAIN                    
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTI                LOAD POINTER TO TEXT UNIT I              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTILEN),TEXTIC  INITIALIZE TEXT UNIT I                
         L     R7,RFORMS               LOAD POINTER TO FORMS FIELD              
         LH    R6,RFORMS+4             LOAD LENGTH OF FORMS FIELD               
         STH   R6,S99TULNG             STORE LENGTH IN TUE                      
         BCTR  R6,0                    DECREMENT LENGTH                         
         EX    R6,MOVEDEST             MOVE FORMS INTO FIELD                    
NOFORMS  DS    0H                                                               
         CLC   PTRAIN(2),HALF1         SEE IF TRAIN SPECIFIED                   
         BNE   NOTRAIN                 NO.....GO CHECK FCB                      
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTH                LOAD POINTER TO TEXT UNIT G              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTHLEN),TEXTHC  INITIALIZE TEXT UNIT H                
         L     R7,RTRAIN               LOAD POINTER TO TRAIN FIELD              
         LH    R6,RTRAIN+4             LOAD LENGTH OF TRAIN FIELD               
         STH   R6,S99TULNG             SAVE LENGTH OF FCBE                      
         BCTR  R6,0                    DECREMENT FOR EX                         
         EX    R6,MOVEDEST             MOVE FCB INTO TU                         
NOTRAIN  DS    0H                                                               
         CLC   PFCB(2),HALF1           SEE IF FCB  SPECIFIED                    
         BNE   NOFCB                   NO.....GO ZERO ECB                       
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTG                LOAD POINTER TO TEXT UNIT G              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTGLEN),TEXTGC  INITIALIZE TEXT UNIT G                
         L     R7,RFCB                 LOAD POINTER TO FCB FIELD                
         LH    R6,RFCB+4               LOAD LENGTH OF FCB FIELD                 
         STH   R6,S99TULNG             SAVE LENGTH OF FCB IN TUE                
         BCTR  R6,0                    DECREMENT                                
         EX    R6,MOVEDEST             MOVE FCB TO TU                           
NOFCB    DS    0H                                                               
         CLC   PPROG(2),HALF1          SEE IF PROG SPECIFIED                    
         BNE   NOPROG                  NO.....GO ZERO ECB                       
         CLI   NODELEN+1,0             IS DEST(NODE.USERID) GIVEN ? WFB         
         BH    NOPROG                  YES, IGNORE PROG             WFB         
*                                      DYNALLOC TEXT UNITS FOR USER WFB         
*                                      AND PROG ARE MUTUAL EXCLUSIV WFB         
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTJ                LOAD POINTER TO TEXT UNIT J              
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVC   S99TUKEY(TEXTJLEN),TEXTJC  INITIALIZE TEXT UNIT J                
         L     R7,RPROG                LOAD POINTER TO PROG FIELD               
         LH    R6,RPROG+4              LOAD LENGTH OF PROG FIELD                
         STH   R6,S99TULNG             SAVE LENGTH OF PROG IN TUE               
         BCTR  R6,0                    DECREMENT FOR MOVE                       
         EX    R6,MOVEDEST             MOVE PROG TO TU                          
NOPROG   DS    0H                                                               
         CLC   PLINELEN(2),HALF1       SEE IF LL SPECIFIED                      
         BNE   LLDEF                   NO...                                    
         L     R7,RLINELEN             LOAD POINTER TO LL FIELD                 
         LH    R6,RLINELEN+4           LOAD LENGTH OF LL FIELD                  
         BCTR  R6,0                    DECREMENT FOR PACK                       
         EX    R6,ZEROTEST             LINELENGTH 0 ENTERED?                    
         BE    LLDEF                   IF YES, USE DEFAULT                      
         EX    R6,PACKLEN              CONVERT INTO PACKED DECIMAL              
         CVB   R6,DEC                  CONVERT INTO FIXED BINARY                
         CH    R6,HALF1                LESS THAN ONE?                           
         BNL   NOLLDEF                 IF YES, USE DEFAULT                      
         CH    R6,HALF208              GREATER THAN 208?                        
         BNH   NOLLDEF                 IF YES, USE DEFAULT                      
LLDEF    LH    R6,HALF132              PLACE 132 IN R6                          
NOLLDEF  STH   R6,LINELEN              STORE INTO LINELEN                       
         A     R6,FULL5                ADD LENGTH FOR VB OUTPUT                 
         STH   R6,VBLEN                STORE INTO VBLEN1                        
         MVI   CCBIT,BLANK             INITIALIZE CCBIT WITH BLANK              
         CLC   PPAGELEN(2),HALF1       SEE IF PL SPECIFIED                      
         BNE   PLDEF                   NO...                                    
         OI    CCBIT,HIGH              YES, SET BIT FOR PAGE LEN                
         L     R7,RPAGELEN             LOAD POINTER TO PL FIELD                 
         LH    R6,RPAGELEN+4           LOAD LENGTH OF PL FIELD                  
         BCTR  R6,0                    DECREMENT FOR PACK                       
         EX    R6,ZEROTEST             PAGELENGTH 0 SPECIFIED?                  
         BE    PLDEF                   IF YES, USE DEFAULT                      
         EX    R6,PACKPAG              CONVERT INTO PACKED DECIMAL              
         CVB   R6,DEC                  CONVERT INTO FIXED BINARY                
         CH    R6,HALF5                LESS THAN 5?                             
         BNL   NOPLDEF                 IF YES, USE DEFAULT                      
         CH    R6,HALF120              GREATER THAN 120?         ARAMCO         
         BNH   NOPLDEF                 IF YES, USE DEFAULT                      
PLDEF    LH    R6,HALF60               LOAD DEFAULT INTO R6      ARAMCO         
NOPLDEF  STH   R6,PAGELEN              STORE INTO PAGELEN                       
         CLC   PSPACE(2),HALF1         SEE IF SINGLE SPACE FORMAT               
         BE    SETSS                   YES...                                   
         CLC   PSPACE(2),HALF2         SEE IF DOUBLE SPACE FORMAT               
         BE    SETDS                   GO ON                                    
         CLC   PASA(2),HALF1           USER SAYS ASA IS IN DATA ?   WFB         
         BNE   CCSET                   NO, CONTINUE                 WFB         
         OI    CCBIT,FORCEASA          YES, SET FORCE BIT           WFB         
         B     CCSET                   CONTINUE IF NEITHER SS OR DS             
SETSS    OI    CCBIT,MID1              FOR SINGLE SPACE CC                      
         B     CCSET                                                            
SETDS    OI    CCBIT,MID2              FOR DOUBLE SPACE CC                      
         LH    R6,PAGELEN              DECREMENT PAGE LENGTH     ARAMCO         
         BCTR  R6,0                                              ARAMCO         
         STH   R6,PAGELEN              BY 1 FOR DS LISTINGS.     ARAMCO         
CCSET    DS    0H                                                               
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** END OF GTEL MOD **************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
         CLC   PBURST(2),HALF1         WAS BURST PARM "BURST"?                  
         BNE   NOBURST                 NO, CHECK FLASH                          
         OI    SETFLAG,SETBURST        YES, TURN ON FLAG                        
         OI    SETPRTE+16,X'80'        AND SET SETPRT BIT                       
NOBURST  DS    0H                                                               
         CLC   PFLASH(2),HALF1         ANY FLASH PARM ?                         
         BNE   NOFLASH                 NO, CHECK CHARS                          
         L     R7,RFLASH               YES, POINT AT PARM                       
         LH    R6,RFLASH+4             AND GET LENGTH                           
         BCTR  R6,0                    DECREMENT FOR MOVE                       
         MVC   SETFLASH(4),BLANKS      BLANK IT OUT                             
         MVC   SETFLASH(1),0(R7)                                                
         EX    R6,*-6                  AND MOVE PARM TO SETPRT                  
         OI    SETFLAG,SETFLSH                                                  
NOFLASH  DS    0H                                                               
         CLC   PCHARS(2),HALF1         ANY CHARS PARM ?                         
         BNE   CHAREND                 NO, END OF ARAMCO                        
         OI    SETFLAG,SETCHAR                                                  
         CLI   RCHARS+8,X'FF'          MORE THAN ONE CHAR SET?                  
         BE    CHARSET                 NO, BRANCH                               
         USING IHADCB,R15                                                       
         LA    R15,OUTPUTA                                                      
         OI    DCBOPTCD,DCBOPTJ        YES, SET OPTCD=J                         
         LA    R15,OUTPUTM AND ON VBM DCB TOO                                   
         OI    DCBOPTCD,DCBOPTJ                                                 
         DROP  R15                                                              
CHARSET  LA    R15,4                   SET LOOP LIMIT                           
         LA    R14,RCHARS              POINT AT FIRST CHARS PDE                 
         LA    R2,SETCHARS             AND AT SETPRT CHARS PARM                 
CHARLOOP L     R7,0(R14)               POINT TO INPUT CHARS PARM                
         LH    R6,4(R14)               AND GET LENGTH                           
         BCTR  R6,0                    DECREMENT FOR MOVE                       
         MVC   0(4,R2),BLANKS          BLANK IT OUT                             
         MVC   0(0,R2),0(R7)                                                    
         EX    R6,*-6                  AND MOVE PARM TO SETPRT                  
         CLI   8(R14),X'FF'            END OF LIST?                             
         BE    CHAREND                 YES, EXIT LOOP                           
         L     R14,8(R14)              NO, BUMP LOOP                            
         LA    R2,4(R2)                POINTERS AND KEEP GOING                  
         BCT   R15,CHARLOOP            MAX OF 4 CHARS PARMS                     
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(CHARMSG,SINGLE,DATA),MF=(E,IOPLSECT)                   
         DROP  R15                                                  WFB         
*DELETED B     CHAREND                                              WFB         
*                                      CHARMSG MOVED TO MSG CSECT   WFB         
CHAREND  DS    0H                                                               
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
         LA    R1,4(R1)                LOAD POINTER TO NEXT TEXT UNIT           
*                                      POINTER                                  
         LA    R2,TEXTFC               LOAD POINTER TO TEXT UNIT F              
*                                      PERMANENTLY ALLOCATED                    
*                                      ATTRIBUTE                                
         ST    R2,S99TUPTR             STORE POINTER IN TUPL                    
         MVI   S99TUPTR,S99TUPLN       INDICATE END OF TEXT UNIT                
*                                      POINTER LIST                             
         DROP  R1,R2,R9                DROP ADDRESSABILITY TO DSECTS            
         LA    R1,RBPTR                LOAD ADDRESS OF REQUEST BLOCK            
*                                      POINTER                                  
         DYNALLOC                      ISSUE DYNAMIC ALLOCATION SVC             
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO               
         BNZ   ALCFAIL                 NO.....GO AND CALL DAIR FAIL             
         MVC   OPENLST,OPENCLOS        MOVE OPEN(CLOSE) LIST CONSTANT           
*                                      INTO WORKAREA                            
         OPEN  ((R5),(OUTPUT)),MF=(E,OPENLST)                                   
*                                      OPEN OUTPUT DCB                          
         TM    48(R5),DCBOFOPN         SEE IF DCB OPENED SUCCESSFULLY           
         BNO   OPENFAIL                NO.....GO PUT OUT OUTPUT DCB             
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
CKSETPRT CLI   SETFLAG,X'00'           NEED SETPRT ?                            
         BE    NOSETPRT                NO, SKIP IT                              
         L     R6,DAPLSECT             ADDRESS UPT                              
         USING UPT,R6                                                           
         MVC   SAVEUPT(1),UPTSWS       SAVE UPT SWITCHES                        
         NI    UPTSWS,X'FF'-UPTWTP     GET RID OF MSG IEF288I                   
         SETPRT (R5),MF=(E,SETPRTE)                                             
         MVC   UPTSWS(1),SAVEUPT       RESTORE UPT SWITCHES                     
         DROP R6                                                                
NOSETPRT DS    0H                                                               
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
*                                      NOT OPENED MESSAGE                       
         LM    14,9,ALCSAVE            RESTORE REGISTERS                        
         BR    R14                     RETURN TO CALLER                         
ALCFAIL  DS    0H                                                               
         LA    R1,REQBLK               LOAD ADDRESS OF REQUEST                  
*                                      BLOCK                                    
         MVI   DFID+1,DFSVC99          SET DAIR FAIL FOR SVC 99 ERROR           
         BAL   R2,DAIRFAIL             LOAD ADDRESS OF OPEN FAIL AND            
*                                      BRANCH TO DAIRFAIL ROUTINE               
OPENFAIL DS    0H                                                               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(OPENMSG,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      OUTPUT DCB NOT OPEND MESSAGE             
         DROP  R15                                                  WFB         
         S     R3,FULL4                GET POINTER TO PUTLINE DDNAME            
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=((R3),SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT             
*                                      DDNAME                                   
         DROP  R15                                                  WFB         
         B     CLOSDCBS                GO CLOSE DCBS AND RETURN                 
*                                                                               
***********************************************************************         
*                                                                     *         
*        INVOKE DAIR TO FREE FILENAME VIA CALLTSSR                    *         
*           AND CHECK FOR ZERO RETURN CODE                            *         
*                                                                     *         
***********************************************************************         
*                                                                               
FREEDD   DS    0H                                                               
         SLR   R8,R8                   INITIALIZE REGISTER 8 TO ZERO            
*                                      RETURN CODE                              
         MVC   DAP18(DAPB18L),DAPB18C  INITIALIZE DAIR PARAMETER BLOCK          
*                                      18 (FREE BY DATASET)                     
         LA    R4,DAP18                LOAD ADDRESS OF DAPB                     
         USING DAPB18,R4               ESTABLISH ADDRESSABILITY TO              
*                                      DAPB                                     
         MVC   DA18DDN,0(R1)           MOVE DDNAME INTO DAPB                    
         SLR   R7,R7                   ZERO REGISTER 7                          
         ST    R7,ECB                  STORE REGISTER 7 AS DUMMY ECB            
         LA    R1,DAPLSECT             LOAD ADDRESS OF DAPL                     
         USING DAPL,R1                 ESTABLISH ADDRESSABILITY TO DAPL         
         ST    R4,DAPLDAPB             STORE ADDRESS OF DAPB IN DAPL            
         DROP  R1,R4                   DROP ADDRESSABILITY TO DAPL AND          
*                                      DAPB                                     
         CALLTSSR EP=IKJDAIR           CALL DAIR TO FREE DDNAME                 
         C     R15,FULL28              SEE IF RETURN CODE IS 28                 
*                                      (DDNAME NOT ALLOCATED)                   
         BER   R2                      YES....GO CONTINUE PROCESSING            
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO               
         BZR   R2                      YES....GO CONTINUE PROCESSING            
         MVI   DFID+1,DFDAIR           SET DAIRFAIL ID TO INDICATE DAIR         
*                                                                               
***********************************************************************         
*                                                                     *         
*        INVOKE DAIRFAIL TO DISPLAY AN ERROR MESSAGE                  *         
*                                                                     *         
***********************************************************************         
*                                                                               
DAIRFAIL XC    DFPARMS(DFLEN),DFPARMS  INITIALIZE PARMLIST FOR DAIR             
*                                      FAIL TO ZEROS                            
         ST    R1,DFDAPLP              STORE POINTER TO DAPL/RB IN              
*                                      PARAMETER LIST                           
         ST    R15,RETCODE             STORE RETURN CODE                        
         LA    R1,RETCODE              LOAD ADDRESS OF RETURN CODE              
         ST    R1,DFRCP                STORE POINTER TO RETURN CODE IN          
*                                      PARAMETER LIST                           
         LA    R1,FULL0                LOAD ADDRESS OF FULLWORD OF              
*                                      ZEROS                                    
         ST    R1,DFJEFF02             STORE DUMMY POINTER TO IKJEFF02          
*                                      IN PARMLIST                              
         LA    R1,DFID                 LOAD ADDRESS OF DAIR FAIL ID             
*                                      FIELD                                    
         ST    R1,DFIDP                STORE POINTER TO DFID IN                 
*                                      PARMLIST                                 
         MVI   DFID,NOWTP              SET FOR NO WRITE TO PROGRAMMER           
         L     R1,SAVEAREA+4           LOAD ADDRESS OF PEVIOUS                  
*                                      SAVEAREA                                 
         L     R1,24(R1)               LOAD POINTER TO CPPL                     
         ST    R1,DFCPPLP              STORE POINTER TO CPPL IN                 
*                                      PARMLIST                                 
         LINK  EP=IKJEFF18,MF=(E,DFPARMS)  LINK TO DAIR FAIL SERVICE            
*                                      ROUTINE TO HANDLE RETURN                 
*                                      CODE                                     
         LTR   R15,R15                 SEE IF RETURN CODE IS ZERO               
         BZR   R2                      YES....GO RETURN TO CALLER               
         LR    R8,R15                  LOAD REGISTER 8 WITH RETURN CODE         
         BAL   R14,SETCODE             GO CONVERT CODE TO DECIMAL               
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(DRFLERR,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT          
*                                      DAIR FAIL ERROR MESSAGE                  
         L     R15,MSGCSECT            GET ADDRESS OF MESSAGE CSECT WFB         
         USING MESSAGES,R15            ESTABLISH ADDRESSABILITY     WFB         
         PUTLINE OUTPUT=(RETNCD,SINGLE,DATA),MF=(E,IOPLSECT)  PUT OUT           
*                                      DECIMAL RETURN CODE                      
         DROP  R15                                                  WFB         
         BR    R2                      GO RETURN TO CALLER                      
*                                                                               
******************** INSTRUCTIONS TO BE EXECUTED **********************         
*                                                                               
FOLDLINE OC    5(0,R9),BLANKS                                      GTEL         
MOVEDSN  MVC   DSNBUF(0),0(R5)                                                  
MOVEVOL  MVC   VOLUME(0),0(R7)                                                  
MOVEUNIT MVC   UNIT(0),0(R7)                                        WFB         
PACKLEN  PACK  DEC(8),0(0,R7)                                      GTEL         
PACKPAG  PACK  DEC(8),0(0,R7)                                      GTEL         
PACKCOPY PACK  DEC(8),0(0,R7)                                                   
ZEROTEST CLC   0(0,R7),ZEROS                                                    
         USING S99TUNIT,R2             ADDRESSABILITY TO S99 TEXT   WFB         
MOVEDDN  MVC   S99TUPAR(0),0(R5)       MOVE DDNAME INTO S99 TEXT    WFB         
         DROP  R2                                                   WFB         
         USING LINDSECT,R15            ADDRESSABILITY TO OUTPUT REC WFB         
MOVEUDK  MVC   RECDATA+3(0),0(R14)     MOVE UDK FONT NAME TO OUTPUT WFB         
         DROP  R15                                                  WFB         
         USING DAPB08,R8                                                        
MOVEMEM  MVC   DA08MNM(0),0(R5)                                                 
MOVEPASS MVC   DA08PSWD(0),0(R5)                                                
         DROP  R8                                                               
DFPBMVE  MVC   DFPBNAME(0),0(R5)                                   GTEL         
*                                                                               
***************************** CONSTANTS *******************************         
*                                                                               
******************** DAIR CONTROL BLOCK CONSTANTS *********************         
DAPB08C  DS    0F                                                               
         DC    X'0008'                 DA08CD                                   
         DC    H'0'                    DA08FLG                                  
         DC    H'0'                    DA08DARC                                 
         DC    H'0'                    DA08CTRC                                 
         DC    A(0)                    DA08PDSN                                 
         DC    CL8'PRINTI  '           DA08DDN                                  
         DC    CL8' '                  DA08UNIT                                 
         DC    CL8' '                  DA08SER                                  
         DC    F'0'                    DA08BLK                                  
         DC    F'0'                    DA08PQTY                                 
         DC    F'0'                    DA08SQTY                                 
         DC    F'0'                    DA08DQTY                                 
         DC    CL8' '                  DA08MNM                                  
         DC    CL8' '                  DA08PSWD                                 
         DC    X'08'                   DA08DSP1      SHR                        
         DC    X'08'                   DA08DSP2      KEEP                       
         DC    X'08'                   DA08DSP3      KEEP                       
         DC    X'08'                   DA08CTL       PERM                       
         DC    F'0'                    DA08DSO                                  
         DC    CL8' '                  DA08ALN                                  
DAPB08L  EQU   *-DAPB08C               LENGTH                                   
         SPACE 2                                                                
DAPB18C  DS    0F                                                               
         DC    X'0018'                 DA18CD                                   
         DC    X'0000'                 DA18FLG                                  
         DC    H'0'                    DA18DARC                                 
         DC    H'0'                    DA18CTRC                                 
         DC    F'0'                    DA18PDSN                                 
         DC    CL8'PRINTI'             DA18DDN                                  
         DC    CL8' '                  DA18MNM                                  
         DC    CL2' '                  DA18SCLS                                 
         DC    X'08'                   DA18DPS2                                 
         DC    X'10'                   DA18CTL                                  
         DC    CL8' '                  DA18JBNM                                 
DAPB18L  EQU   *-DAPB18C               LENGTH                                   
         SPACE 2                                                                
INPUTC   DCB   DSORG=PS,MACRF=(GM),EODAD=EXITI,SYNAD=ERRI,DDNAME=PRINTI         
INPUTL   EQU   *-INPUTC                                                         
*                                                                               
OUTPUTAC DCB   DSORG=PS,MACRF=(PM),SYNAD=ERRO,DDNAME=PRINTA,RECFM=VBA, X        
               LRECL=256,BLKSIZE=3120                                           
OUTPUTAL EQU   *-OUTPUTAC                                                       
*                                                                               
OUTPUTMC DCB   DSORG=PS,MACRF=(PM),SYNAD=ERRO,DDNAME=PRINTM,RECFM=VBM, X        
               LRECL=256,BLKSIZE=3120                                           
OUTPUTML EQU   *-OUTPUTMC                                                       
*                                                                               
DIRECTC  DCB   DDNAME=PRINTI,DSORG=PS,MACRF=(GM),RECFM=U,BLKSIZE=256,  X        
               SYNAD=SERRI,EODAD=FREEBLK                                        
DIRECTL  EQU   *-DIRECTC                                                        
*                                                                               
OPENCLOS OPEN  (,),MF=L                                                         
         SPACE 2                                                                
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
SETPRTL  SETPRT OUTPUTAC,,MF=L                                                  
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
HEADERC  DS    0F                                                               
         DC    H'75'                   (WAS 49 BEFORE DATE)  ARAMCO WFB         
         DC    H'0'                                                             
HDRCNTLC DC    C' '                                                             
         DC    CL34' **** TSO FOREGROUND HARDCOPY ****'      ARAMCO WFB         
         DC    CL36'      HH:MM:SS    MONTHNAME DY, YEAR'           WFB         
HEADERM  DS    0F                                                               
         DC    H'49'                                             ARAMCO         
         DC    H'0'                                                             
         DC    C' '                                                             
         DC    CL44' *** TSO FOREGROUND MEMBER LIST ***'         ARAMCO         
         DS    0H                                                ARAMCO         
LDSNAME  DS    0CL12                                                            
         ORG   LDSNAME                                                          
         DC    H'86'                                             ARAMCO         
         DC    H'0'                                                             
         DC    CL9'  DSNAME='                                    ARAMCO         
VOLCONST DC    CL11'   VOLUME: '       FOR HEADING WHEN VOL(...)    WFB         
DDNCONST DC    CL11'   DDNAME: '       FOR HEADING WHEN DDN(...)    WFB         
EJECTM   DS    0F                                                               
         DC    H'5'                                                             
         DC    H'0'                                                             
         DC    X'8B'                                                            
EJECTA   DS    0F                                                               
         DC    H'5'                                                             
         DC    H'0'                                                             
         DC    C'1'                                                             
SPACE    EQU   EJECTA                                                           
         SPACE 2                                                                
FULL0    DC    F'0'                                                             
FULL1    DC    F'1'                                                             
FULL4    DC    F'4'                                                             
FULL5    DC    F'5'                                                             
FULL20   DC    F'20'                                                            
FULL28   DC    F'28'                                                            
FULL61   DC    F'61'                                               GTEL         
FULL132  DC    F'132'                                              GTEL         
FULL256  DC    F'256'                                                           
PRINTILN DC    H'12',H'0'                                                       
PRINTI   DC    CL8'PRINTI'                                                      
PRINTALN DC    H'12',H'0'                                                       
PRINTA   DC    CL8'PRINTA'                                                      
PRINTMLN DC    H'12',H'0'                                                       
PRINTM   DC    CL8'PRINTM'                                                      
BLANKS   DC    256CL1' '                                                        
ZEROS    DC    4CL1'0'                                                          
ALIAS    DC    CL8' *ALIAS*'                                                    
ENDCHAIN DS    0F                                                               
         DC    X'FF000000'                                                      
MEMDATL  DC    X'00'                   SUBPOOL NUMBER                           
         DC    AL3(1808)                                                        
HALF0    DC    H'0'                                                             
HALF1    DC    H'1'                                                             
HALF2    DC    H'2'                                                             
HALF4    DC    H'4'                                              ARAMCO         
HALF5    DC    H'5'                                                             
HALF6    DC    H'6'                                                             
HALF12   DC    H'12'                                                            
HALF85   DC    H'85'                                                            
HALF256  DC    H'256'                                                           
HALF132  DC    H'132'                                              GTEL         
HALF208  DC    H'208'                                            ARAMCO         
HALF60   DC    H'60'                                             ARAMCO         
HALF120  DC    H'120'                                            ARAMCO         
PATCH    DC    C'PATCH AREA',20S(*)                                 WFB         
MSGCSECT DC    A(MESSAGES)             ADDRESS OF MESSAGE CSECT     WFB         
UDKRESET DC    H'14',H'0',CL10' =UDK={{+X'  DEFINE UDK THEN RESET   WFB         
UDKSET   DC    H'11',H'0',CL7' =UDK={'      DEFINE UDK              WFB         
UDKFHEAD DC    H'0',H'0',CL4' {+2'          SET FONT NAME #2        WFB         
UDKFSEL  DC    H'7',H'0',CL3' {2'           SELECT FONT #2          WFB         
NOMSG    EQU   X'04'                   FLAG IN BYTE VOLBIT          WFB         
UDKDONE  EQU   X'02'                   FLAG IN BYTE VOLBIT          WFB         
FORCEASA EQU   X'04'                   FLAG IN BYTE CCBIT           WFB         
HEXFF    EQU   X'FF'                                                            
HIGH     EQU   X'80'                                                            
LOW      EQU   X'01'                                                            
MID1     EQU   X'10'                                               GTEL         
MID2     EQU   X'08'                                               GTEL         
JFCPDS   EQU   X'01'                                                            
BLANK    EQU   X'40'                                                            
HEX00    EQU   X'00'                                                            
HEXF0    EQU   X'F0'                                                            
HEXF1    EQU   X'F1'                                                            
SCLSA    EQU   C'A'                                                             
SKIPM    EQU   X'09'                                                            
DSOPS    EQU   X'40'                                                            
DSOPO    EQU   X'02'                                                            
NOWTP    EQU   X'00'                                                            
         SPACE 2                                                                
****************** POINTER TO PARS PARAMETER CSECT ********************         
PCLADDR  DC    A(PARMTAB)                                                       
         SPACE 2                                                                
************************ PARS PARAMETER LIST **************************         
PARMTAB  IKJPARM  DSECT=IKJPARMD                                                
DSNAMES  IKJPOSIT  DSTHING,LIST,USID,                                  X        
               PROMPT='DSNAME, (LIST OF DSNAMES), OR * IF DDNAME(...) IX        
               S SPECIFIED',                                        WFBX        
               HELP=('THE NAME OF THE DATASET TO BE PRINTED, OR AN ASTEX        
               RISK IF A PREALLOCATED DDNAME IS TO BE USED.')       WFB         
PCLASS   IKJKEYWD                                                               
         IKJNAME 'CLASS',SUBFLD=CLASSUB                                         
PDEST    IKJKEYWD                                                               
         IKJNAME 'DEST',SUBFLD=DESTSUB                                          
PHOLD    IKJKEYWD                                                               
         IKJNAME 'HOLD'                                                         
         IKJNAME 'NOHOLD'                                                       
PCOPIES  IKJKEYWD                                                               
         IKJNAME 'COPIES',SUBFLD=COPYSUB                                        
PPRINT   IKJKEYWD                                                               
         IKJNAME 'PRINT'                                                        
         IKJNAME 'NOPRINT'                                                      
PLIST    IKJKEYWD                                                               
         IKJNAME 'LIST'                                                         
         IKJNAME 'NOLIST'                                                       
PHEAD    IKJKEYWD                                                               
         IKJNAME 'NOHEADING'                                       GTEL         
         IKJNAME 'HEADING'                                         GTEL         
PVOL     IKJKEYWD                                                               
         IKJNAME 'VOLUME',SUBFLD=VOLSUB                                         
PFOLD    IKJKEYWD                                                               
         IKJNAME 'FOLD',ALIAS=('CAPS')                                          
         IKJNAME 'NOFOLD',ALIAS=('ASIS')                                        
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** START OF GTEL MOD ************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
PSPACE   IKJKEYWD                                                               
         IKJNAME 'SINGLESPACE',ALIAS=('SS','NOCC')                  WFB         
         IKJNAME 'DOUBLESPACE',ALIAS=('DS')                         WFB         
PFORMS   IKJKEYWD                                                               
         IKJNAME  'FORMS',SUBFLD=SFORMS                                         
PTRAIN   IKJKEYWD                                                               
         IKJNAME  'TRAIN',SUBFLD=STRAIN,ALIAS=('UCS')                           
PFCB     IKJKEYWD                                                               
         IKJNAME    'FCB',SUBFLD=SFCB                                           
PPROG    IKJKEYWD                                                               
         IKJNAME    'PROG',SUBFLD=SPROG                                         
PTEXT    IKJKEYWD                                                               
         IKJNAME    'TEXT',INSERT='UCS(TN) ASIS'                                
PLINELEN IKJKEYWD                                                               
         IKJNAME 'LINELENGTH',SUBFLD=SLINELEN,ALIAS=('LL')                      
PPAGELEN IKJKEYWD                                                               
         IKJNAME 'PAGELENGTH',SUBFLD=SPAGELEN,ALIAS=('PL')                      
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** END OF GTEL MOD **************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
PBURST   IKJKEYWD                                                               
         IKJNAME  'BURST'                                                       
         IKJNAME  'NOBURST'                                                     
PFLASH   IKJKEYWD                                                               
         IKJNAME  'FLASH',SUBFLD=SFLASH                                         
PCHARS   IKJKEYWD                                                               
         IKJNAME  'CHARS',SUBFLD=SCHARS                                         
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
PUNIT    IKJKEYWD ,                                                 WFB         
         IKJNAME 'UNIT',SUBFLD=UNITSUB                              WFB         
PNOMSG   IKJKEYWD ,                                                 WFB         
         IKJNAME 'NOMSGS',ALIAS=('NOMESSAGES')                      WFB         
PDDNAME  IKJKEYWD ,                                                 WFB         
         IKJNAME 'DDNAME',ALIAS=('FILE'),SUBFLD=DDNSUB              WFB         
PASA     IKJKEYWD ,                                                 WFB         
         IKJNAME 'ASA'                                              WFB         
PUDKFONT IKJKEYWD ,                                                 WFB         
         IKJNAME 'UDKFONT',SUBFLD=UDKSUB                            WFB         
*                                                                               
*        B E G I N   S U B F I E L D S                                          
CLASSUB  IKJSUBF                                                                
SCLASS   IKJIDENT 'CLASSNAME',LIST,FIRST=NONATNUM,MAXLNTH=1,           X        
               PROMPT='CLASS NAME'                                              
DESTSUB  IKJSUBF                                                                
SDEST    IKJIDENT 'DESTINATION',MAXLNTH=17,                         WFBX        
               FIRST=ALPHANUM,OTHER=ANY,VALIDCK=VALDEST,            WFBX        
               PROMPT='DESTINATION FOR OUTPUT',                     WFBX        
               HELP=('WHERE TO PRINT OUTPUT. DESTINATION CAN BE: REMOTEX        
                LINE NUMBER, JES PRINTER NAME, OR NETWORK NODE AND USERX        
               ID')                                                 WFB         
COPYSUB  IKJSUBF                                                                
SCOPIES  IKJIDENT 'COPIES',MAXLNTH=3,                                  X        
               FIRST=NUMERIC,OTHER=NUMERIC,                            X        
               PROMPT='1-3 DIGITS - NUMBER OF COPIES OF OUTPUT',       X        
               HELP=('NUMBER OF COPIES OF PRINTOUT DESIRED')                    
VOLSUB   IKJSUBF                                                                
SVOL     IKJIDENT 'VOLUME',MAXLNTH=8,                                  X        
               FIRST=ALPHANUM,OTHER=ALPHANUM,                          X        
               PROMPT='VOLUME SERIAL FOR DATA SETS TO BE PRINTED',     X        
               HELP=('VOLUME SERIAL TO BE USED FOR ALL DATA SETS')              
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** START OF GTEL MOD ************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
SFORMS   IKJSUBF                                                                
RFORMS   IKJIDENT 'FORMS',MAXLNTH=4,FIRST=ALPHANUM,                    X        
               OTHER=ALPHANUM,                                         X        
               DEFAULT='$TST',                                      WFBX        
               HELP=('AN ALPANUMERIC STRING TO SPECIFY THE FORM')               
STRAIN   IKJSUBF                                                                
RTRAIN   IKJIDENT   'UCS',MAXLNTH=4,FIRST=ALPHANUM,                    X        
               OTHER=ALPHANUM,                                         X        
               PROMPT='UCS   DESIGNATION FOR PRINTED OUTPUT',          X        
               HELP=('AN ALPANUMERIC STRING TO SPECIFY THE TRAIN')              
SFCB     IKJSUBF                                                                
RFCB     IKJIDENT 'FCB',MAXLNTH=4,FIRST=ALPHANUM,                      X        
               OTHER=ALPHANUM,                                         X        
               PROMPT='FCB DESIGNATION FOR PRINTED OUTPUT',            X        
               HELP=('AN ALPANUMERIC STRING TO SPECIFY THE FCB')                
SPROG    IKJSUBF                                                                
RPROG    IKJIDENT 'PROG',MAXLNTH=8,FIRST=ALPHA,                        X        
               OTHER=ALPHANUM,                                         X        
               PROMPT='PROG DESIGNATION FOR PRINTED OUTPUT',           X        
               HELP=('AN ALPANUMERIC STRING TO SPECIFY THE PROG')               
SLINELEN IKJSUBF                                                                
RLINELEN IKJIDENT 'LINELENGTH',MAXLNTH=3,FIRST=NUMERIC,                X        
               OTHER=NUMERIC,                                          X        
               PROMPT='LINESIZE, DEFAULT=132',                         X        
               HELP=('A LENGTH UP TO 208 FOR MAXIMUM PRINT WIDTH')              
SPAGELEN IKJSUBF                                                                
RPAGELEN IKJIDENT 'PAGELENGTH',MAXLNTH=3,FIRST=NUMERIC,                X        
               OTHER=NUMERIC,                                          X        
               PROMPT='PAGELENGTH, DEFAULT=60',                        X        
               HELP=('A LENGTH UP TO 120 FOR PRINTER PAGE LENGTH')              
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
**************************** END OF GTEL MOD **************************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
SFLASH   IKJSUBF                                                                
RFLASH   IKJIDENT 'FLASH',MAXLNTH=4,FIRST=ALPHANUM,                    X        
               OTHER=ALPHANUM,                                         X        
               PROMPT='FLASH DESIGNATION FOR PRINTED OUTPUT',          X        
               HELP=('FORMS OVERLAY FLASH NAME -- VALID FOR 3800 ONLY')         
SCHARS   IKJSUBF                                                                
RCHARS   IKJIDENT 'CHARS',LIST,MAXLNTH=4,FIRST=ALPHA,                  X        
               OTHER=ANY,                                              X        
               PROMPT='CHARS DESIGNATION FOR PRINTED OUTPUT',          X        
               HELP=('A LIST OF 1 TO 4 CHARACTER SET NAMES -- VALID FORX        
                3800 ONLY')                                                     
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
UNITSUB  IKJSUBF ,                                                  WFB         
SUNIT    IKJIDENT 'UNIT',MAXLNTH=8,                                 WFBX        
               FIRST=ALPHANUM,OTHER=ALPHANUM,                       WFBX        
               PROMPT='UNIT TYPE OF SPECIFIED VOLUME',              WFBX        
               HELP=('UNIT TYPE WHICH IS REQUIRED IF THE SPECIFIED VOLUX        
               ME IS NOT ACCESSIBLE THROUGH YOUR DEFAULT TSO UNIT VALUEX        
               ')                                                   WFB         
DDNSUB   IKJSUBF ,                                                  WFB         
SDDNAME  IKJIDENT 'DDNAME',MAXLNTH=8,                               WFBX        
               FIRST=ALPHA,OTHER=ALPHANUM,                          WFBX        
               PROMPT='DD NAME OF PREVIOUSLY ALLOCATED DATASET',    WFBX        
               HELP=('A FILE THAT WAS ALLOCATED EARLIER IN YOUR TSO SESX        
               SION','DDNAME IS IGNORED IF THE LAST OR ONLY DSNAME IS NX        
               OT AN ASTERISK')                                     WFB         
UDKSUB   IKJSUBF ,                                                  WFB         
SUDKFONT IKJIDENT 'UDK FONT NAME',ASIS,MAXLNTH=20,                  WFBX        
               FIRST=ALPHANUM,OTHER=ANY,                            WFBX        
               PROMPT='UDK FONT NAME',                              WFBX        
               HELP=('A FONT NAME FOR PRINTING ON A XEROX 2700 OR 3700'X        
               ,'THE NAME MUST BE ENTERED EXACTLY IN UPPER/LOWER CASE AX        
               S THE PRINTER EXPECTS IT')                           WFB         
         IKJENDP                                                                
         SPACE 2                                                                
MESSAGES CSECT ,                                                    WFB         
****************************** MESSAGES *******************************         
GNRLERR  DC    AL2(GNRLERRL),AL2(0)                                             
         DC    C'AN ERROR WAS ENCOUNTERED IN THE GENERAL FAIL SERVICE RX        
               OUTINE.  THE RETURN CODE FROM GNRLFAIL IS: '                     
GNRLERRL EQU   *-GNRLERR                                                        
*                                                                               
DRFLERR  DC    AL2(DRFLERRL),AL2(0)                                             
         DC    C'AN ERROR WAS ENCOUNTERED IN THE DAIR FAIL SERVICE ROUTX        
               INE.  THE RETURN CODE FROM DAIR FAIL IS: '                       
DRFLERRL EQU   *-DRFLERR                                                        
*                                                                               
OPENMSG  DC    AL2(OPENMSGL),AL2(0)                                             
         DC    C'OUPUT PROCESSING IS BEING TERMINATED.  AN ERROR WAS ENX        
               COUNTERED ATTEMPTING TO OPEN THE OUTPUT DATASET ASSOCIATX        
               ED WITH DDNAME: '                                                
OPENMSGL EQU   *-OPENMSG                                                        
*                                                                               
DSNNOTP  DC    AL2(DSNNOTPL),AL2(0)                                             
         DC    C'AN ERROR OCCURRED AND YOUR DATASET WAS NOT PRINTED'            
DSNNOTPL EQU   *-DSNNOTP                                                        
*                                                                               
DSNMSG   DC    AL2(DSNMSGL),AL2(0)                                              
         DC    C'PROCESSING HAS BEEN COMPLETED FOR DATASET: '                   
DSNMSGL  EQU   *-DSNMSG                                                         
*                                                                               
MEMMSG   DC    AL2(MEMMSGL),AL2(0)                                              
         DC    C' MEMBER: '                                                     
MEMMSGL  EQU   *-MEMMSG                                                         
*                                                                               
PRTMSG   DC    AL2(PRTMSGL),AL2(0)                                              
         DC    C'MEMBERS WILL NOW BE PRINTED FOR DATASET: '                     
PRTMSGL  EQU   *-PRTMSG                                                         
*                                                                               
NOTPSPO  DC    AL2(NOTPSPOL),AL2(0)                                             
         DC    C'DATASET IS NOT SEQUENTIAL OR PARTITIONED AND WAS NOT PX        
               RINTED.'                                                         
NOTPSPOL EQU   *-NOTPSPO                                                        
*                                                                               
SYNADI   DC    AL2(SYNADIL),AL2(0)                                              
         DC    C'A SYNAD ERROR OCURRED READING YOU INPUT DATASET AND ONX        
               LY PART OF YOUR DATASET MAY HAVE BEEN PRINTED.'                  
SYNADIL  EQU   *-SYNADI                                                         
*                                                                               
SYNADO   DC    AL2(SYNADOL),AL2(0)                                              
         DC    C'A SYNAD ERROR OCURRED WRITING THE OUTPUT DATASET AND NX        
               O MORE DATASETS WILL BE PRINTED.'                                
SYNADOL  EQU   *-SYNADO                                                         
*                                                                               
*DSNISU  DC    AL2(DSNISUL),AL2(0)                                              
*        DC    C'DATASET HAS UNDEFINED RECORD LENGTH AND WILL NOT BE PRX        
               INTED.'                                                          
*DSNISUL EQU   *-DSNISU                                                         
*                                                                               
*DSNISL  DC    AL2(DSNISLL),AL2(0)                                              
*        DC    C'DATASET HAS RECORD LENGTH GREATER THAN 256.'                   
*DSNISLL EQU   *-DSNISL                                                         
*                                                                ARAMCO         
CHARMSG  DC    AL2(CHARMSGL),AL2(0)                              ARAMCO         
         DC    C'MAX OF 4 CHAR SETS ALLOWED, REMAINDER IGNORED'  ARAMCO         
CHARMSGL EQU   *-CHARMSG                                         ARAMCO         
*                                                                   WFB         
NODSNDD  DC    AL2(NODSNDDL),AL2(0)                                 WFB         
         DC    C'NO INPUT SPECIFIED: AN ASTERISK DSNAME IMPLIES A DDNAMX        
               E WILL BE USED FOR INPUT, BUT NO DDNAME WAS GIVEN.'  WFB         
NODSNDDL EQU   *-NODSNDD                                            WFB         
NOTLAST  DC    AL2(NOTLASTL),AL2(0)                                 WFB         
         DC    C'AN ASTERISK DSNAME MUST BE THE LAST OR ONLY DSNAME SPEX        
               CIFIED FOR DDNAME TO BE PROCESSED.'                  WFB         
NOTLASTL EQU   *-NOTLAST                                            WFB         
         SPACE 2                                                                
************************ DSECTS (MAPPING MACROS) **********************         
MEMDSECT DSECT                                                                  
MEMNTTR  DS    CL11                                                             
         ORG   MEMNTTR                                                          
MEMBER   DS    CL8                                                              
MEMTTR   DS    CL3                                                              
CFIELD   DS    CL1                                                              
MEMSECTN EQU   *                                                                
         IKJDAP08                                                               
DAP08LEN EQU   *-DAPB08                                                         
         IKJDAP18                                                               
DAP18LEN EQU   *-DAPB18                                                         
         IKJDAPL                                                                
DAPLLEN  EQU   *-DAPL                                                           
         IKJCPPL                                                                
CPPLLEN  EQU   *-CPPL                                                           
         IKJPPL                                                                 
PPLLEN   EQU   *-PPL                                                            
         IKJIOPL                                                                
IOPLLEN  EQU   *-IOPL                                                           
         IHADSAB                                                                
TIOEDDNM EQU   4           X'1C'(OFFSET) - X'18'(JOB STEP)                      
         CVT   DSECT=YES                                            WFB         
         IEFZB4D0                                                               
         IEFZB4D2                                                               
         IKJDFPL                                                   GTEL         
         IKJDFPB                                                   GTEL         
         IKJUPT                                                  ARAMCO         
RBLEN    EQU   S99RBEND-S99RB                                                   
         PRINT NOGEN                                                            
         DCBD  DSORG=(PS,PO)                                                    
         PRINT GEN                                                              
         EJECT                                                                  
*                                                                               
* DALUSRID IS ABSENT FROM THE MVS3.8 VERSION OF IEFZG4D2 MACRO SO   JLM         
* I HAVE INCLUDED THE FOLLOWING EQUATE FROM A MORE RECENT SYSTEM    JLM         
* ALLOW ASSEMBLY WITHOUT ERRORS                                     JLM         
DALUSRID EQU   X'0063'                                              JLM         
******************** CONSTANTS FOR DYNAMIC ALLOCATION *****************         
PRINTOFF CSECT                                                                  
REQBLKC  DC    AL1(S99RBEND-S99RB),AL1(S99VRBAL),18AL1(0)                       
TEXTAC   DC    AL2(DALDDNAM),AL2(1),AL2(8),CL8'PRINT'  DDNAME                   
TEXTALEN EQU   *-TEXTAC                                                         
TEXTBC   DC    AL2(DALSYSOU),AL2(1),AL2(1),C'A'        SYSOUT CLASS             
TEXTBLEN EQU   *-TEXTBC                                                         
TEXTCC   DC    AL2(DALSUSER),AL2(1),AL2(8),CL8'LOCAL'  DESTINATION              
TEXTCLEN EQU   *-TEXTCC                                                         
TEXTDC   DC    AL2(DALSHOLD),AL2(0)                    SYSOUT HOLD              
TEXTDLEN EQU   *-TEXTDC                                                         
TEXTEC   DC    AL2(DALCOPYS),AL2(1),AL2(1),AL2(1)      SYSOUT COPIES            
TEXTELEN EQU   *-TEXTEC                                                         
TEXTFC   DC    AL2(DALPERMA),AL2(0)              PERM ALLOCATION                
TEXTFLEN EQU   *-TEXTFC                                                         
TEXTGC   DC    AL2(DALFCBIM),AL2(1),AL2(4),CL4'STD.'  FCB          GTEL         
TEXTGLEN EQU   *-TEXTGC                                        GTEL WFB         
TEXTHC   DC    AL2(DALUCS),AL2(1),AL2(2),CL4'PN'      UCS          GTEL         
TEXTHLEN EQU   *-TEXTHC                                        GTEL WFB         
TEXTIC   DC    AL2(DALSFMNO),AL2(1),AL2(2),CL4'STD.'  FORMS        GTEL         
TEXTILEN EQU   *-TEXTIC                                        GTEL WFB         
TEXTJC   DC    AL2(DALSPGNM),AL2(1),AL2(8),CL8'PROG'  PROG         GTEL         
TEXTJLEN EQU   *-TEXTJC                                        GTEL WFB         
TEXTKC   DC    AL2(DALUSRID),AL2(1),AL2(8),CL8'USER'  USERID        WFB         
TEXTKLEN EQU   *-TEXTKC                                             WFB         
TEXTLC   DC    AL2(DINDDNAM),AL2(1),AL2(8),CL8' '   PREALLOC DDNAME WFB         
TEXTLLEN EQU   *-TEXTLC                                             WFB         
TEXTMC   DC    AL2(DINRTDSN),AL2(1),AL2(44),CL44' ' RETURNED DSNAME WFB         
TEXTMLEN EQU   *-TEXTMC                                             WFB         
TEXTNC   DC    AL2(DINRTMEM),AL2(1),AL2(8),CL8' '   RETURNED MEMBER WFB         
TEXTNLEN EQU   *-TEXTNC                                             WFB         
TEXTOC   DC    AL2(DINRTORG),AL2(1),AL2(2),XL2'0000' RETURNED DSORG WFB         
TEXTOLEN EQU   *-TEXTOC                                             WFB         
*                                                                   WFB         
**       VALIDITY CHECK ROUTINE FOR DESTINATION                     WFB         
***                                                                 WFB         
****     MAXIMUM LENGTH IS 17 CHARACTERS (ENFORCED BY PARSE)        WFB         
*****    DEST(NODE.USERID) MUST HAVE 1 PERIOD, EACH NAME 1-8 CHARS  WFB         
******   DEST(NAME) IF NO PERIOD, MAXIMUM LENGTH IS 8 CHARACTERS    WFB         
******                                                              WFB         
*****    AT ENTRY, REG 1 POINTS TO A THREE WORD LIST:               WFB         
****     +0  A(SDEST)   ADDRESS OF THE PDE BUILT BY PARSE           WFB         
***      +4  A(WORKAREA) ADDRESS OF USER WORK AREA FROM IKJPPL      WFB         
**       +8  A(VALMSG)  =F'0', ADDRESS OF USER SUPPLIED 2ND LVL MSG WFB         
*                                                                   WFB         
VALDEST  CSECT ,                                                    WFB         
         PUSH  USING                                                WFB         
         STM   R14,R12,12(13)          SAVE PARSE REGISTERS         WFB         
         LR    R12,R15                 USE REG 12 AS BASE           WFB         
         USING VALDEST,R12             ESTABLISH ADDRESSABILITY     WFB         
         LM    R8,R10,0(R1)            LOAD INPUT LIST VALUES       WFB         
         SR    R15,R15                 ASSUME ZERO RETURN CODE      WFB         
         STH   R15,NODELEN-WORKAREA(,R9)  ASSUME NOT NODE.USERID    WFB         
         L     R1,0(,R8)               GET ADDRESS OF DEST          WFB         
         LH    R3,4(,R8)               GET TOTAL LENGTH OF DEST     WFB         
         BCTR  R3,0                    DECREMENT LENGTH FOR TRT     WFB         
         EX    R3,VALTRT               LOOK FOR PERIOD OR INVALID   WFB         
         BZ    VALNODOT           CC=0 NOTHING FOUND, GO CHECK LEN  WFB         
         BM    VALCHECK           CC=1 FOUND IN MIDDLE, GO CHECK    WFB         
         B     VALRET4            CC=2 FOUND IN LAST BYTE - INVALID WFB         
VALNODOT CLI   5(R8),X'08'             NO PERIOD, LEN MUST BE 1-8   WFB         
         BNH   VALRETRN                YES, OK                      WFB         
         B     VALRET4                 NO, INVALID LENGTH           WFB         
VALCHECK CLI   0(R1),C'.'              PERIOD FOUND ?               WFB         
         BNE   VALRET4                 NO, INVALID CHARACTER        WFB         
         LA    R4,0(,R1)               GET ADDRESS OF PERIOD        WFB         
         SL    R4,0(,R8)               MINUS BEGIN DEST = LEN NODE  WFB         
         LA    R1,1(,R1)               POINT PAST PERIOD            WFB         
         SLR   R3,R4                   GET REMAINING LEN OF '.USER' WFB         
         BCTR  R3,0                    DECREMENT FOR PERIOD         WFB         
         EX    R3,VALTRT               LOOK FOR MORE PERIOD/INVALID WFB         
         BNZ   VALRET4                 FOUND, INVALID SPECIFICATION WFB         
         STH   R4,NODELEN-WORKAREA(,R9)  SAVE NODE LEN IN WORKAREA  WFB         
         B     VALRETRN                DONE                         WFB         
VALRET4  LA    R15,4                   SET RC 4 - INVALID DEST      WFB         
VALRETRN LM    R0,R12,20(R13)          RESTORE PARSE REGISTERS      WFB         
         L     R14,12(,R13)            RESTORE RETURN ADDRESS       WFB         
         BR    R14                     RETURN TO PARSE              WFB         
*                                                                   WFB         
VALTRT   TRT   0(0,R1),VALTABLE        ** EXECUTED **               WFB         
VALTABLE DC    256AL1(*-VALTABLE)      TABLE OF VALID CHARACTERS    WFB         
         ORG   VALTABLE+C'$'                                        WFB         
         DC    X'00'                   ALLOW $                      WFB         
         ORG   VALTABLE+C'#'                                        WFB         
         DC    2X'00'                  ALLOW # @                    WFB         
         ORG   VALTABLE+C'A'                                        WFB         
         DC    9X'00'                  ALLOW A B C D E F G H I      WFB         
         ORG   VALTABLE+C'J'                                        WFB         
         DC    9X'00'                  ALLOW J K L M N O P Q R      WFB         
         ORG   VALTABLE+C'S'                                        WFB         
         DC    8X'00'                  ALLOW S T U V W X Y Z        WFB         
         ORG   VALTABLE+C'0'                                        WFB         
         DC    10X'00'                 ALLOW 0 1 2 3 4 5 6 7 8 9    WFB         
         ORG   ,                                                    WFB         
         DROP  R12                                                  WFB         
         POP   USING                                                WFB         
*********************** DSECT FOR DYNAMIC WORKAREA ********************         
WORKAREA DSECT                                                                  
SAVEAREA DS    18F                                                              
ALCSAVE  DS    12F                                                              
         DS    0D                                                               
DEC      DS    2F                                                               
RETNCD   DS    F                                                                
CONV     DS    2F                                                               
IOPB     PUTLINE MF=L                                                           
DAP08    DS    0F                                                               
         ORG   DAP08+DAP08LEN                                                   
DAP18    DS    0F                                                               
         ORG   DAP18+DAP18LEN                                                   
DAPLSECT DS    0F                                                               
         ORG   DAPLSECT+DAPLLEN                                                 
PPLSECT  DS    0F                                                               
         ORG   PPLSECT+PPLLEN                                                   
IOPLSECT DS    0F                                                               
         ORG   IOPLSECT+IOPLLEN                                                 
DFPLSECT DS    4F                   SPACE FOR DFPL                 GTEL         
DFPBSECT DS    5F                   SPACE FOR DFPB                 GTEL         
         DS    H                    TO GET ALLIGNMENT              GTEL         
DFPBDSL  DS    H                    DSNAME LENGTH                  GTEL         
DFPBNAME DS    CL44                 DSNAME                         GTEL         
DFPBQUA  DS    CL8                                                              
ECB      DS    F                                                                
PARSBACK DS    F                                                                
LINE     DS    0H                                                               
LENGTH   DS    H                                                                
         DS    H                                                                
CNTLBYTE DS    CL1                                                              
DATA     DS    CL256                                                            
HEADER2  DS    CL13                                              ARAMCO         
DSNAME   DS    CL44                                                             
OPENPRN  DS    CL1                                                              
MEMNAME  DS    CL8                                                              
CLOSEPRN DS    CL1                                                              
VOLHEAD  DS    CL11                 C'   VOLUME: ' ON HEADING       WFB         
VOLNAME  DS    CL8                                                  WFB         
         ORG   DSNAME-4                                                         
DSNLENP  DS    CL2                                                              
DSNLEN   DS    CL2                                                              
DSNBUF   DS    CL44                                                             
         ORG   MEMNAME-4                                                        
MEMNAMEL DS    CL2                                                              
         ORG                                                                    
HEADER   DS    CL75                 (WAS 49 BEFORE DATE)     ARAMCO WFB         
         ORG   HEADER+4                                                         
HDRCNTL  DS    CL1                                                              
         ORG   HEADER+41                                            WFB         
HDRTIME  DS    CL12                 4 BYTE PREFIX, HH:MM:SS         WFB         
HDRDATE  DS    CL22                 4 BYTE PREFIX, MONTHNAME DY, YR WFB         
HDRTDLEN EQU   *-HDRTIME                                            WFB         
DFID     DS    CL2                                                              
         ORG                                                                    
VOLBIT   DS    CL1                                                              
VOLUME   DS    CL8                                                              
UNIT     DS    CL8                  UNIT() VALID ONLY WITH VOL()    WFB         
PREALDDN DS    CL8                  PREALLOCATED DDNAME(...)        WFB         
NODELEN  DS    H                    LEN OF NODE IN DEST(NODE.USER)  WFB         
CALLMFL  CALL  ,(,),MF=L            LIST FORM FOR CALL IKJEFLPA     WFB         
MEMTABLE DS    F                                                                
ENDTABLE DS    F                                                                
CURRENT  DS    F                                                                
PRESENT  DS    F                                                                
COLUMN   DS    F                                                                
XLIST    DS    F                                                                
LINELEN  DS    H                                                   GTEL         
VBLEN    DS    H                                                   GTEL         
PAGELEN  DS    H                                                   GTEL         
CCBIT    DS    CL1                                                 GTEL         
ALNDSECT DS    F                                                   GTEL         
RDJL     RDJFCB (,),MF=L                                                        
JFCBAREA DS    44F                                                              
         ORG   JFCBAREA+44                                                      
JFCBELNM DS    CL8                                                              
         ORG   JFCBAREA+86                                                      
JFCBIND1 DS    CL1                                                              
         ORG   JFCBAREA+98                                                      
JFCDSRG1 DS    CL1                                                              
         ORG                                                                    
SAVER6   DS    F                                                                
SAVER2   DS    2F                                                               
SAVER3   DS    2F                                                               
SAVMR2   DS    2F                                                  GTEL         
SAVMR6   DS    2F                                                  GTEL         
SAVMR9   DS    2F                                                  GTEL         
*                                                                               
         PRINT NOGEN                                                            
*                                                                               
INPUT    DCB   DSORG=PS,MACRF=(GM),EODAD=EXITI,SYNAD=ERRI,DDNAME=PRINTI         
*                                                                               
OUTPUTA  DCB   DSORG=PS,MACRF=(PM),SYNAD=ERRO,DDNAME=PRINTA,RECFM=VBA, X        
               LRECL=256,BLKSIZE=3120                                           
*                                                                               
OUTPUTM  DCB   DSORG=PS,MACRF=(PM),SYNAD=ERRO,DDNAME=PRINTM,RECFM=VBM, X        
               LRECL=256,BLKSIZE=3120                                           
*                                                                               
DIRECT   DCB   DDNAME=PRINTI,DSORG=PS,MACRF=(GM),RECFM=U,BLKSIZE=256,  X        
               SYNAD=SERRI,EODAD=FREEBLK                                        
*                                                                               
OPENLST  OPEN  (,),MF=L                                                         
*                                                                               
CLOSLST  CLOSE (,),MF=L                                                         
*                                                                               
*                                                                               
         PRINT GEN                                                              
*                                                                               
RETCODE  DS    F                                                                
GFPARMP  DS    F                                                                
         IKJEFFGF                                                               
         IKJEFFDF                                                               
RBPTR    DS    F                                                                
REQBLK   DS    10F                                                 GTEL         
TEXTPTRS DS    16F                                             GTEL WFB         
TEXTA    DS    0F                                   DDNAME                      
         ORG   TEXTA+TEXTALEN                                                   
TEXTB    DS    0F                                   SYSOUT CLASS                
         ORG   TEXTB+TEXTBLEN                                                   
TEXTC    DS    0F                                   DESTINATION                 
         ORG   TEXTC+TEXTCLEN                                                   
TEXTE    DS    0F                                   SYSOUT COPIES               
         ORG   TEXTE+TEXTELEN                                                   
TEXTG    DS    0F                                   FCB            GTEL         
         ORG   TEXTG+TEXTGLEN                                      GTEL         
TEXTH    DS    0F                                   UCB            GTEL         
         ORG   TEXTH+TEXTHLEN                                      GTEL         
TEXTI    DS    0F                                   FORMS          GTEL         
         ORG   TEXTI+TEXTILEN                                      GTEL         
TEXTJ    DS    0F                                   PROG           GTEL         
         ORG   TEXTJ+TEXTJLEN                                      GTEL         
TEXTK    DS    0F                                   USERID          WFB         
         ORG   TEXTK+TEXTKLEN                                       WFB         
TEXTL    DS    0F                                   PREALLOC DDNAME WFB         
         ORG   TEXTL+TEXTLLEN                                       WFB         
TEXTM    DS    0F                                   RETURNED DSNAME WFB         
         ORG   TEXTM+TEXTMLEN                                       WFB         
TEXTN    DS    0F                                   RETURNED MEMBER WFB         
         ORG   TEXTN+TEXTNLEN                                       WFB         
TEXTO    DS    0F                                   RETURNED DSORG  WFB         
         ORG   TEXTO+TEXTOLEN                                       WFB         
*---------------------------------------------------------------------*         
*------------------------- START OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
SETFLAG  DS    X                                                                
SETBURST EQU   1                                                                
SETFLSH  EQU   2                                                                
SETCHAR  EQU   4                                                                
SETPRTE  SETPRT OUTPUTA,,MF=L                                                   
SETFLASH EQU   SETPRTE+28                                                       
SETCHARS EQU   SETPRTE+32                                                       
SETPRTEL EQU   *-SETPRTE                                                        
SAVEUPT  DS    X                                                                
*---------------------------------------------------------------------*         
*--------------------------- END OF ARAMCO MOD -----------------------*         
*---------------------------------------------------------------------*         
LDYNAMIC EQU   *-WORKAREA                                                       
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
*********************** DSECT FOR RECORD MAPPING **********************         
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
LINDSECT DSECT                                                                  
RECORD   DS    0F                                                               
RECLEN   DS    H                                                                
         DS    H                                                                
RECCC    DS    CL1                                                              
RECDATA  DS    CL32760                                              WFB         
RECSIZE  EQU   *-RECORD                                             WFB         
*********************** END OF RECORD MAPPING DSECT *******************         
         END                                                                    
//SYSGO    DD  DSN=&&OBJECT,DISP=(,PASS),                               00160000
//             UNIT=SYSDA,SPACE=(TRK,(50,10))                           00170000
//*                                                                     00180000
//LKED    EXEC LKED,PARM.LKED='LET,LIST,XREF,RENT,REUS',                00190000
//             COND.LKED=(8,LT)                                         00200000
//SYSPRINT DD  SYSOUT=*                                                 00210000
//SYSLIN   DD  DSN=&&OBJECT,DISP=(OLD,DELETE)                           00220000
//         DD  *                                                        00230000
  ALIAS PRINTO                                                          00240000
  ALIAS PO                                                              00250000
  NAME PRINTOFF(R)                                                      00260000
//SYSLMOD  DD  DSN=SYS2.CMDLIB,DISP=SHR                                 00270000
//SYSLIB   DD  DSN=SYS1.AOST4,DISP=SHR                                  00280000
//*                                                                     00290000
//IEBGENER EXEC PGM=IEBGENER,REGION=1024K                               00300000
//SYSPRINT DD  SYSOUT=*                                                 00310000
//SYSIN    DD  *                                                        00320000
  GENERATE MAXNAME=3                                                    00330000
  MEMBER NAME=(PRINTOFF,PRINTO,PO)                                      00340000
//SYSUT2   DD  DSN=SYS2.HELP,DISP=SHR                                   00350000
//SYSUT1   DD  *                                                        00360000
)F Function -                                                                   
   The PRINTOFF command creates a printed copy of data sets through             
   foreground copying to SYSOUT.  The command prints datasets which             
   are sequential or partitioned, blocked or unblocked, with fixed,             
   variable, or undefined length records of any length up to 32,760.            
)X Syntax -                                                                     
   PRINTOFF (dslist)/*  DDNAME(ddname)/FILE(ddname)                             
            UNIT(unit-type)  VOLUME(volser)     NOMESSAGES/NOMSGS               
            CLASS(class)     DEST(destination)  COPIES(nnn)                     
            HOLD/NOHOLD      LIST/NOLIST        PRINT/NOPRINT                   
            FORMS(form)      FCB(fcb)           TRAIN(image)/UCS(image)         
            HEADING/NOHEADING                   CAPS/ASIS/FOLD/NOFOLD           
            NOCC/SINGLESPACE/SS/DOUBLESPACE/DS  ASA                             
            LINELENGTH(nnn)/LL(nnn)             PAGELENGTH(nnn)/PL(nnn)         
            BURST/NOBURST    FLASH(flash-name)  CHARS(charset-name(s))          
            PROG(progname)   UDKFONT(font-name)                                 
   Required -- dslist or * if DDNAME(...)                                       
   Aliases  -- PRINTO, PO                                                       
   Defaults -- CLASS(A), COPIES(1), NOHOLD, LIST, PRINT, FORM($TST),            
               HEADING, ASIS, LINELENGTH(132), PAGELENGTH(60), NOBURST,         
               SINGLESPACE if PAGELENGTH(...) or if input RECFM not A/M         
)O Operands -                                                                   
)P DSLIST - Data set list contains the names of data sets to be printed         
            or punched.  The names should follow TSO convention, in             
            quotes if the primary index differs from your profile               
            prefix, or without quotes and with the primary index                
            omitted if it is the same as your profile prefix.                   
            Enclosing parenthesis are required if there is more than            
            one name in the list.                                               
              If DDNAME(...) is specified, the dslist must end with an          
            asterisk (or contain only an asterisk) as a place holder.           
))ASA     - Output is to be printed using input data column 1 as ASA            
            carriage control characters even though the DCB record              
            format does not specify RECFM=..A                                   
))ASIS    - Output is not to be converted to upper case prior to                
            printing. (It is left as it is.)                                    
            NOFOLD is an alias for ASIS.                                        
))BURST   - Output is to be trimmed and burst. ===> VALID FOR 3800 ONLY         
))NOBURST - Output will be printed on continuous forms.                         
))CAPS    - Output is to be converted to upper case prior to                    
            printing. FOLD is an alias for CAPS.                                
))CHARS(charset-name(s)) - Character set(s) to be used to print the             
            output. (1-4 names, each name 1-4 characters.)  If more             
            than one character set name is given, the input data should         
            have the character set id specified in the second character         
            of each line. OPTCD=J is assumed. See the JCL reference             
            manual for more information. ===> VALID FOR 3800 ONLY               
))CLASS(class) - SYSOUT class in which output is to be printed.                 
            Default is A.                                                       
))COPIES(nnn) - Number of copies to be printed.  Default is 1.                  
))DEST(destination) - The destination to where SYSOUT is to be routed.          
            Destination can be a JES remote line, a JES local or remote         
            printer, or a network node and userid. Local and remote             
            names are 1-8 characters. Network names are 3-17 characters         
            (node.userid) with the period required as a separator.              
            DEST(node.userid) is mutually exclusive with                        
            PROG(progname).                                                     
))DDNAME(ddname) - DD name of a previously allocated dataset. If DDNAME         
            is specified, the last (or only) dataset name in dslist             
            must be an asterisk. The DD will not be freed after being           
            printed. FILE is an alias for DDNAME.                               
))FCB(fcb) - Forms Control Buffer to be used when the data set is               
            printed.  (1-4 character FCB name)                                  
))FLASH(flashname) - The name of the forms flash overlay which is to be         
            flashed on all output. ===> VALID FOR 3800 ONLY                     
))FORMS(form) - Form to be used when the data set is printed.                   
            Default is $TST. (1-4 character form name)                          
))HEADING - Output is to have a heading containing the data set name.           
))NOHEADING - Output is not to have heading information.                        
))HOLD    - Output is to be placed on a hold queue upon deallocation.           
))NOHOLD  - Output is not to be placed on a hold queue upon                     
            deallocation.                                                       
))LINELENGTH(nnn) - Number of characters on each line of printed                
            output. (1-208 characters with a default of 132.)  Input            
            lines longer than specified linelength will be printed on           
            multiple lines.  LL(...) is an alias for LINELENGTH(...).           
))LIST    - A separate listing of member names processed is to be               
            created and printed with the data set output.                       
))NOLIST  - No list of member names is to be created.                           
))NOMESSAGES - Non-error messages are not to be written to the TSO              
            terminal. NOMSGS is an alias of NOMESSAGES. The default is          
            to write informational messages to the terminal before and          
            after printing.                                                     
))PAGELENGTH(nnn) - Number of lines per page.  (1-120 lines with a              
            default of 60.)  Carriage control in input records is               
            ignored (even if ASA is specified) and SINGLESPACE is used.         
            PL(...) is an alias for PAGELENGTH(...).                            
))PRINT   - Members are to be printed. (Whether they are also listed            
            is controlled by LIST/NOLIST.)                                      
))NOPRINT - Members are not to be printed. (Whether they are to be              
            listed is controlled by LIST/NOLIST.)                               
))PROG(progname) - The name of the special 'external writer' program            
            that is to process the output. PROG(progname) is mutually           
            exclusive with DEST(node.userid).                                   
))TRAIN(image) - Print image to be used when the data set is printed.           
            UCS is an alias for TRAIN. (1-4 character print image name)         
))UCS(image) - Print image to be used when the data set is printed.             
            UCS is an alias for TRAIN. (1-4 character print image name)         
))SINGLESPACE - Output is to be single spaced.  Carriage control in             
            input data is ignored even if ASA is specified.                     
            NOCC and SS are aliases for SINGLESPACE.                            
))DOUBLESPACE - Output is to be double spaced between lines.  Carriage          
            control in input data is ignored even if ASA is specified.          
            DS is an alias for DOUBLESPACE.  (Multiple line records             
            will not be split between pages.)                                   
))UNIT(unit-type) - Unit type of the specified VOLUME(volser). UNIT is          
            ignored if VOLUME is not also specified. UNIT is required           
            only when the dataset is not cataloged, or when the dataset         
            is cataloged to a different volume than the specified               
            VOLUME and the volume cannot be accessed through your TSO           
            default unit type.                                                  
))VOLUME(volser) - Volume serial of volume on which data sets to be             
            printed are found.  This volume serial will be used for all         
            data sets specified in the data set list.                           
))UDKFONT(font-name) - Output is intended to be printed on a XEROX 2700         
            or 3700.  PRINTOFF will insert Xerox User Defined Key (UDK)         
            statements in the output to select the specified font.  No          
            validation is performed on the font name before it is sent          
            to the printer, so the full font name must be specified in          
            upper/lower case exactly as expected by the XEROX printer.          
            (PRINTOFF uses the left brace character, {, hex C0, as the          
            UDK.  Input data containing this character will be                  
            interpreted by the printer as a Xerox command, and may              
            produce undesired results.)                                         
//                                                                      00380000
