SSSM TITLE 'HASP SUBSYSTEM SUPPORT MODULE PROLOG' T0000500 *********************************************************************** T0001000 * * T0001500 * MODULE NAME = HASPSSSM * T0002000 * * T0002500 * DESCRIPTIVE NAME = HASP SUBSYSTEM SUPPORT MODULE FOR JES2 * T0003000 * * T0003500 * COPYRIGHT = NONE * T0004100 * * T0004700 * STATUS = OS/VS2 MVS -- SEE &VERSION (BELOW) FOR JES2 LEVEL * T0005000 * * T0005500 * FUNCTION = HASPSSSM INTERFACES DIRECTLY WITH THE OPERATING SYSTEM * T0006000 * TO PROVIDE JOB SCHEDULING, DATA MANAGEMENT (SYSIN AND * T0006100 * SYSOUT), AND OPERATOR COMMUNICATIONS. HASPSSSM CONTAINS * T0007000 * FUNCTION ROUTINES WHICH ARE INVOKED THROUGH THE USE * T0007500 * OF VECTORS IN THE SUBSYSTEM VECTOR TABLE (SSVT). THE * T0008000 * VECTORS ARE USED BY THE OPERATING SYSTEM TO INVOKE * T0008500 * FUNCTIONS WHICH ARE DEFINED BY THE IEFJSSOB MACRO * T0009000 * EXPANSION. ADDITIONAL SSVT VECTORS ARE USED BY THE * T0009500 * HASJES20 MODULE TO PROVIDE SERVICES TO THE REST OF THE * T0010000 * JES2 SYSTEM. DURING EXECUTION OF FUNCTIONS REPRESENTED * T0010500 * BY THE SSVT VECTORS, ADDITIONAL VECTORS ARE SET INTO * T0011000 * DEBS AND ACBS FOR DATA MANAGEMENT SUPPORT. HASPSSSM * T0011500 * MAKES REQUESTS FOR SERVICES TO THE HASJES20 MODULE * T0012000 * RUNNING UNDER THE JES2 TCB AS WELL AS TO THE OPERATING * T0012500 * SYSTEM IN THE PERFORMANCE OF ITS FUNCTIONS. * T0013000 * * T0013500 * NOTES = SEE BELOW * T0014000 * * T0014500 * DEPENDENCIES = EXCP ACCESS METHOD, SUBSYSTEM INTERFACE, * T0015000 * BRANCH ENTRIES TO GETMAIN/FREE MAIN AND * T0015500 * POST, CMS AND LOCAL LOCK, SWA CREATE INTERFACE, * T0016000 * ENQ,DEQ, AND GET/PUT RPL INTERFACE * T0016500 * * T0017000 * RESTRICTIONS = NONE * T0017500 * * T0018000 * REGISTER CONVENTIONS = SEE ENTRY POINT DOCUMENTATION * T0018500 * * T0019000 * PATCH LABEL = SSMPATCH * T0019500 * * T0020000 * MODULE TYPE = PROCEDURE * T0020500 * * T0021000 * PROCESSOR = ASSEMBLER F * T0021500 * * T0022000 * MODULE SIZE = SEE $DLENGTH MACRO EXPANSION(S) AT END OF ASSEMBLY * T0022500 * * T0023500 * ATTRIBUTES = REENTRANT * T0024000 * * T0024500 * ENTRY POINT = SSVT OPERATING SYSTEM DEFINED FUNCTIONS * T0025000 * * T0025500 * HOSSOUT - PROCESS SYSOUT * T0026000 * HOSCANC - TSO CANCEL * T0026500 * HOSSTAT - TSO STATUS * T0027000 * HOSEOT - END OF TASK * T0027500 * HOSJBSL - JOB SELECTION * T0028000 * HOSALLOC - ALLOCATION * T0028500 * HOSUNAL - UNALLOCATION * T0029000 * HOSEOM - END OF MEMORY * T0029500 * HOSWTO - WTO * T0030000 * HOSCMND - COMMAND PROCESSING * T0030500 * HOSUSER - USER VALIDITY CHECK * T0031000 * HOSTERM - JOB DELETION (TERMINATE EXECUTION) * T0031500 * HOSRENQ - RE-ENQUEUE JOB * T0032000 * HOSOPEN - OPEN * T0032500 * HOSCLOS - CLOSE * T0033000 * HOSCKPT - CHECKPOINT * T0033500 * HOSREST - RESTART * T0034000 * HOSREQID - REQUEST JOB ID * T0034500 * HOSRETID - RETURN JOB ID * T0035000 * * T0035500 * SSVT JES2 SERVICE FUNCTIONS * T0036000 * * T0036500 * $$POST - POST JES2 MAIN TASK * T0037000 * USERDEST - VERIFY DESTINATION AND CONVERT TO ROUTE * T0037500 * SSVOPNC - CONVERTER FAKE OPEN * T0038000 * SSVCLSC - CONVERTER FAKE CLOSE * T0038500 * TSGCELL - GET STORAGE CELL * T0039500 * TSGCPOL - GET CELL POOL (EXPAND CELLS) * T0040000 * TSFCELL - FREE CELL BY STORAGE ADDRESS * T0040500 * TSFCELA - FREE CELL BY SJB/TCB ADDRESS * T0041000 * TSGCMNS - GET MAIN FOR CELLS * T0041500 * $$VFL - SIMULATE VFL INSTRUCTION * T0041600 * * T0042000 * ACCESS METHOD FUNCTIONS * T0042500 * * T0043000 * HASPAM - GET/PUT/CHECK/POINT/ENDREQ/ERASE * T0043500 * SUPPORT ROUTINE FOR SYSIN/SYSOUT * T0044000 * REQUESTS VIA ACB VECTORS * T0044500 * SVCHAM - END OF BLOCK ROUTINE ENTERED BY HASPAM * T0045000 * VIA SVC 111 * T0045500 * HAMCEA - CHANNEL END APPENDAGE FOR SVCHAM I/O * T0046000 * HAMCEX - ABNORMAL CHANNEL END APPENDAGE FOR * T0046500 * SVCHAM I/O * T0047000 * * T0047500 * PURPOSE = SEE ENTRY POINT DOCUMENTATION * T0048000 * * T0048500 * LINKAGE = SEE ENTRY POINT DOCUMENTATION * T0049000 * * T0049500 * INPUT = SEE ENTRY POINT DOCUMENTATION * T0050000 * * T0050500 * OUTPUT = SEE ENTRY POINT DOCUMENTATION * T0051000 * * T0051500 * EXIT-NORMAL = SEE ENTRY POINT DOCUMENTATION * T0052000 * * T0052500 * EXIT-ERROR = SEE ENTRY POINT DOCUMENTATION * T0053000 * * T0053500 * EXTERNAL REFERENCES = SEE BELOW * T0054000 * * T0054500 * ROUTINES = SVC 0, SVC 1, SVC 2, SVC 3, SVC 6, SVC 8, SVC 10, * T0055000 * SVC 11, SVC 13, SVC 34, SVC 35, SVC 48, SVC 56, * T0055500 * SVC 111, SVC 120, SETLOCK, GETMAIN/FREE MAIN, * T0056000 * IEFIB600 * T0056500 * * T0057000 * DATA AREAS = SEE $HASPCB MACRO EXPANSION * T0057500 * * T0058000 * CONTROL BLOCKS = SEE $HASPCB MACRO EXPANSION * T0058500 * * T0059000 * TABLES = NONE * T0059500 * * T0060000 * MACROS = EXCP, WAIT, POST, GETMAIN, FREEMAIN, LINK, LOAD, TIME, * T0060500 * ABEND, WTO, DEQ, ENQ, CALL, PUT, MODESET, RETURN, SETLOCK * T0061000 * * T0061100 * CHANGE ACTIVITY * T0061200 * * T0061300 * RELEASE 4.0 = OZ00553,OZ00559,OZ00790,OZ02445,OZ02448,OZ02568, * T0061500 * OZ03317,OZ03324,OZ03344,OZ04303,OZ04307,OZ04312, * T0061600 * OZ04329,OZ04992,OZ05795,OZ05957,OZ06658,OZ06720, * T0061700 * OZ07418,OZ07419,OZ07425,OZ07433,OZ07435,OZ08188, * T0061800 * OZ08194,OZ08205,OZ08213,OZ08214,OZ08220,OZ08236, * T0061900 * OZ09075,OZ09076,OZ09490,OZ10289,OZ10293,OZ10297, * T0062000 * OZ10315 * T0062100 * * T0062200 * RELEASE 4.1 = OZ07751,OZ09101,OZ09106,OZ09107,OZ10298,OZ10335, * T0062300 * OZ10345,OZ10368,OZ11323,OZ11406,OZ11741,OZ11742, * T0062400 * OZ11779,OZ11783,OZ11801,OZ12288,OZ12300,OZ13219, * T0062500 * OZ13224,OZ13237,OZ13241,OZ13257,OZ14409,OZ14426, * T0062600 * OZ14427,OZ14448,OZ14449,OZ14893,OZ14902,OZ14909, * T0062700 * OZ15289,OZ15815,OZ15825,OZ18213 * T0062800 * @G38ESBB T0062900 * EJE1103 = @G38ESBB 3800 PRINTER ENHANCEMENTS @G38ESBB T0062950 * * T0063400 *********************************************************************** T0063500 TITLE 'HASP SUBSYSTEM SUPPORT MODULE MACRO DEFINITIONS' T0063600 * T0064000 ***** $HASPCB ***** GENERATE HASP CONTROL BLOCKS T0064500 * T0065000 * T0065500 MACRO T0066000 $HASPCB &DOC=YES,&LIST=YES T0066500 GBLC &PRINT,&GEN,&DATA T0067000 PUSH PRINT T0067500 PRINT &PRINT T0068000 $PSA LIST=&LIST GENERATE OS PSA DSECT T0068500 $CVT LIST=&LIST GENERATE OS CVT DSECT T0069000 $SSCT LIST=&LIST GENERATE OS SSCT DSECT T0069500 $SSIB LIST=&LIST GENERATE OS SSIB DSECT T0070000 $SSOB (SO,CS,JS,AL,EN,ET,WT,CM,US,JT,RQ,DM,VS,DA,RR), CT0070500 LIST=&LIST GENERATE OS SSOB DSECT T0071000 $ASCB LIST=&LIST GENERATE OS ASCB DSECT T0071500 $ASXB LIST=&LIST GENERATE OS ASXB DSECT T0071500 $ACEE LIST=&LIST GENERATE OS ACEE DSECT T0071500 $ASVT LIST=&LIST GENERATE OS ASVT DSECT T0072000 $SRB LIST=&LIST GENERATE OS SRB DSECT T0072500 $TCB LIST=&LIST GENERATE OS TCB DSECT T0073000 $RB LIST=&LIST GENERATE OS RB DSECT T0073500 $JSCB LIST=&LIST GENERATE OS JSCB DSECT T0074000 $PSCB LIST=&LIST GENERATE OS PSCB DSECT T0074500 $TCT LIST=&LIST GENERATE OS TCT DSECT T0075000 $TIOT LIST=&LIST GENERATE OS TIOT DSECT T0075500 $SIOT LIST=&LIST GENERATE OS SIOT DSECT T0076000 $JFCB LIST=&LIST GENERATE OS JFCB DSECT T0076500 JFCB DSECT T0077000 ORG JFCBDSNM T0077500 SPACE 1 T0078000 * T0078500 * JOB ENTRY SUBSYSTEM DSNAME CONVENTIONS T0079000 * T0079500 SPACE 1 T0080000 DSNSSNM DC CL4'HASP',C'.' SUBSYSTEM NAME T0080500 DSNJBID DC 0CL8'JOB12345',C'JOB' JOB IDENTIFIER T0081000 DSNJBNR DC ZL5'12345',C'.' JOB NUMBER T0081500 DSNDSID DC 0CL6'SO1234' DATASET IDENTIFIER T0082000 DSNDSTYP DC CL2'SO' DATASET FUNCTIONAL TYPE T0082500 DSNDSNR DC ZL4'1234',C'.' UNIQUE DATA SET NUMBER T0083000 DSNDDNM DC CL8'STCINRDR' DATASET DEFINITION NAME T0083500 DSNBLANK EQU DSNDSNR+L'DSNDSNR,1 PAD WITH BLANKS FROM HERE. T0084000 DSNBLNK1 EQU DSNBLANK+1,L'JFCBDSNM-(DSNBLANK+1-JFCBDSNM) T0084500 &SYSECT CSECT RETURN TO MAIN CSECT T0085000 $DCB LIST=&LIST GENERATE OS DCB DSECT T0085500 $RPL LIST=&LIST GENERATE OS RPL DSECT T0086000 $RMR LIST=&LIST GENERATE OS RPL RETURN CODES T0086500 $ACB LIST=&LIST GENERATE OS ACB DSECT T0087000 ACBINR EQU X'04' DEBIRBAD POINTS TO INTRDR T0087500 $ACBXL LIST=&LIST GENERATE OS ACBXL DSECT T0088000 $DEB LIST=&LIST GENERATE OS DEB DSECT T0088500 $IOSB LIST=&LIST GENERATE OS IOSB DSECT T0088600 $UCB LIST=&LIST GENERATE OS UCB DSECT T0088700 $NEL LIST=&LIST GENERATE OS NEL DSECT T0089000 $LCT LIST=&LIST GENERATE OS LCT DSECT T0089500 $CSCB LIST=&LIST GENERATE OS CSCB DSECT T0090000 $UCM LIST=&LIST GENERATE OS UCM DSECT T0090500 $WQE LIST=&LIST GENERATE OS WQE DSECT T0091000 $ORE LIST=&LIST GENERATE OS ORE DSECT T0091500 $SDWA LIST=&LIST GENERATE OS SDWA DSECT @OZ36122 T0091600 $IOCM LIST=&LIST GENERATE OS IOCM DSECT T0091800 $SMCA LIST=&LIST GENERATE OS SMCA DSECT R4 T0091900 $RQE LIST=&LIST GENERATE OS RQE DSECT @OZ43706 T0091950 $LCCA LIST=&LIST GENERATE OS LCCA DSECT @OZ43706 T0091960 $TED DOC=&DOC GENERATE HASP TED DSECT T0092000 $TGB DOC=&DOC GENERATE HASP TGB DSECT T0092300 $TGM DOC=&DOC GENERATE HASP TGM DSECT T0092500 $TAB DOC=&DOC GENERATE HASP TAB DSECT R4 T0092600 $SVT DOC=&DOC GENERATE HASP SSVT DSECT T0093000 $SJB DOC=&DOC GENERATE HASP SJB DSECT T0093500 $SDB DOC=&DOC GENERATE HASP SDB DSECT T0094000 $HCT DOC=&DOC GENERATE HASP HCT DSECT T0094500 $PCE DOC=&DOC GENERATE HASP PCE DSECT T0095000 $LRC DOC=&DOC GENERATE HASP LRC DSECT T0095500 $BUFFER DOC=&DOC GENERATE HASP BUFFER DSECT T0096000 $CMB DOC=&DOC GENERATE HASP CMB DSECT T0096500 $JCT DOC=&DOC GENERATE HASP JCT DSECT T0097000 $PDDB DOC=&DOC GENERATE HASP PDDB DSECT T0097500 $IOT DOC=&DOC GENERATE HASP IOT DSECT T0098000 $CAT DOC=&DOC GENERATE HASP CAT DSECT T0098500 $OCR DOC=&DOC GENERATE HASP OCR DSECT T0099000 $OCT DOC=&DOC GENERATE HASP OCT DSECT T0099500 $SCAT DOC=&DOC GENERATE HASP SCAT DSECT T0100000 $RAT DOC=&DOC GENERATE HASP RAT DSECT T0100500 $RDT DOC=&DOC GENERATE HASP RDT DSECT R4 T0100600 $DCT DOC=&DOC GENERATE HASP DCT DSECT T0101000 $CCE DOC=&DOC GENERATE HASP CCE DSECT T0101500 $HQR DOC=&DOC GENERATE HASP HQR DSECT T0101600 $PSO DOC=&DOC GENERATE HASP PSO DSECT T0102000 $CSA DOC=&DOC GENERATE HASP CSA DSECT R4 T0102100 $CNVWORK DOC=&DOC GENERATE HASP CNVWORK DSECT T0102500 $BF DOC=&DOC GENERATE HASP BF DSECT T0103000 SPACE 3 T0103500 POP PRINT T0104000 PRINT &GEN,&DATA SET ASSEMBLY PRINT OPTIONS T0104500 MEND T0105000 TITLE 'HASP SUBSYSTEM SUPPORT MODULE LOCAL MACRO DEFINITIONS' T0105500 MACRO T0106000 $BF &DOC=NO T0106500 GBLA &BUFSIZE T0107000 TITLE 'GENERALIZED SUBSYSTEM DATASET BUFFER' T0107500 * T0108000 * T0108500 * GENERALIZED SUBSYSTEM DATASET BUFFER DSECT T0109000 * T0109500 * T0110000 BFDSECT DSECT T0110500 BFD EQU BFDSECT T0111000 SPACE 3 T0111500 BFID DS CL4 ID - PBF, UBF, OR HBF T0112000 BFLENG DS AL2(4096) LENGTH R4 T0112500 BFFL1 DS B FLAG BYTE 1 T0113000 BFFL2 DS B FLAG BYTE 2 T0113500 BFBF DS A CHAIN POINTER T0114000 BFTRK DS F TRACK ADDRESS OF BUFFER T0114500 BFTCB DS A TCB ADDRESS FOR FREEMAIN T0115000 BFASCB DS A ASCB ADDRESS FOR FREEMAIN T0115500 BFLOC DS A CURRENT LOCATION IN BUFFER T0116000 BFLEN DS 0F OUTPUT - LENGTH REMAINING T0116500 BFECB DS F INPUT - ECB ON WHICH TO WAIT T0117000 BFRBA DS D RELATIVE BLOCK ADDRESS T0117500 BFRCT DS F RECORD COUNTER T0118000 * T0118500 * ONLY THE FOLLOWING DATA IS WRITTEN TO DISK T0119000 * T0119500 BFIO EQU * START OF AUXILIARY STORAGE DATA R4 T0120000 BFNXT DS F CHAINING TRACK T0120500 BFKEY DS 0CL6 UNIQUE DATA SET KEY --- T0121000 BFJBK DS CL4 4-BYTE JOB KEY BASED ON TOD CLOCK T0121500 BFDSK DS CL2 2-BYTE SEQUENTIAL DATA SET KEY T0122000 BFDAT EQU * USER DATA AREA R4 T0122500 EJECT T0124500 * T0125000 * FLAG DEFINITIONS T0125500 * T0126000 SPACE 3 T0126500 * FLAGS 1 --- T0127000 SPACE 1 T0127500 BF1EOB EQU B'10000000' END-OF-BUFFER INDICATOR R4 T0128000 BF1RSV1 EQU B'01000000' RESERVED T0128500 BF1RSV2 EQU B'00100000' RESERVED T0129000 BF1RSV3 EQU B'00010000' RESERVED T0129500 BF1GSG EQU B'00001000' HGMOVE SPAN ENTRY FLAG T0130000 BF1IOC EQU B'00000100' PBF I/O IS COMPLETE T0130500 BF1PMV EQU B'00000010' HPMOVE ENTRY FLAG T0131000 BF1PSG EQU B'00000001' HPMOVE SPAN ENTRY FLAG T0131500 SPACE 3 T0132000 * FLAGS 2 --- T0132500 SPACE 1 T0133000 BF2IOC EQU B'10000000' UBF NOT PRIMED BY HCEGET @OZ30886 T0133500 BF2RSV1 EQU B'01000000' RESERVED T0134000 BF2RSV2 EQU B'00100000' RESERVED T0134500 BF2RSV3 EQU B'00010000' RESERVED T0135000 BF2RSV4 EQU B'00001000' RESERVED T0135500 BF2RSV5 EQU B'00000100' RESERVED T0136000 BF2RSV6 EQU B'00000010' RESERVED T0136500 BF2RSV7 EQU B'00000001' RESERVED T0137000 SPACE 6 T0156000 &SYSECT CSECT T0156500 MEND T0157000 SPACE 3 R4 T0157300 MACRO T0157500 &LABEL CALL &ARG T0158000 &LABEL L R15,=A(&ARG) T0158500 BALR R14,R15 T0159000 MEND T0159500 SPACE 3 T0160000 MACRO T0160500 &L $PROLOG &FUNC,&LENG,&LOCK=NO,&KEY=0 T0161000 GBLB &B(8) T0161500 &B(1) SETB ('&LOCK' EQ 'YES') T0162000 &B(2) SETB ('&LOCK' EQ 'REQ') T0162500 &B(3) SETB ('&LOCK' EQ 'SDB') T0163000 &B(1) SETB (&B(1) OR &B(2) OR &B(3)) T0163500 &L $ENTRY BASE=R15,ENTRY=NO PROVIDE ENTRY FOR ROUTINE T0164000 L R15,=A($PROLOG) T0164500 BALR R15,R15 T0165000 DC B'&B(1)&B(2)&B(3)&B(4)&B(5)&B(6)&B(7)&B(8)' T0165500 DC AL1(&FUNC) T0166000 DC AL2(&LENG) T0166500 DROP R15 T0167000 USING *,R12 T0167500 MEND T0168000 MACRO T0168500 &L $EPILOG &KEY= T0169000 &L L R14,=A($EPILOG) T0169500 BR R14 T0170000 MEND T0170500 MACRO T0171000 &L $ALGN &OP,&R1,&S2 T0171500 &L &OP &R1,0 T0172000 ORG *-2 T0172500 DC S(&S2) T0173000 MEND T0173500 SPACE 3 T0174000 MACRO T0174500 &L $GETMAIN &TYPE,&A=,&LV=,&SP=,&KEY= T0175000 &L $MAIN 0,&TYPE,0,&LV,&SP,&KEY T0175500 MEND T0176000 SPACE 3 T0176500 MACRO T0177000 &L $FREMAIN &TYPE,&A=,&LV=,&SP=,&KEY=,&TCB=NO T0177500 &L $MAIN 1,&TYPE,&A,&LV,&SP,&KEY,&TCB T0178000 MEND T0178500 SPACE 3 T0179000 MACRO T0179500 &L $GETBUF &TYPE=PROT,&A= T0180000 AIF ('&TYPE' EQ 'PROT').PROT T0180500 &L $MAIN 0,BC,0,4096,229,15 UNPROTECTED R4 T0181000 MEXIT T0181500 .PROT ANOP T0182000 &L $MAIN 0,BC,0,4096,229,5 PROTECTED R4 T0182500 MEND T0183000 SPACE 3 T0183500 MACRO T0184000 &L $FREEBUF &TYPE=PROT,&A= T0184500 AIF ('&TYPE' EQ 'PROT').PROT T0185000 &L $MAIN 1,BU,&A,4096,229,15 UNPROTECTED R4 T0185500 MEXIT T0186000 .PROT ANOP T0186500 &L $MAIN 1,BU,&A,4096,229,5 PROTECTED R4 T0187000 MEND T0187500 SPACE 3 T0188000 MACRO T0188500 &L $MAIN &T,&TYPE,&A,&LV,&SP,&KEY,&TCB T0189000 LCLA &TYPA,&TYP,&I T0189500 LCLB &B T0190000 LCLC &C T0190500 * REGISTERS DESTROYED -- R0,R1,R2,R3,R4,R7,R14,R15 T0191000 .* T0191500 .* TEST REGULAR OR BUFFER TYPE T0192000 .* T0192500 AIF ('&TYPE'(1,1) NE 'B').NOTB GO IF NOT BUFFER-TYPE. T0193000 &TYPA SETA &TYPA+64 SHOW BUFFER-TYPE T0193500 .NOTB ANOP T0194000 .* T0194500 .* SET &TYPA BIT 2 IF GETMAIN, BIT 3 IF FREEMAIN T0195000 .* T0195500 &TYPA SETA &TYPA+32 ASSUME GETMAIN T0196000 AIF (NOT &T).NOTFREE GO IF ASSUMPTION CORRECT. T0196500 &TYPA SETA &TYPA+16-32 SET FREEMAIN T0197000 .NOTFREE ANOP T0197500 .* T0198000 .* SET &TYPA BIT 4 IF TCB=YES T0198500 .* T0199000 AIF ('&TCB' NE 'YES').NOTCB SKIP IF TCB NOT YES. T0199500 &TYPA SETA &TYPA+8 FLAG TCB=YES. T0200000 .NOTCB ANOP CONTINUE. T0200500 .* T0201000 .* TEST CONDITIONALITY AND GET/FREE T0201500 .* T0202000 &B SETB ('&TYPE'(2,1) EQ 'U') T0202500 &TYP SETA &T+2*&B T0203000 .* T0203500 .* SET INDEX TO DESCRIBE ARGUMENTS T0204000 .* T0204500 AIF ('&LV' EQ '(R0)').T3 IF LR IS REQUIRED FOR LV=, T0205000 &I SETA &I+1 ADD 1 TO INDEX T0205500 AIF ('&LV'(1,1) EQ '(').T3 IF ADCON REQUIRED FOR LV=, T0206000 &I SETA &I+1 ADD 1 TO INDEX. T0206500 .T3 AIF ('&A' EQ '(R1)').T6 IF SLR OR LR REQUIRED FOR A=, T0207000 &I SETA &I+3 ADD 3 TO INDEX. T0207500 AIF (NOT &T OR '&A'(1,1) EQ '(').T6 IF L REQUIRED FOR A=, T0208000 &I SETA &I+3 ADD 3 TO INDEX. T0208500 .T6 ANOP T0209000 .* T0209500 .* SET CONDITIONAL NO-OPERATION T0210000 .* T0210500 AIF (&I-&I/2*2 EQ 0).CNOP2 IF INDEX IS ODD, T0211000 CNOP 0,4 T0211500 AGO .LABEL START ON WD BDRY, ELSE HALFWORD. T0212000 .CNOP2 CNOP 2,4 T0212500 .LABEL ANOP T0213000 .* T0213500 .* SET UP LABEL IF PROVIDED T0214000 .* T0214500 AIF ('&L' EQ '').NOLABEL GO IF BLANK LABEL T0215000 &L DS 0H T0215500 .NOLABEL ANOP T0216000 .* T0216500 .* SET UP LENGTH VALUE ARGUMENT LV= T0217000 .* T0217500 &C SETC '012012012'(&I+1,1) EXTRACT LV= FROM INDEX. T0218000 AIF (&C EQ 2).A IF LENGTH TO BE PASSED IN R0, T0218500 &TYPA SETA &TYPA+128 SHOW SO BY FLAG. T0219000 AIF (&C EQ 0).A IF LV=(R0),LENGTH ALREADY LKAY. T0219500 &C SETC '&LV'(2,K'&LV-2) ELSE REMOVE PARENTHESES. T0220000 LR R0,&C T0220500 .A ANOP T0221000 .* T0221500 .* SET UP ADDRESS VALUE &A= T0222000 .* T0222500 &C SETC '000111222'(&I+1,1) EXTRACT A= FROM INDEX. T0223000 AIF (&T).A0 IF GETMAIN, ZERO ADDRESS REGISTER. T0223500 SLR R1,R1 T0224000 AGO .A3 T0224500 .A0 AIF (&C EQ 0).A3 IF R1 ALREADY SET UP, BRANCH. T0225000 AIF (&C NE 1).A2 IF LR IS REQUIRED, T0225500 &C SETC '&A'(2,K'&A-2) REMOVE PARENTHESES AND LR. T0226000 LR R1,&C T0226500 AGO .A3 T0227000 .A2 L R1,&A T0227500 .A3 ANOP T0228000 .* T0228500 .* CALL HGFMAIN T0229000 .* T0229500 L R15,=A(HGFMAIN) T0230000 BALR R4,R15 T0230500 .* T0231000 .* T0231500 .* DESCRIPTION OF FOLLOWING FULLWORD --- T0232000 .* T0232500 .* BYTE 0 --- T0233000 .* BIT 0 IS ON IF LV= OPERAND IS IN R0, OFF IF LV= T0233500 .* OPERAND IS IN THE FULLWORD FOLLOWING THIS. T0234000 .* BIT 1 IS ON IF $GETBUF/$FREEBUF, OFF IF $GETMAIN/ T0234500 .* $FREMAIN. T0235000 .* BIT 2 IS ON IF $GETMAIN/$GETBUF. T0235500 .* BIT 3 IS ON IF $FREMAIN/$FREEBUF. T0236000 .* BIT 4 IS ON IF TCB SUPPLIED FOR $FREMAIN. T0236500 .* BITS 5-7 ARE RESERVED FOR FUTURE USE. T0237000 .* T0237500 .* BYTE 1 --- T0238000 .* BITS 0-3 CONTAIN STORAGE PROTECTION KEY, OR X'F'. T0238500 .* THE LATTER IS AN INDICATION TO HGFMAIN TO USE T0239000 .* THE PROTECT KEY FROM TCBPKF. T0239500 .* BITS 4-7 MUST BE ZERO. T0240000 .* T0240500 .* BYTE 2 --- T0241000 .* BITS 0-7 CONTAIN SUBPOOL NUMBER. T0241500 .* T0242000 .* BYTE 3 --- T0242500 .* BITS 0-7 CONTAIN A CODE USED BY VIRTUAL STORAGE T0243000 .* SUPERVISOR -- T0243500 .* 0 - CONDITIONAL GETMAIN T0244000 .* 1 - CONDITIONAL FREEMAIN T0244500 .* 2 - UNCONDITIONAL GETMAIN T0245000 .* 3 - UNCONDITIONAL FREEMAIN T0245500 .* T0246000 .* T0246500 DC AL1(&TYPA,&KEY*16,&SP,&TYP) T0247000 .* T0247500 .* ADD LENGTH ADCON IF NOT IN R0 T0248000 .* T0248500 AIF (&TYPA GE 128).NOLAD GO IF LENGTH ALREADY IN REG. T0249000 DC A(&LV) T0249500 .NOLAD ANOP T0250000 MEND T0250500 HASPSSSM START 0 HASP SUBSYSTEM SUPPORT MODULE T0263500 COPY $HASPGEN T0264000 TITLE 'OS/HASP CONTROL BLOCKS' T0264500 SPACE 5 T0265000 HASPSSSM $ENTRY BASE=,CSECT=YES, PROVIDE PROCESSOR ID AND R41CT0265500 POINTER=(SENTL,SENTRIES) POINTER TO ADCON VECTOR R41 T0265600 SPACE 5 T0266000 * T0266500 * DOCUMENTATION OPTIONS FOR THIS ASSEMBLY T0267000 * T0267500 SPACE 3 T0268000 $SYSPARM (OFF,GEN,NODATA,NO,NO) T0268500 EJECT R4 T0269000 * T0269500 * GENERATE OS/HASP CONTROL BLOCKS T0270000 * T0270500 SPACE 3 T0271000 $HASPCB DOC=&DOC,LIST=&LIST GENERATE HASP CONTROL BLOCKS T0271500 TITLE 'HASP EXIT ROUTINE WORK AREA DSECTS' T0272000 *********************************************************************** T0272500 * * T0273000 * USER SAVE AREA DSECT * T0273500 * * T0274000 *********************************************************************** T0274500 USAVE DSECT T0275000 DS F T0275500 UCALLER DS F CALLER'S CALLER SAVE T0276000 UOURSAV DS F OUR SAVE T0276500 USAVER DS 15F REGISTERS 14,15,0-12 T0277000 UDENQ ENQ (*-*,*-*,E,3,STEP),RET=USE,MF=L @OZ34664 T0277100 UDRN DS CL3 RNAME TO SERIALIZE LOGGING @OZ34664 T0277200 UESTAE ESTAE UESTAER,TERM=YES,RECORD=YES,MF=(L) @OZ36122 T0277230 ULEN EQU *-USAVE LENGTH OF EXTENDED AREA @OZ34664 T0277300 SPACE 3 T0277500 ORG UOURSAV REDEFINE FOR SVC 35 WORK AREA T0278000 USAVFL DS C FLAGS BYTE T0278500 USAVFLM EQU X'80' MULTIPLE LINE WTO (MLWTO) T0279000 USAVFLMI EQU X'40' CURRENT WQE IS A MINOR WQE T0279500 *********************************************************************** T0293000 * * T0293500 * SVC 35 WORK AREA * T0294000 * * T0294500 *********************************************************************** T0295000 S35DSECT DSECT T0295500 S35DSTRT DS 0D @OZ34664 T0295600 S35DID DC CL4'S35D' DSECT IDENTIFIER @OZ34664 T0295700 DS F FILLER TO MATCH S34DSECT @OZ34664 T0295800 S35DNEXT DS F POINTER TO NEXT BUFFER @OZ34664 T0295900 S35DWK DS 0D WORK AREA T0296000 S35DSAV DS F STANDARD SAVE AREA T0296500 S35DSAVH DS F POINTER TO CALLERS SAVE T0297000 DS F T0297500 DS 15F REGISTERS T0298000 S35DMSGL DS H LENGTH OF TEXT IN LOG BUFFER T0298500 S35DMSG DS 0CL146 MESSAGE AREA T0299000 S35DTIME DS CL8 HH.MM.SS T0299500 DS C - T0300000 S35DJOB DS CL8 JOB NNNN T0300500 DS C T0301000 S35DACTF DS C * T0301500 S35HIDL EQU 9 SIZE OF HASP ID PORTION OF TEXT R4 T0302000 S35DHID DS CL(S35HIDL) HASPXXX- T0302500 S35DJOBN DS CL8 JOBNAMES T0303000 DS C - T0303500 S35DTXTL EQU (S35DMSG+L'S35DMSG-*) T0304000 S35DTXT DS CL(S35DTXTL) HASPSSSM TEXT T0304500 S35DMAX EQU 132 MAXIMUM LOG LRECL SIZE T0305000 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0305500 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0306000 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0306500 DS 0D T0307000 S35DL EQU *-S35DSECT LENGTH OF WORK AREA T0307500 S35WQEID EQU WQETXT+1,1 LOCATION OF HASP $ T0308000 S35WQEHT EQU WQETXT+S35HIDL+1 LOCATION OF HASPSSSM WTO TEXT T0309000 *********************************************************************** T0310000 * * T0310500 * COMMAND INPUT BUFFER (CBF) DSECT * T0311000 * * T0311500 *********************************************************************** T0312000 CBF DSECT T0312500 CBFCNT DS H LENGTH OF ENTIRE BUFFER (136) T0313000 DS H T0313500 CBFTEXT DS CL140 TEXT AREA T0314000 CBFL EQU *-CBF T0314500 HASPSSSM CSECT T0315000 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - SUPPORT ROUTINES ' T0315500 USING SSVT,R11 ESTABLISH BASE T0316000 USING USAVE,R13 T0316500 *********************************************************************** T0317000 * * T0317500 * SUPPORT ROUTINE ENTRY POINTS, MOVED TO SSVT BY HASPINIT * T0318000 * * T0318500 *********************************************************************** T0319000 SENTRIES DS 0F T0319500 DC A(HOSSOUT) PROCESS SYSOUT T0320000 DC A(HOSCANC) TSO CANCEL T0320500 DC A(HOSSTAT) TSO STATUS T0321000 DC A(HOSEOT) END OF TASK T0321500 DC A(HOSJBSL) JOB SELECTION T0322000 DC A(HOSALLOC) ALLOCATION T0322500 DC A(HOSUNAL) UNALLOCATION T0323000 DC A(HOSEOM) END OF MEMORY T0323500 DC A(HOSWTO) WTO T0324000 DC A(HOSCMND) COMMAND PROCESSING T0324500 DC A(HOSUSER) USERID VALIDITY CHECK T0325000 DC A(HOSTERM) JOB DELETION T0325500 DC A(HOSRENQ) RE-ENQUEUE JOB T0326000 DC A(HOSOPEN) OPEN T0326500 DC A(HOSCLOS) CLOSE T0327000 DC A(HOSCKPT) CHECKPOINT T0327500 DC A(HOSREST) RESTART T0328000 DC A(HOSREQID) REQUEST JOB ID T0328500 DC A(HOSRETID) RETURN JOB ID T0329000 *********************************************************************** T0329500 * * T0330000 * SUBROUTINE ENTRY POINTS MOVED TO SSVT * T0330500 * * T0331000 *********************************************************************** T0331500 DC A($$POST) POST HASP TASK T0332000 DC A(USERDEST) VERIFY DESTINATION T0332500 DC A(SSVOPNC) CONVERTER FAKE OPEN T0333000 DC A(SSVCLSC) CONVERTER FAKE CLOSE T0333500 DC A(TSGCELL) GET STORAGE CELL T0334500 DC A(TSGCPOL) GET CELL POOL T0335000 DC A(TSFCELL) FREE CELL BY STORAGE ADDRESS T0335500 DC A(TSFCELA) FREE CELL BY SJB/TCB ADDRESS T0336000 DC A(TSGCMNS) GET MAIN FOR CELLS T0336500 DC A($$VFL) SIMULATE VFL INSTRUCTION R4 T0336600 DC A(SSMPATCH) SSSM PATCH SPACE POINTER T0337000 SENTL EQU *-SENTRIES SHOULD BE EQUAL TO $SVENTL T0337500 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - SVC 34 EXIT' T0338000 *********************************************************************** T0338500 * * T0339000 * SVC 34 EXIT - SUBSYSTEM FUNCTION SSOBCMND * T0339500 * * T0340000 * FUNCTION * T0340500 * * T0341000 * RECEIVE CONTROL FROM THE OPERATING SYSTEM SVC 34 PROCESSING * T0341500 * ROUTINES FOR THE PURPOSE OF EDITING THE COMMAND BUFFER TEXT, * T0342000 * COPYING HASP COMMANDS TO CMBS FOR HASP ACTION, AND COPYING * T0342500 * EDITED REPLY COMMANDS AND QUEUING THEM FOR OUTPUT BY THE SVC * T0343000 * 35 EXIT ROUTINE. THE DESCRIPTION OF OPERATIONS FOLLOW. * T0343500 * * T0344000 * (1) BACKSPACE EDIT THE COMMAND TEXT LOCATING THE BEGINNING * T0344500 * AND CALCULATING THE LENGTH OF SOLID TEXT. * T0345000 * * T0345500 * (2) IF THE COMMAND IS A REPLY COMMAND, PERFORM THE FOLLOWING * T0346000 * * T0346500 * GET A STORAGE CELL, FILL IT OUT WITH THE OS FORMAT * T0347000 * (R NN,TEXT), PROVIDE THE INPUT AREA WITH A COPY * T0347500 * (TRUNCATED IF NECESSARY), AND TIME STAMP THE CELL. * T0348000 * IF AN ERROR IS ENCOUNTERED, FREE THE CELL AND GIVE * T0348500 * THE COMMAND TO OS. * T0349000 * * T0349500 * GET THE CMS LOCK, LOOK FOR AN ORE WITH MATCHING * T0350000 * NUMBERS, LOCATE THE CORRESPONDING SJB, QUEUE * T0350500 * THE CELL TO THE SJB WITH CELL OWNER SET TO THE SJB, * T0351000 * FREE THE LOCK, AND RETURN GIVING THE COMMAND TO * T0351500 * OS. IF NO ORE OR SJB FREE THE CELL INSTEAD OF QUEUING * T0352000 * IT TO THE SJB. * T0352500 * * T0353000 * (3) IF THE COMMAND STARTS WITH THE HASP COMMAND IDENTIFIER * T0353500 * AND THE HIGH ORDER 3 BYTES OF SSCMSCID (SVC 34 R0 VALUE) * T0354000 * ARE ZERO, GET A CMB, REDUCE THE $SVCOMCT COUNT, PLACE THE * T0354500 * COMMAND AND RESTRICTIONS INTO THE CMB, QUEUE THE CMB TO * T0355000 * THE $SVCOMMQ QUEUE, AND POST THE HASP TASK. IF THE COMMAND * T0355500 * IS TOO LONG TO FIT INTO A CMB, THERE ARE NO CMBS IN THE * T0356000 * $SVCMBFQ OR $SVCMBRQ QUEUES, OR THE $SVCOMCT GOES TO ZERO, * T0356500 * PROCESSING IS NEGATED AND CONTROL IS RETURNED TO OS WITH * T0357000 * AN ERROR INDICATION. IF HASP IS NOT UP ON ENTRY PROCESSING * T0357500 * IS ABORTED AND CONTROL IS RETURNED TO OS WITH R15 INDICATING * T0358000 * HASP NOT UP. * T0358500 * * T0359000 * (4) IF THE COMMAND IS NOT NUMERIC OR FOR HASP, IT IS GIVEN * T0359500 * TO OS. * T0360000 * * T0360500 * INPUT REGISTERS * T0361000 * * T0361500 * R0 = ADDRESS OF SSCVT * T0362000 * R1 = ADDRESS OF SSOB * T0362500 * R13 = SAVE AREA * T0363000 * R14 = RETURN * T0363500 * R15 = ENTRY BASE * T0364000 * * T0364500 *********************************************************************** T0365000 EJECT T0365500 *********************************************************************** T0366000 * * T0366500 * OUTPUT REGISTERS * T0367000 * * T0367500 * R0-R14= UNCHANGED * T0368000 * R15 = RETURN CODE * T0368500 * * T0369000 * NOTES * T0369500 * * T0370000 * THE HASP SVC 34 EXIT CONVERTS REPLIES TO STANDARD FORMAT. THE * T0370500 * FORMATS ARE DESCRIBBED BELOW USING THE FOLLOWING CONVENTIONS. * T0371000 * * T0371500 * /XXX/ = XXX IS OPTIONAL * T0372000 * (XXX) = XXX IS REQUIRED * T0372500 * X... = X IS REPEATED A NUMBER OF TIMES * T0373000 * TEXT = CHARACTER STRING INCLUDING BLANKS GIVEN TO USER * T0373500 * COMMENT CHARACTER STRING INCLUDING BLANKS IGNORED * T0374000 * * T0374500 * INPUT = (REPLY)/ .../(N) /,/TEXT// * T0375000 * (R ) (NN)/,'TEXT'/ COMMENT// * T0375500 * / COMMENT/ * T0376000 * * T0376500 * OUTPUT= (R NN)/,/TEXT// * T0377000 * /,'TEXT'/ COMMENT// * T0377500 * / COMMENT/ * T0378000 * * T0378500 * INPUT = (N) /,// ...//TEXT/ * T0379000 * (NN)/ / /'TEXT'/ COMMENT// * T0379500 * * T0380000 * OUTPUT= (R NN,)/TEXT/ * T0380500 * /'TEXT'/ COMMENT// * T0381000 * * T0381500 *********************************************************************** T0382000 EJECT T0382500 *********************************************************************** T0383000 * * T0383500 * ENTRY TO SVC 34 EXIT - PICK UP PARAMETERS * T0384000 * * T0384500 *********************************************************************** T0385000 HOSCMND $ENTRY BASE=R15,ENTRY=NO PROVIDE ENTRY FOR ROUTINE T0385500 S34 EQU HOSCMND T0386000 STM R14,R12,USAVER SAVE CALLER'S REGISTERS T0386500 LR R12,R15 ESTABLISH BASE T0387000 USING S34,R12 T0387500 DROP R15 T0388000 LR R8,R0 POINT TO SSCVT T0388500 USING SSCT,R8 T0389000 L R11,SSCTSSVT POINT TO SSVT T0389500 LR R10,R1 POINT TO SSOB T0390000 USING SSOB,R10 T0390500 L R9,SSOBINDV POINT TO FUNCTION AREA T0391000 L R2,SSCMBUFF-SSCMBGN(0,R9) POINT TO COMMAND BUFFER T0391500 EJECT T0392000 *********************************************************************** T0392500 * * T0393000 * LOCATE AND BACKSPACE EDIT THE COMMAND * T0393500 * * T0394000 *********************************************************************** T0394500 USING CBF,R2 T0395000 LH R5,CBFCNT PICK UP LENGTH OF CIB T0395500 CH R5,=Y(CBFL) IS IT STANDARD LENGTH T0396000 BH S34OEXIT EXIT IF HIGH T0396500 CLI CBFTEXT,C' ' TEST FOR VERB AT START OF TEXT T0397000 BE S34OEXIT EXIT IF NOT T0397500 AR R5,R2 END + 1 T0398000 BCTR R5,0 END T0398500 S34EBT CLI 0(R5),C' ' IS IT BLANK T0399000 BNE S34ENB IF END NOT BLANK EXIT T0399500 BCT R5,S34EBT LOOP T0400000 S34ENB LA R4,CBFTEXT-1 POINT TO TEXT - 1 T0400500 LR R6,R4 LOAD BSPACE SCANNER T0401000 S34BSL LR R7,R5 SET LENGTH COUNTER T0401500 SR R7,R6 GET LENGTH OF REMAINING T0402000 BNP S34BEND GIVE BACK TO OS IF NO TEXT T0402500 CLC $SVBAKSP,1(R6) CHECK FOR BACKSPACE R4 T0403000 BE S34BS BR IF YES T0403500 LA R6,1(0,R6) POINT TO NEXT CHARACTER T0404000 B S34BSL LOOP T0404500 S34BS BCT R7,S34BSB IF COUNT GT 1 BR T0405000 CR R6,R4 IS THIS FIRST CHARACTER T0405500 BNE S34BCNF BR IF NOT T0406000 B S34BONE BLANK ONE CHARACTER IF YES T0406500 S34BSB BCTR R7,0 REDUCE TO MACHINE COUNT T0407000 CR R6,R4 IS THIS FIRST CHARACTER T0407500 BNE S34BMC IF NOT MOVE CHARACTERS T0408000 EX R7,S34BMVF MOVE INTO FIRST CHARACTER T0408500 B S34BONE BLANK ONE CHARACTER T0409000 S34BMC EX R7,S34BMVC MOVE INTO CURRENT CHARACTER T0409500 S34BCNF MVI 0(R5),C' ' SET BLANK T0410000 BCTR R5,0 ADJUST COMMAND SIZE T0410500 BCTR R6,0 BACK UP CURRENT CHARACTER SCAN T0411000 S34BONE MVI 0(R5),C' ' SET BLANK T0411500 BCTR R5,0 ADJUST COMMAND SIZE T0412000 CLI 1(R4),C' ' IS FIRST CHARACTER BLANK T0412500 BNE S34BSL LOOP IF NOT T0413000 MVC 1(1,R4),$SVBAKSP FORCE ANOTHER BACKSPACE R4 T0413500 B S34BSL LOOP T0414000 S34BEND SR R5,R4 GET NEW LENGTH OF COMMAND T0414500 BNP S34HEXIT IF NULL CAUSE THROW AWAY T0415000 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - SVC 34 EXIT - REPLIES' T0415500 *********************************************************************** T0416000 * * T0416500 * TEST FOR AND HANDLE ALL NUMERIC REPLY FORMATS * T0417000 * * T0417500 *********************************************************************** T0418000 CLI 1(R4),C'0' TEST FOR NUMERIC COMMAND T0418500 BL S34NN BR IF NOT NUMERIC T0419000 S34REPLY LR R8,R2 SAVE CBF POINTER T0419500 LR R6,R4 SAVE POINTER T0420000 LA R0,2 SET CLAIM ID T0420500 LR R1,R0 IN BOTH REGISTERS T0421000 LA R4,S34DL SET LENGTH T0421500 L R15,$SVGCELL POINT TO GET CELL ROUTINE T0422000 BALR R14,R15 ENTER IT T0422500 B S34NCELL NO CELL EXIT +0 T0423000 S34GCELL LR R2,R8 RESTORE CBF POINTER +4 T0423500 LR R8,R1 POINT TO AREA T0424000 USING S34DSECT,R8 T0424500 *********************************************************************** T0425000 * * T0425500 * FILL OUT SKELETON OF WORK AREA * T0426000 * * T0426500 *********************************************************************** T0427000 MVC S34DTIME-1(S34TL),S34TIME INSERT EDIT PATTERNS T0427500 LR R7,R6 POINT TO COMMAND-1 T0428000 LR R6,R5 GET LENGTH OF TEXT T0428500 MVC S34DIGIT+1(1),1(R7) MOVE IN DIGIT T0429000 LA R7,1(0,R7) UP ONE T0429500 BCT R6,*+8 DOWN ONE T0430000 B S34MINR SKIP MOVE OUT IF NULL T0430500 CLI 1(R7),C'0' TEST FOR TWO DIGITS T0431000 BL S34N1D BR IF ONE T0431500 MVC S34DIGIT(2),0(R7) MOVE IN DIGITS T0432000 LA R7,1(0,R7) UP ONE T0432500 BCT R6,S34N1D REDUCE TEXT COUNT T0433000 B S34MINR SKIP MOVE OUT IF NULL TEXT T0433500 S34N1D LTR R2,R2 IS THIS OS FORMAT T0434000 BM S34NMOR MOVE ALL FOLLOWING THE NUMERIC T0434500 CLI 1(R7),C',' IS FIRST CHARACTER A COMMA T0435000 BE S34NSCMA PRETEND BLANK IF SO T0435500 S34NNBS CLI 1(R7),C' ' IS CHARACTER A BLANK T0436000 BNE S34NREPY MOVE SOLID TEXT T0436500 S34NSCMA LA R7,1(0,R7) UP ONE T0437000 BCT R6,S34NNBS COUNT AND LOOP T0437500 B S34MINR SKIP MOVE IF NULL T0438000 EJECT T0438500 *********************************************************************** T0439000 * * T0439500 * MOVE TEXT INTO WORK AREA IF NOT TOO LONG, THEN BACK * T0440000 * * T0440500 *********************************************************************** T0441000 S34NMOR BCTR R6,0 REDUCE COUNT T0441500 CH R6,=Y(S34DTL) TEST FOR MAXIMUM REPLY LENGTH T0442000 BH S34OEXIA EXIT IF TOO LONG T0442500 EX R6,S34NMVCA MOVE OS FORMAT TEXT T0443000 BCTR R6,0 REDUCE ONE MORE (COULD GO MINUS) T0443500 B S34MINR SKIP NORMAL MOVE T0444000 S34NREPY CH R6,=Y(S34DTL) TEST FOR MAXIMUM REPLY LENGTH T0444500 BH S34OEXIA EXIT IF TOO LONG T0445000 BCTR R6,0 GET MACHINE COUNT T0445500 EX R6,S34NMVCO MOVE REPLY OUT T0446000 S34MINR LH R5,CBFCNT PICK UP COUNT T0446500 SH R5,=H'5' GET TEXT MACHINE LENGTH T0447000 EX R5,S34NMVCI MOVE TEXT BACK IN T0447500 OC S34DTXT,S34DTXTC UPPER CASE TEXT PART T0448000 LA R6,S34DTXT-S34DTIME+1(0,R6) GET FULL LENGTH T0448500 LA R5,L'S34DTEXT SET MAXIMUM LENGTH T0449000 CR R6,R5 CHECK FOR NOT TOO LONG T0449500 BNL S34RWOK IF TOO LONG ALLOW TRUNCATE T0450000 LR R5,R6 SET REAL LENGTH IN R5 T0450500 S34RWOK TIME DEC GET TIME OF DAY T0451000 ST R0,S34DWK PUT TIME IN WORK T0451500 ED S34DTIME-1(L'S34DTIME+1),S34DWK EDIT T0452000 EJECT R4 T0452100 *********************************************************************** T0452500 * * T0453000 * FIND CONTROLLING SJB * T0453500 * * T0454000 *********************************************************************** T0454500 L R3,CVTPTR POINT TO CVT T0455000 USING CVT,R3 T0455500 L R6,CVTCUCB POINT TO UCM T0456000 USING UCM,R6 T0456500 STM R11,R14,S34DSAV SAVE REGISTERS AROUND LOCK T0457000 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=(ORE,*-*,*-*) T0457500 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,RELATED=(ORE,*-*,*-*) T0458000 LM R11,R14,S34DSAV RESTORE REGISTERS T0458500 LA R6,UCMRPYQ-(ORELKP-OREF) POINT TO HEAD OF REPLY QUEUE T0459000 USING OREF,R6 T0459500 S34ORES ICM R6,15,ORELKP PICK UP NEXT ORE T0460000 BZ S34LABRT EXIT TO LOCKED ABORT T0460500 CLC OREID,S34DIGIT CHECK MATCHING DIGITS T0461000 BNE S34ORES LOOP T0461500 LH R1,OREASID PICK UP ASID T0462000 BAL R14,SFNDSJB FIND SJB VIA HAVT T0462500 B S34LABRT EXIT NOT FOUND +0 T0463000 B S34LABRT EXIT IF $WTO TASK +4 T0463500 LR R7,R1 POINT TO SJB +8 T0464000 USING SJBDSECT,R7 T0464500 L R1,OREWQE POINT TO WQE T0465000 TM WQEROUT2-WQE(R1),WQEROUTI IS SECURITY BIT ON T0465500 BZ S34SJBF SKIP SUPPRESSION IF NOT T0466000 MVC S34DTXT(10),=C'SUPPRESSED' T0466500 LA R5,S34DTXT-S34DTIME+10 GET LENGTH T0467000 S34SJBF MVC S34DJOB,SJBJOBID COPY JOBID T0467500 LA R1,S34DJOB+3 POINT TO JOB NUMBER T0468000 BAL R14,SBLKJOB BLANK HIGH ORDER DIGITS T0468500 S34SKBKL STH R5,S34DMSGL SET LENGTH OF TEXT T0469000 LA R5,S34DL SET T0469500 STH R5,S34DLN LENGTH OF ELEMENT T0470000 L R1,S34DCCEW POINT TO CCE T0470500 ST R7,CCESJB-CCEDSECT(,R1) SET OWNER OF CELL T0471000 EJECT R4 T0471100 *********************************************************************** T0471500 * * T0472000 * QUEUE ELEMENT TO SJB * T0472500 * * T0473000 *********************************************************************** T0473500 L R5,SJBLOGQ PICK UP LOG QUEUE HEAD T0474000 S34RPQS ST R5,S34DNEXT COPY TO OUR ELEMENT T0474500 CS R5,R8,SJBLOGQ QUEUE IT T0475000 BNE S34RPQS LOOP IF NOT QUEUED T0475500 LR R5,R13 SAVE CALLERS SAVE T0476000 LR R6,R12 SAVE OUR BASE T0476500 SETLOCK RELEASE,TYPE=CMS,RELATED=(ORE+SJB,*-*,*-*) T0477000 SETLOCK RELEASE,TYPE=LOCAL,RELATED=(ORE+SJB,*-*,*-*) T0477500 LR R13,R5 RESTORE SAVE T0478000 LR R12,R6 RESTORE OUR BASE T0478500 B S34OEXIT EXIT T0479000 *********************************************************************** T0479500 * * T0480000 * LOCKED ABORT OF REPLY ID SEARCHING EXIT * T0480500 * * T0481000 *********************************************************************** T0481500 S34LABRT DS 0H T0482000 * STM R11,R14,S34DSAV SAVE REGISTERS AROUND LOCK T0482500 SETLOCK RELEASE,TYPE=CMS,RELATED=(ORE,*-*,*-*) T0483000 SETLOCK RELEASE,TYPE=LOCAL,RELATED=(ORE,*-*,*-*) T0483500 LM R11,R14,S34DSAV RESTORE REGISTERS T0484000 EJECT T0484500 *********************************************************************** T0485000 * * T0485500 * EXIT WITH OS MESSAGE * T0486000 * * T0486500 *********************************************************************** T0487000 S34OEXIA LR R1,R8 POINT TO AREA T0487500 L R15,$SVFCELL POINT TO FREE CELL ROUTINE T0488000 BALR R14,R15 ENTER IT T0488500 S34OEXIT LA R15,SSCMSCMD SET RETURN CODE T0489000 S34EXIT ST R15,SSOBRETN SET RETURN CODE FOR CALLER T0489500 LM R14,R12,USAVER PICK UP CALLER REGISTERS T0490000 LA R15,SSRTOK SET NORMAL RETURN T0490500 BR R14 EXIT T0491000 *********************************************************************** T0491500 * * T0492000 * NO CELL - GET MORE STORAGE * T0492500 * * T0493000 *********************************************************************** T0493500 S34NCELL L R15,$SVGCMNS POINT TO CELL GET MAIN STORAGE T0494000 MODESET EXTKEY=HASP GET KEY 1 T0494500 BALR R14,R15 ENTER IT T0495000 MODESET EXTKEY=ZERO GET KEY 0 T0495500 LTR R1,R1 TEST FOR GOTTEN T0496000 BNE S34GCELL IF SO CONTINUE T0496500 B S34OEXIT EXIT T0497000 SPACE 1 R4 T0497100 S34NMVCO MVC S34DTXT(*-*),1(R7) *** EXECUTE ONLY *** R4 T0497200 S34NMVCA MVC S34DTXT-1(*-*),1(R7) *** EXECUTE ONLY *** R4 T0497300 S34NMVCI MVC CBFTEXT(*-*),S34DTEXT *** EXECUTE ONLY *** R4 T0497400 EJECT T0499000 *********************************************************************** T0499500 * * T0500000 * NOT NUMERIC FORM OF REPLY TRY 'R ' OR 'REPLY ' * T0500500 * * T0501000 *********************************************************************** T0501500 S34NN CLI 1(R4),C'R' COULD THIS BE A REPLY T0502000 BNE S34NRPLY EXIT IF NOT T0502500 LA R4,1(0,R4) POINT TO THE R T0503000 ICM R2,8,* SET HIGH ORDER BIT ON T0503500 CLC 1(4,R4),=C'EPLY' TEST FOR 'REPLY' T0504000 BNE S34NRSK SKIP REPLY COUNTING T0504500 LA R0,4 SET COUNT T0505000 AR R4,R0 UP 4 TO POINT TO THE Y T0505500 SR R5,R0 DOWN 4 T0506000 S34NRSK BCTR R5,0 REDUCE COUNT T0506500 LTR R5,R5 INSURE WE HAVE SOME TEXT T0507000 BNP S34OEXIT GIVE COMMAND TO OS IF NO MORE T0507500 CLI 1(R4),C' ' IS NEXT CHARACTER BLANK T0508000 BNE S34OEXIT GIVE COMMAND TO OS IF NOT T0508500 S34NRSBK LA R4,1(0,R4) UP 1 T0509000 BCT R5,S34NRTB TEST FOR MORE BLANKS T0509500 B S34OEXIT GIVE COMMAND TO OS IS NO MORE T0510000 S34NRTB CLI 1(R4),C' ' ARE THERE ANY MORE OPTIONAL BLANKS T0510500 BE S34NRSBK CONTINUE SCAN IF YES T0511000 CLI 1(R4),C'0' IS IT NUMERIC T0511500 BNL S34REPLY HANDLE NUMERIC PART IF YES T0512000 B S34OEXIT GIVE TO OS T0512500 S34NRPLY DS 0H T0513000 DROP R8 T0513500 DROP R7 T0514000 DROP R6 T0514500 DROP R3 T0515000 DROP R2 T0515500 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - SVC 34 EXIT - HASP COMMANDS' T0516000 *********************************************************************** T0516500 * * T0517000 * TEST FOR HASP COMMAND AND HANDLE ALL HASP COMMANDS * T0517500 * * T0518000 *********************************************************************** T0518500 CLC 1(1,R4),$SVCOMCH IS THIS A HASP COMMAND T0519000 BNE S34NH BR IF NOT HASP T0519500 CH R5,=Y(L'CMBMSG) CHECK FOR COMMAND TOO LONG T0520000 BH S34HER EXIT IF TOO LONG T0520500 CLC SSCMSCID-SSCMBGN(3,R9),=XL8'0' CHECK FOR ZEROS T0521000 BNE S34NH IF NOT CAN'T BE A UCMID T0521500 L R1,$SVCMBAC PICK UP ACTIVITY COUNT T0522000 LA R0,1(0,R1) UP THE ACTIVITY T0522500 CS R1,R0,$SVCMBAC STORE ACTIVITY T0523000 BNZ *-8 LOOP IF NOT SET T0523500 ICM R1,15,$SVHASP PICK UP HASP STATUS T0524000 BNZ S34HNUP EXIT IF HASP NOT UP T0524500 L R6,$SVCOMCT PICK UP CMB COUNT T0525000 S34HCTR LR R1,R6 PUT INTO WORK T0525500 BCT R1,S34HMOR COUNT THE COMMAND T0526000 B S34HERA SET RETURN CODE AND EXIT T0526500 *********************************************************************** T0527000 * * T0527500 * EXIT WITH UNABLE TO ACCEPT COMMAND * T0528000 * * T0528500 *********************************************************************** T0529000 S34HERR L R6,$SVCOMCT PICK UP COUNT T0529500 S34HERRL LA R1,1(0,R6) UP THE COUNT T0530000 CS R6,R1,$SVCOMCT STORE NEW VALUE T0530500 BNZ S34HERRL LOOP UNTIL TAKEN T0531000 S34HERA $$POST TYPE=CMB POST HASP CMB T0531500 S34HNUP L R1,$SVCMBAC PICK UP ACTIVITY COUNT T0532000 LR R0,R1 COPY T0532500 BCTR R0,0 REDUCE T0533000 CS R1,R0,$SVCMBAC STORE T0533500 BNZ *-8 LOOP IF NOT SET T0534000 S34HER LA R15,SSCMIMSG SET RETURN CODE T0534500 B S34EXIT RETURN T0535000 EJECT R4 T0535100 *********************************************************************** T0535500 * * T0536000 * GET A CMB * T0536500 * * T0537000 *********************************************************************** T0537500 S34HMOR CS R6,R1,$SVCOMCT SET NEW VALUE T0538000 BNE S34HCTR IF NO TAKE DO OVER T0538500 LM R2,R3,$SVCMBFQ PICK UP CMB Q HEAD T0539000 USING CMBDSECT,R2 T0539500 S34HQE LTR R2,R2 TEST FOR QUEUE EMPTY T0540000 BZ S34HCBNF TRY RESERVE BUFFER T0540500 L R0,CMBCMB POINT TO NEXT CMB R4 T0541000 LR R1,R3 COPY SECURITY WORD T0541500 CDS R2,R0,$SVCMBFQ DECHAIN T0542000 BNE S34HQE TRY AGAIN IF MISSED T0542500 B S34HCMBF GO TO FOUND ROUTINE T0543000 S34HCBNF ICM R2,15,$SVCMBRQ PICK UP CMB Q HEAD T0543500 BZ S34HERR EXIT IF EMPTY T0544000 L R0,CMBCMB POINT TO NEXT CMB R4 T0544500 CS R2,R0,$SVCMBRQ REMOVE CMB FROM RESERVE T0545000 BNE S34HCBNF LOOP (THIS SHOULD NOT HAPPEN) T0545500 S34HCMBF DS 0H T0546000 MVC CMBFLAG(14),S34HCMBH SET BASIC HEADER FOR CMB R4 T0546400 MVC CMBFM,$SVTO SET THIS SYSTEM AS SOURCE R4 T0546500 MVC CMBUCM,SSCMSCID+3-SSCMBGN(R9) MOVE UCMID INTO CMB R4 T0546600 *********************************************************************** T0547000 * * T0547500 * FIND MATCHING UCMID FOR AUTHORITY EXTRACTION * T0548000 * * T0548500 *********************************************************************** T0549000 L R6,CVTPTR POINT TO CVT T0549500 USING CVT,R6 T0550000 L R6,CVTCUCB POINT TO UCM T0550500 USING UCM,R6 T0551000 LM R7,R9,UCMVEA PICK UP SEARCH PARMS T0551500 DROP R6 T0552000 USING UCMLIST,R7 T0552500 S34HUTST CLC CMBUCM,UCMID LOOK FOR MATCHING UCMID R4 T0553000 BE S34HUFND EXIT IF FOUND T0553500 BXLE R7,R8,S34HUTST LOOP T0554000 MVC CMBDESC,S34HCMBH+(CMBDESC-CMBFLAG) SET DESCRIPTOR CODER4 T0555000 B S34NUCM SKIP UCM AUTH SETTINGS T0555500 *********************************************************************** T0556000 * * T0556500 * SET UCM AUTHORITY - HASP RESTRICTIONS * T0557000 * * T0557500 *********************************************************************** T0558000 S34HUFND SR R8,R8 ZERO WORK T0558500 IC R8,UCMAUTH PICK UP AUTHORIZATION BITS T0559000 SRL R8,5 ALIGN TO HASP BITS T0559500 STC R8,CMBFLAG SET FLAGS R4 T0560000 XI CMBFLAG,S34F7+CMBFLAGC+CMBFLAGU RESTRICTIONS AND FLAGSR4 T0560500 S34NUCM DS 0H T0561000 EJECT R4 T0561100 *********************************************************************** T0561500 * * T0562000 * COPY COMMAND INTO CMB * T0562500 * * T0563000 *********************************************************************** T0563500 MVI CMBMSG,C' ' BLANK OUT MESSAGE AREA T0564000 MVC CMBMSG+1(L'CMBMSG-1),CMBMSG DO REST T0564500 STC R5,CMBML STORE MESSAGE LENGTH R4 T0565000 BCTR R5,0 GET MACHINE LENGTH T0565500 EX R5,S34HMC MOVE HASP COMMAND T0566000 *********************************************************************** T0566500 * * T0567000 * QUEUE TO COMMAND PROCESSOR * T0567500 * * T0568000 *********************************************************************** T0568500 L R0,$SVCOMMQ PICK UP QUEUE HEAD T0569000 S34HQUE ST R0,CMBCMB SET CHAIN R4 T0569500 CS R0,R2,$SVCOMMQ QUEUE TO COMMAND PROCESSOR T0570000 BNE S34HQUE TRY AGAIN IF NOT QUEUED T0570500 *********************************************************************** T0571000 * * T0571500 * TELL HASP ABOUT THE COMMAND * T0572000 * * T0572500 *********************************************************************** T0573000 $$POST ELMT=$SVCOMM $$POST COMMAND PROCESSOR T0573500 L R1,$SVCMBAC PICK UP ACTIVITY COUNT T0574000 LR R0,R1 COPY T0574500 BCTR R0,0 REDUCE T0575000 CS R1,R0,$SVCMBAC STORE T0575500 BNZ *-8 LOOP IF NOT SET T0576000 S34HEXIT LA R15,SSCMSUBC SET RETURN CODE T0576500 B S34EXIT EXIT T0577000 SPACE 1 R4 T0577100 S34HMC MVC CMBMSG(*-*),1(R4) *** EXECUTE ONLY *** R4 T0577200 S34BMVC MVC 0(*-*,R6),2(R6) *** EXECUTE ONLY *** R4 T0577300 S34BMVF MVC 1(*-*,R6),2(R6) *** EXECUTE ONLY *** R4 T0577400 S34HCMBH $WTO MF=LX,JOB=NO,TYPE=SVC34,ROUTE=B'1000000000000000', R4CT0578600 CLASS=$ALWAYS,PRI=$HI R4 T0578700 DROP R2 T0579000 DROP R7 T0579500 DROP R10 T0580000 DROP R12 T0580500 S34NH EQU S34OEXIT EXIT IF NOT HASP COMMAND T0581000 LTORG @OZ34664 T0581200 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - SVC 35 EXIT' T0581500 *********************************************************************** T0582000 * * T0582500 * SVC 35 EXIT - SUBSYSTEM FUNCTION SSOBWTO * T0583000 * * T0583500 * FUNCTION * T0584000 * * T0584500 * RECEIVE CONTROL FROM THE OPERATING SYSTEM SVC 35 PROCESSING * T0585000 * ROUTINES AFTER THE WTO MESSAGE HAS BEEN COPIED TO A WQE FOR * T0585500 * THE PURPOSE OF EDITING THE FIELDS OF THE WQE AND COPYING JOB * T0586000 * ASSOCIATED MESSAGES TO THE USERS JOB LOG DATA SET ALONG WITH * T0586500 * MESSAGES QUEUED TO THE JOB'S SJB BY THE SVC 34 EXIT ROUTINE. * T0587000 * THE DESCRIPTION OF OPERATIONS FOLLOW. * T0587500 * * T0588000 * (1) DETERMINE THE TYPE OF WQE AND LOCATE THE LENGTH BTYE AND * T0588500 * TIME STAMP FIELDS FOR THE CURRENT MESSAGE, IF THE MESSAGE * T0589000 * CONTAINS NO DATA (MLWTO LINE TYPE X'80', X'40', AND X'20' * T0589500 * FLAGS OFF) NO FURTHER PROCESSING IS PERFORMED. SINCE MINOR * T0590000 * WQES DO NOT HAVE PRE TEXT FIELDS THE ADDRESS IS PROJECTED * T0590500 * BASED UPON THE TEXT FIELD OF THE CURRENT MINOR TEXT LINE. * T0591000 * * T0591500 * (2) THE USERS ASID IS PICKED UP FROM THE CURRENT ASCB AND * T0592000 * IS USED TO DETERMINE IF THE WQE REPRESENTS A MESSAGE FROM * T0592500 * THE HASP COMMUNICATIONS TASK (HASPCON CSECT), THE HASP * T0593000 * CONVERSION TASK (HASPXEQ CSECT), A USER TASK RUNNING IN * T0593500 * A MEMORY CONTROLLED BY HASP (THE HAVT HAS SJBS FOR THE * T0594000 * USER). * T0594500 * * T0595000 * (3) IF THE MESSAGE IS FROM THE HASP COMMUNICATIONS TASK, THE * T0595500 * WQE IS NOT MLWTO, AND THE SVC 35 REQUESTOR IS RUNNING * T0596000 * OFF THE LAST RB, THEN THE JOB ID FIELD IS MOVED INTO THE JOB * T0596500 * IDENTIFICATION FIELD. * T0597000 * * T0598000 * (4) IF THE MESSAGE IS FROM THE CONVERSION TASK OR HASP * T0598500 * CONTROLLED USER TASK, A WORK AREA IS GOTTEN AND THE * T0599000 * TIME STAMP AND JOB ID FIELDS ARE PRIMMED WITH BLANKS. IF * T0599500 * THE WQE IS NOT A MINOR, THE USER JOBID IS INSERTED INTO * T0600000 * THE WQE AND TIME STAMP AND JOB ID ARE COPIED INTO THE * T0600500 * WORK AREA, IF THE USER TEXT STARTS WITH '$', THE FLAG BYTE * T0601000 * IS NOT '@', AND THE WQE IS NOT MLWTO, THE WORK AREA TEXT * T0601500 * IS FILLED WITH THE FLAG BYTE ('*' OR ' '), MESSAGE ID * T0602000 * ('$ ' OR '$HASPXXX '), JOBNAME (FROM SJB), AND REST OF TEXT. * T0602500 * THE COMBINED MESSAGE IS COPIED BACK INTO THE WQE AND THE * T0603000 * LENGTH IS ADJUSTED, IF THE USER TEXT DOES NOT START WITH * T0603500 * '$' ETC., THE MESSAGE TEXT IS COPIED TO THE WORK AREA. * T0604000 * IF THE EDITED MESSAGE IS 'IEA960I', ADDITIONAL PROCESSING * T0604500 * IS SKIPPED. OTHERWISE, A STEP ORIENTED ENQ (Q NAME IN THE * T0605000 * $SVQNAM FIELD AND R NAME 'WTO') IS ISSUED TO SERIALIZE ON * T0605500 * THE SJB LOG QUEUE REMOVAL AND USE OF THE SJB LOG DATA SET. * T0606000 * * T0606500 *********************************************************************** T0607000 EJECT T0607500 *********************************************************************** T0608000 * * T0608500 * THE 'USE' OPTION IS USED TO CAUSE MESSAGES ISSUED @OZ34664 T0609000 * BECAUSE OF ASYNCHRONOUS PROCESSING TO REMAIN CHAINED @OZ34664 T0609250 * ON SJBLOGQ. IF THE ENQ IS OBTAINED, THE LOG MSGS @OZ34664 T0609500 * ARE COPIED TO THE LOG DATA SET (FREEING THE QUEUE * T0610000 * ELEMENTS). THE MESSAGE WITHIN THE WORK AREA IS COPIED, * T0610500 * DEQ ISSUED, AND THE WORK AREA FREED. * T0611000 * * T0611500 * (5) CONTROL IS RETURNED TO OS SVC 35 PROCESSING ALLOWING THE * T0612000 * DISPLAY OF THE MESSAGE. * T0612500 * * T0613000 * INPUT REGISTERS * T0613500 * R0 = ADDRESS OF SSCVT * T0614000 * R1 = ADDRESS OF SSOB * T0614500 * R13 = SAVE AREA * T0615000 * R14 = RETURN * T0615500 * R15 = ENTRY BASE * T0616000 * * T0616500 * OUTPUT REGISTERS * T0617000 * * T0617500 * R0-R14= UNCHANGED * T0618000 * R15 = RETURN CODE * T0618500 * * T0619000 * NOTES * T0619500 * * T0620000 * (1) NULL LINE PROCESSING FOR MLWTO IS NOT USED IN THIS VERSION. * T0620500 * * T0621000 * (2) WTO DELETION CAPABILITY IS NOT USED IN THIS VERSION. * T0621500 * * T0622000 *********************************************************************** T0622500 EJECT T0623000 *********************************************************************** T0623500 * * T0624000 * ENTRY TO SVC 35 EXIT - PICK UP PARAMETERS * T0624500 * * T0625000 *********************************************************************** T0625500 HOSWTO $ENTRY BASE=R15,ENTRY=NO PROVIDE ENTRY FOR ROUTINE T0626000 S35 EQU HOSWTO T0626500 STM R14,R12,USAVER SAVE CALLER'S REGISTERS T0627000 LR R12,R15 ESTABLISH BASE T0627500 USING S35,R12 T0628000 DROP R15 T0628500 LR R8,R0 POINT TO SSCVT T0629000 USING SSCT,R8 T0629500 L R11,SSCTSSVT POINT TO SSVT T0630000 LR R10,R1 POINT TO SSOB T0630500 USING SSOB,R10 T0631000 L R5,SSOBINDV POINT TO PARMS T0631500 USING SSWTBGN,R5 T0632000 LM R5,R7,SSWTWQE PICK UP PARMS T0632500 * R5 = WQE, NORMAL OR MAJOR T0633000 * R6 = MINOR WQE OR ZERO T0633500 * R7 = ORE OR ZERO T0634000 USING WQE,R5 T0634500 MVI USAVFL,0 ZERO TEMPORARY FLAGS T0635000 EJECT T0635500 *********************************************************************** T0636000 * * T0636500 * SETUP FOR NORMAL WQE * T0637000 * * T0637500 *********************************************************************** T0638000 LA R3,WQETS POINT TO TIME STAMP T0638500 LA R4,WQENBR+3 POINT TO LENGTH T0639000 TM WQENBR,WMJMMLWB IS THIS MAJOR WQE T0639500 BZ S35NORML IF NOT MUST BE NORMAL T0640000 *********************************************************************** T0640500 * * T0641000 * SETUP FOR MAJOR WQE * T0641500 * * T0642000 *********************************************************************** T0642500 MVI USAVFL,USAVFLM SET MLWTO FLAG T0643000 LA R3,WMJMTS POINT TO TIME STAMP T0643500 LA R4,WMJMTXTL+1 POINT TO LENGTH T0644000 TM WMJMLTYP,X'E0' DOES THE WQE CONTAIN A MESSAGE T0644500 BZ S35EXIT EXIT IF NO T0645000 LTR R5,R6 TEST FOR CURRENT LINE IN MINOR T0645500 BZ S35NORML CONTINUE IF NOT MINOR T0646000 *********************************************************************** T0646500 * * T0647000 * SETUP FOR MINOR WQE * T0647500 * * T0648000 *********************************************************************** T0648500 MVI USAVFL,USAVFLM+USAVFLMI SET MINOR FLAG T0649000 LA R2,WMNMLT1 POINT TO LINE TYPE, LINE 1 T0649500 LA R3,WMNMTXT1 POINT TO TEXT, LINE 1 T0650000 LA R0,WQETXT-WQETS GET OFFSET FOR MINOR T0650500 SLR R3,R0 POINT TO TIME STAMP, LINE 1 T0651000 LA R4,WMNMTL1 POINT TO LENGTH, LINE 1 T0651500 TM WMNMML2,WMNMML2H TEST FOR LINE 2 AVAILABLE T0652000 BO S35MINOR SKIP NEXT IF YES T0652500 LA R2,WMNMLT2 POINT TO LINE TYPE, LINE 2 T0653000 LA R3,WMNMTXT2-(WQETXT-WQETS) POINT TO TS, LINE 2 T0653500 LA R4,WMNMTL2 POINT TO LINE LENGTH, LINE 2 T0654000 S35MINOR TM 0(R2),X'E0' IS THERE DATA IN LINE T0654500 BZ S35EXIT EXIT IF NO T0655000 EJECT T0655500 *********************************************************************** T0656000 * * T0656500 * PREPARE TO EDIT WQES * T0657000 * * T0657500 *********************************************************************** T0658000 S35NORML SLR R2,R2 ZERO MOVE COUNT T0658500 IC R2,0(0,R4) PICK UP LENGTH OF TEXT T0659000 USING WQETS,R3 T0659500 L R1,PSAAOLD-PSA POINT TO ASCB T0660000 LH R1,ASCBASID-ASCB(,R1) PICK UP ASID T0660500 BAL R14,SFNDSJB FIND SJB VIA HAVT T0661000 B S35EXIT IGNORE MESSAGE +0 T0661500 B S35SHIFT SHIFT HASP MESSAGE +4 T0662000 LR R6,R1 POINT TO SJB +8 T0662500 USING SJBDSECT,R6 T0663000 B S35GWK GET WORK AREA T0663500 S35SHIFT L R1,PSATOLD-PSA POINT TO TCB R4 T0665000 L R14,TCBRBP-TCB(,R1) POINT TO OUR RB T0665500 L R15,RBGRS1-RBBASIC(,R14) POINT TO POSSIBLE CSA R4 T0665600 L R14,RBLINK-RBBASIC(,R14) POINT TO WHAT SHOULD BE PRB T0666000 CLM R1,7,RBLINKB-RBBASIC(R14) DOES IT POINT TO TCB T0666500 BNE S35EXIT SKIP EDIT IF NOT T0667000 TM USAVFL,USAVFLMI MLWTO MINOR LINE R4 T0667500 BO S35EXIT SKIP EDIT IF YES R4 T0668000 CLC $SVTO,CSANFM-CSADSECT(R15) THIS FROM OUR SYSTEM R4 T0668100 BE S35WQEE EDIT WQE IF YES R4 T0668200 MVC WQETS,CSATS-CSADSECT(R15) CLOBBER OS TIME STAMP R4 T0668300 B S35SJID SKIP EDIT R4 T0668400 S35WQEE BAL R14,S35HIDS EDIT WQE R4 T0668500 S35SJID MVC WQEJOBNM,CSAJOBID-CSADSECT(R15) SET JOB ID R4 T0669000 B S35EXIT EXIT T0672500 S35HIDS MVC S35WQEID,$SVCOMCH SET MESSAGE ID SAME AS COMMAND R4 T0672600 CLI 0(R4),S35HIDL CHECK LENGTH GT MSG ID @OZ19488 T0672635 BNH S35EXIT4 IF ONLY MSG ID, DELETE WQE @OZ19488 T0672670 TM $SVSTUS,$SVSTIDS REQUIRE HASP IDS R4 T0672700 BOR R14 RETURN IF YES R4 T0672800 LA R0,S35HIDL+1 SET ADJUSTMENT R4 T0672900 SLR R2,R0 SET MACHINE COUNT OF REMAINING TEXT T0673000 EX R2,S35HIDSM CLOBBER OUR MESSAGE ID R4 T0673100 LA R2,3(,R2) UP TO TRUE MESSAGE LENGTH R4 T0673200 STC R2,0(,R4) SET LENGTH R4 T0673300 LA R1,WQETXT(R2) POINT TO RESIDUE R4 T0673400 MVC 0(S35HIDL-2,R1),=CL(S35HIDL-2)' ' BLANK IT R4 T0673500 BR R14 RETURN R4 T0673600 EJECT R4 T0673700 *********************************************************************** T0673800 * * T0673900 * GET WORK AREA * T0674000 * * T0674500 *********************************************************************** T0675000 S35GWK LA R0,S35DL GET DATA LENGTH T0675500 GETMAIN RC,LV=(0),SP=URASP GET STORE PROTECTED WORK AREA T0676000 LTR R15,R15 TEST FOR GOTTEN T0676500 BNZ S35EXIT IF NOT GOTTEN FORGET IT T0677000 LR R8,R1 POINT TO AREA T0677500 USING S35DSECT,R8 T0678000 MVC S35DTIME(S35DACTF-S35DTIME),=CL(S35DACTF-S35DTIME)' ' T0678500 TM USAVFL,USAVFLMI TEST FOR MINOR T0679000 BO S35NJBTS SKIP JOB NUMBERING AND TIME STAMPING T0679500 MVC WQEJOBNM,SJBJOBID MOVE JOB ID T0680000 LA R1,WQEJOBNM+3 POINT TO NUMERIC PART T0680500 BAL R14,SBLKJOB BLANK HIGH DIGITS T0681000 MVC S35DTIME(S35DACTF-S35DTIME),WQETS INSERT TIME AND JOB ID T0681500 S35NJBTS CLI S35WQEID,C'$' IS THIS OF HASP ORIGIN T0682000 BE *+14 BR IF YES @OZ30033 T0682100 CLC S35WQEID,$SVCOMCH MSG EDITED BY $$WTO... @OZ30033 T0682200 BNE S35NHASP IF NOT SKIP SPECIAL EDIT T0682500 CLC PSAAOLD-PSA,$SVPOSTE+4 CHECK FOR HASP ASID R4 T0682600 BE S35HASP SKIP NEXT IF HASP ASID @OZ30033 T0682700 L R1,PSATOLD-PSA POINT TO TCB R4 T0682800 L R14,TCBRBP-TCB(,R1) POINT TO OUR RB R4 T0682900 L R14,RBLINK-RBBASIC(,R14) POINT TO CALLING RB R4 T0683000 CLC RBOPSW+5-RBBASIC(3,R14),=AL3(SENTRIES) CHECK RANGE R4 T0683100 BL S35NHASP SKIP HASPSSSM EDIT IF LOW R4 T0683200 CLC RBOPSW+5-RBBASIC(3,R14),=AL3(SSMPATCH) CHECK RANGE R4 T0683300 BH S35NHASP SKIP HASPSSSM EDIT IF HIGH R4 T0683400 CLI WQETXT,C'@' IS THIS PROBLEM PROGRAM ACTION T0683500 BE S35NHASP SKIP SPECIAL EDIT IF YES T0683600 TM USAVFL,USAVFLM IS THIS MLWTO T0684000 BO S35NHASP HASPSSSM DOES NOT ISSUE MLWTOS T0684500 S35HASP CLI S35WQEID+1,C' ' HASP ID PRESENT... @OZ30033 T0684510 BNE S35NSSSM BR IF YES @OZ30033 T0684520 CH R2,=Y(L'S35DACTF+L'S35DHID-7) COUNT VALID... @OZ30033 T0684530 BNP S35EXIT5 BR IF NO TO SKIP EDIT @OZ36122 T0684540 MVC S35DTXT,S35WQEID+1 SHIFT TEXT RIGHT TO @OZ30033 T0684550 MVC S35WQEHT-1(S35DTXTL),S35DTXT ALLOW FOR MSG ID @OZ30033 T0684560 LA R2,S35HIDL-2(,R2) UPDATE LENGTH @OZ30033 T0684570 EJECT R4 T0684600 S35NSSSM MVC S35DACTF(L'S35DACTF+L'S35DHID),WQETXT MOVE HEADER R4 T0684700 MVC S35DJOBN,SJBJOBNM MOVE JOB NAME T0686000 LA R0,L'S35DACTF+L'S35DHID GET ADJUSTMENT T0686500 SR R2,R0 ADJUST COUNT T0687000 BNP S35EXIT5 FORGET EDIT @OZ36122 T0687500 LA R0,S35DTXTL GET MAXIMUM COUNT T0688000 CR R2,R0 TEST MAXIMUM EXCEEDED T0688500 BNH *+6 SKIP TRUNCATION IF OK T0689000 LR R2,R0 TRUNCATE T0689500 EX R2,S35MVO MOVE TEXT OUT T0690000 LA R2,S35DTXT-S35DACTF(,R2) GET TOTAL LENGTH OF TEXT T0690500 STC R2,0(,R4) SET NEW LENGTH. T0691000 BCTR R2,0 REDUCE COUNT T0691500 EX R2,S35MVI MOVE TEXT IN T0692000 LR R15,R2 SAVE MACHINE LENGTH OF TEXT R4 T0692100 LA R2,1(,R2) GET TRUE LENGTH R4 T0692200 BAL R14,S35HIDS EDIT WQE R4 T0692300 TM $SVSTUS,$SVSTIDS REQUIRE HASP IDS... @OZ30033 T0692320 BO S35RLEN BR IF YES @OZ30033 T0692340 SH R2,=H'3' GET MACHINE LENGTH OF TEXT @OZ30033 T0692360 EX R2,S35HIDRM OVERLAY MSG ID @OZ30033 T0692380 LA R1,S35DACTF+3(R2) POINT TO RESIDUE @OZ30033 T0692400 MVC 0(S35HIDL-2,R1),=CL(S35HIDL-2)' ' BLANK IT @OZ30033 T0692420 S35RLEN LR R2,R15 RESTORE MSG LENGTH @OZ30033 T0692440 B S35GL SKIP WHOLE TEXT MOVE OUT T0692500 S35NHASP BCTR R2,0 REDUCE COUNT T0693000 EX R2,S35MVW MOVE WHOLE TEXT T0693500 S35GL LA R2,S35DACTF-S35DMSG+1(,R2) GET ENTIRE MESSAGE LENGTH T0694000 LA R0,S35DMAX SET MAXIMUM SIZE T0694500 CR R2,R0 TEST FOR TOO LONG T0695000 BNH *+6 IF SAFE SKIP NSI T0695500 LR R2,R0 TRUNCATE T0696000 STH R2,S35DMSGL SET NEW LENGTH T0696500 MVC S35DID,S35ID SET BUFFER ID @OZ34664 T0696510 SPACE 2 @OZ34664 T0696520 ************************************************************* @OZ34664 T0696530 * QUEUE WTO MESSAGE TO SJBLOGQ FOR POSSIBLE @OZ34664 T0696540 * LATER PROCESSING @OZ34664 T0696550 ************************************************************* @OZ34664 T0696560 L R5,SJBLOGQ PICK UP LOG QUEUE HEAD @OZ34664 T0696600 S35QLOOP ST R5,S35DNEXT COPY TO OUR ELEMENT @OZ34664 T0696700 CS R5,R8,SJBLOGQ QUEUE IT @OZ34664 T0696800 BNE S35QLOOP LOOP IF NOT QUEUED @OZ34664 T0696900 EJECT @OZ34664 T0696950 *********************************************************************** T0697000 * * T0697500 * CLEAN OUT SJB LOG QUEUE * T0698000 * * T0698500 *********************************************************************** T0699000 CLC WQETXT+1(7),=C'IEA960I' IS THIS ENQ DISASTER MESSAGE T0699500 BE S35EXIT SKIP LOG IF SO @OZ34664 T0700000 SPACE 2 @OZ34664 T0700100 LA R0,ULEN GET ENQ/DEQ AREA LENGTH @OZ34664 T0700200 GETMAIN RC,LV=(0),SP=253 GET STORAGE FOR WORKAREA @OZ34664 T0700300 LTR R15,R15 TEST RETURN FROM GETMAIN @OZ34664 T0700400 BNZ S35EXIT QUIT HERE IF NO STORAGE @OZ34664 T0700500 LR R8,R1 SAVE WORKAREA ADDRESS @OZ34664 T0700600 ST R8,UOURSAV POINT CALLER SAVE TO OURS @OZ34664 T0700700 DROP R13 DROP OLD SAVEAREA ADDRESS @OZ34664 T0700800 USING USAVE,R8 ADDRESS OUR WORKAREA @OZ34664 T0700900 ST R13,UCALLER POINT TO CALLER SAVE @OZ34664 T0701000 MVC UDENQ(S35PATL),S35PATRN MOVE PATTERN ENQ @OZ34664 T0701500 ESTAE PARAM=(R8),MF=(E,UESTAE) PROVIDE REC. ENVIRON. @OZ36122 T0701700 ENQ ($SVQNAM,UDRN),MF=(E,UDENQ) ENQ ON ONE SJB @OZ34664 T0702000 LTR R15,R15 DO WE HAVE CONTROL T0702500 BNZ S35FREE IF NOT, FORGET IT @OZ34664 T0703000 LR R13,R8 USE OUR SAVE AREA @OZ34664 T0703500 S35CLNPT ICM R5,15,SJBLOGQ POINT TO QUEUED MESSAGES T0704000 USING S34DSECT,R5 T0704500 BZ S35DEQ IF EMPTY,PREPARE TO EXIT @OZ34664 T0705000 LA R4,SJBLOGQ-(S34DNEXT-S34DSECT) T0705500 S35QSRLL ICM R1,15,S34DNEXT POINT TO NEXT T0706000 BZ S35QEND IF END, BR T0706500 LR R4,R5 BRING UP REAR T0707000 LR R5,R1 POINT TO NEXT T0707500 B S35QSRLL LOOP T0708000 S35QEND CS R5,R1,S34DNEXT-S34DSECT(R4) REMOVE FROM END T0708500 BNE S35QSRLL TRY AGAIN IF NO GO T0709000 CLC S35ID,S35DID-S35DSECT(R5) SVC35 BUFFER... @OZ34664 T0709100 BE S35PMSG YES, GO PUT IT @OZ34664 T0709200 * PUT SVC 34 MESSAGE @OZ34664 T0709300 LH R0,S34DMSGL PICK UP LENGTH T0709500 USING RPLDSECT,R1 T0710000 LA R1,SJBLRPL POINT TO RPL T0710500 ST R0,RPLRLEN SET LENGTH T0711000 LA R0,S34DTIME POINT TO TEXT T0711500 ST R0,RPLAREA SET AREA T0712000 TM SJBFLG2,SJB2INIT INITIATOR SJB... R41 T0712300 BO S35INIT1 SKIP PUT IF YES R41 T0712400 PUT RPL=(1) LOG DATA T0712500 DROP R1 T0713000 S35INIT1 DS 0H R41 T0713300 LR R1,R5 POINT TO AREA T0713500 L R15,$SVFCELL POINT TO FREE CELL ROUTINE T0714000 BALR R14,R15 ENTER IT T0714500 B S35CLNPT CLEAN OUT SJB QUEUE T0715000 EJECT T0715500 *********************************************************************** T0716000 * * T0716500 * PUT SVC 35 MESSAGE ON LOG DATA SET * T0717000 * * T0717500 *********************************************************************** T0718000 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0718200 USING S35DSECT,R5 @OZ34664 T0718300 S35PMSG LH R0,S35DMSGL PICK UP LENGTH T0718500 USING RPLDSECT,R1 T0719000 LA R1,SJBLRPL POINT TO RPL T0719500 ST R0,RPLRLEN SET LENGTH T0720000 LA R0,S35DTIME POINT TO DATA T0720500 ST R0,RPLAREA SET AREA T0721000 TM SJBFLG2,SJB2INIT INITIATOR SJB... R41 T0721300 BO S35INIT2 SKIP PUT IF YES R41 T0721400 PUT RPL=(1) LOG DATA T0721500 DROP R1 T0722000 S35INIT2 DS 0H R41 T0722300 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0722400 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0722500 LA R0,S35DL GET LENGTH OF AREA @OZ34664 T0722600 ICM R0,8,=AL1(URASP) SET SUBPOOL NUMBER @OZ34664 T0722700 LR R1,R5 POINT TO AREA @OZ34664 T0722800 FREEMAIN R,LV=(0),A=(1) FREE AREA @OZ34664 T0722900 B S35CLNPT CLEAN OUT SJB QUEUE @OZ34664 T0723000 SPACE 2 @OZ34664 T0723100 * THIS LINE DELETED BY APAR NUMBER @OZ34664 T0723200 S35DEQ DS 0H @OZ34664 T0723300 * THIS LINE DELETED BY APAR ===> @OZ44947 T0723330 * THIS LINE DELETED BY APAR ===> @OZ44947 T0723360 DEQ RET=NONE,MF=(E,UDENQ) RELEASE SJB @OZ34664 T0723400 S35FREE ESTAE 0 TERMINATE ESTAE @OZ36122 T0723450 LA R0,ULEN GET LENGTH OF ENQ/DEQ AREA @OZ36122 T0723500 ICM R0,8,=AL1(253) SET SUBPOOL NUMBER @OZ34664 T0724000 L R13,UCALLER RESTORE CALLER'S SAVEAREA @OZ34664 T0724100 DROP R8 USE OUR SAVE AREA @OZ34664 T0724200 USING USAVE,R13 USE CALLER'S SAVE AREA @OZ34664 T0724300 LR R1,R8 POINT TO AREA T0724500 FREEMAIN R,LV=(0),A=(1) FREE AREA T0725000 S35EXIT LA R15,SSWTRTOK SET RETURN CODE T0725500 S35EXITA ST R15,SSOBRETN PUT INTO FEED BACK T0726000 LM R14,R12,USAVER RESTORE CALLER REGISTERS T0726500 LA R15,SSRTOK SET NORMAL RETURN T0727000 BR R14 EXIT T0727500 SPACE 1 R4 T0727600 S35EXIT4 LA R15,SSWTNDSP TELL IEAVVWTO TO @OZ19488 T0727625 B S35EXITA DELETE MSG @OZ19488 T0727650 * ERROR FOUND IN FORMATTING S35 WORK AREA @OZ36122 T0727655 S35EXIT5 LA R0,S35DL GET LENGTH OF AREA @OZ36122 T0727660 ICM R0,8,=AL1(URASP) SET SUBPOOL NUMBER @OZ36122 T0727665 LR R1,R8 POINT TO AREA @OZ36122 T0727670 FREEMAIN R,LV=(0),A=(1) FREE AREA @OZ36122 T0727675 B S35EXIT RETURN TO CALLER @OZ36122 T0727680 SPACE 1 @OZ36122 T0727685 USING S35DSECT,R8 ACCESS CURRENT SVC35 BUFF @OZ34664 T0727690 S35HIDSM MVC S35WQEID+1(*-*),S35WQEID+S35HIDL-1 *** EXEC ONLY *** R4 T0727700 S35HIDRM MVC S35DHID+1(*-*),S35DJOBN-1 *** EXEC ONLY *** @OZ30033 T0727750 S35MVW MVC S35DACTF(*-*),WQETXT *** EXECUTE ONLY *** R4 T0727800 S35MVI MVC WQETXT(*-*),S35DACTF *** EXECUTE ONLY *** R4 T0727900 S35MVO MVC S35DTXT-1(*-*),S35WQEHT-1 *** EXECUTE ONLY *** R4 T0728000 URASP EQU 255 EXPLICITLY ASSIGNED LSQA @OZ34664 T0730000 DROP R3 T0730500 DROP R5 T0731000 DROP R6 T0731500 DROP R8 T0732000 DROP R10 T0732500 DROP R12 T0733000 DROP R13 DROP OLD USAVE ADDRESS. @OZ36122 T0733200 EJECT T0733500 *********************************************************************** T0734000 * * T0734500 * MISCELLANEOUS * T0735000 * * T0735500 *********************************************************************** T0736000 S34F7 EQU CMBFLAGJ+CMBFLAGD+CMBFLAGS R4 T0736500 CSAFP EQU 231 COMMON SERVICE AREA PROTECTED POOL T0737000 EJECT T0737500 *********************************************************************** T0738000 * * T0738500 * ITEMS MOVED INTO SVC 34 OR 35 QUEUE WORK AREA * T0739000 * * T0739500 *********************************************************************** T0740000 S35PATRN ENQ (*-*,*-*,E,3,STEP),RET=USE,MF=L @OZ34664 T0740500 DC C'WTO' R NAME FOR WTO LOGGING T0741000 ESTAE UESTAER,TERM=YES,RECORD=YES,MF=(L) @OZ36122 T0741200 S35PATL EQU *-S35PATRN T0741500 S35ID DC CL4'S35D' IDENTIFIER FOR SVC35 BUFF. @OZ34664 T0741600 S34TIME DC X'F021204B20204B202040' @OZ33128 T0742000 DC CL10'JOB' JOB NNNN-- T0742500 DC C'R 00,' T0743000 S34DTXTC DC CL(L'S34DTXT)' ' T0743500 S34TL EQU *-S34TIME T0744000 *********************************************************************** T0744500 * * T0745000 * SUBROUTINE TO BLANK HIGH ORDER ZEROS OF JOB NUMBER * T0745500 * * T0746000 *********************************************************************** T0746500 SBLKJOB LA R0,4 SUPPRESS UP TO 4 DIGITS T0747000 BALR R15,0 ESTABLISH BASE T0747500 S34BKL CLI 0(R1),C'0' IS THIS ZERO T0748000 BCR NE,R14 SKIP BLANKING T0748500 MVI 0(R1),C' ' BLANK T0749000 LA R1,1(0,R1) UP TO NEXT T0749500 BCTR R0,R15 LOOP T0750000 BR R14 RETURN T0750500 EJECT T0751000 *********************************************************************** T0751500 * * T0752000 * SUBROUTINE TO LOCATE SJB FOR SVC 34 AND 35 SUPPORT * T0752500 * * T0753000 *********************************************************************** T0753500 SFNDSJB LR R0,R1 COPY ASID T0754000 BCTR R0,0 REDUCE BY ONE T0754500 LTR R0,R0 INSURE ASID GREATER THAN ONE T0755000 BNPR R14 EXIT TO IGNORE ROUTINE T0755500 BALR R15,0 ESTABLISH BASE T0756000 USING *,R15 T0756500 CLC PSAAOLD-PSA,$SVPOSTE+4 CHECK FOR HASP ASCB T0757000 BNE SFNDSJBA DO NORMAL PICK UP IF NOT T0757500 ICM R0,15,$SVHASP HASP STILL UP T0758000 BNER R14 EXIT TO IGNORE IF NOT T0758500 LR R0,R1 SAVE ASID T0759000 L R1,$SVHCT POINT TO HCT T0759500 CLC PSATOLD-PSA,$WTOTCBA-HCTDSECT(R1) IS THIS $WTO T0760000 BE 4(0,R14) RETURN TO $WTO ROUTINE HANDLER T0760500 CLC PSATOLD-PSA,$CNVTCBA-HCTDSECT(R1) IS THIS CONVERTER T0761000 BNER R14 EXIT TO IGNORE ROUTINE T0761500 LR R1,R0 RESTORE ASID T0762000 SFNDSJBA SLL R1,2 GET ASID * 4 ( WORD/ASID ) T0762500 AL R1,$SVHAVT POINT TO VECTOR TABLE ENTRY T0763000 L R0,0(0,R1) POINT TO SJB T0763500 SFNDSJBB LTR R1,R0 COPY POINTER T0764000 BZR R14 RETURN TO IGNORE IF NO SJB T0764500 L R0,SJBSJB-SJBDSECT(,R1) POINT TO NEXT LOWER T0765000 LTR R0,R0 TEST FOR END T0765500 BNZ SFNDSJBB LOOP IF NOT T0766000 B 8(0,R14) RETURN TO CONTINUE ROUTINE T0766500 DROP R15 T0767000 EJECT @OZ36122 T0767010 ************************************************************* @OZ36122 T0767020 * @OZ36122 T0767030 * ESTAE EXIT FOR HOSWTO @OZ36122 T0767040 * @OZ36122 T0767050 ************************************************************* @OZ36122 T0767060 USING SDWA,R1 PROVIDE SDWA ADDRESS. @OZ36122 T0767070 USING USAVE,R2 PROVIDE USAVE ADDRESS. @OZ36122 T0767080 USING UESTAER,R12 PROVIDE UESTAER ADDRESS. @OZ36122 T0767090 UESTAER LR R12,R15 TEST TO SEE... @OZ36122 T0767100 C R0,=F'12' IF SDWA OBTAINED... @OZ36122 T0767105 BE UESTA2 BRANCH IF NO. @OZ36122 T0767110 L R2,SDWAPARM LOAD R2 WITH @ OF WORKAREA @OZ36122 T0767115 UESTA2 LR R3,R14 SAVE RETURN ADDRESS @OZ36122 T0767120 LR R4,R1 SAVE SDWA ADDRESS @OZ36122 T0767125 DEQ RET=HAVE,MF=(E,UDENQ) ISSUE DEQUEUE @OZ36122 T0767135 XR R15,R15 CLEAR REGISTER 15 @OZ36122 T0767140 LR R1,R4 RESTORE SDWA ADDRESS @OZ36122 T0767145 BR R3 RETURN TO CALLER @OZ36122 T0767150 DROP R1 DROP ADDRESSIBILITY @OZ36122 T0767155 DROP R2 DROP ADDRESSIBILITY @OZ36122 T0767160 DROP R12 DROP ADDRESSIBILITY @OZ36122 T0767165 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - PROCESS SYSOUT' T0767500 *********************************************************************** T0768000 * * T0768500 * PROCESS SYSOUT - SUBSYSTEM FUNCTION SSOBSOUT * T0769000 * * T0769500 * FUNCTION * T0770000 * * T0770500 * RECEIVE CONTROL FROM THE OPERATING SYSTEM OUTPUT COMMAND * T0771000 * PROCESSOR OR THE EXTERNAL WRITER FOR THE PURPOSE OF INTERFACING * T0771500 * WITH THE PROCESS SYSOUT SUPPORT ROUTINES IN HASPXEQ TO RETRIEVE * T0772000 * DATA SETS QUEUED TO THE HELD DATA SET QUEUE OR READY FOR * T0772500 * NORMAL OUTPUT AS APPROPRIATE AND DISPOSING OF THOSE DATA SETS * T0773000 * EITHER BY USE OF DATA MANAGEMENT FACILITIES TO RETRIEVE THE * T0773500 * DATA OR BY USE OF THIS INTERFACE TO RELEASE OR DELETE THE * T0774000 * DATA SETS. THE FUNCTIONAL OPERATIONS ARE DESCRIBED BELOW. * T0774500 * * T0775000 * (1) A $PROLOG MACRO INSTRUCTION IS EXECUTED TO GET CONTROL * T0775500 * OF THE USERS SJB (REQUESTOR MUST BE ONE OF OUR JOBS). * T0776000 * * T0776500 * (2) IF THE SJB DOES NOT HAVE A PROCESS SYSOUT (PSO) WORK AREA, * T0777000 * THE REQUEST IS IGNORED (CONSIDERED A NOP), IF THE SSSOCTRL * T0777500 * FLAG IS ON AND THE SSSOUFLG BYTE IS ZERO. IF REQUEST NOT * T0778000 * IGNORED A PSO WORK AREA IS CREATED AND QUEUED TO THE SJB * T0778500 * USING AN SJB OWNED STORAGE CELL. * T0779000 * * T0779500 * (3) DESTINATION IS CONVERTED TO ROUTE CODE AND JOB ID IS * T0780000 * CONVERTED TO JOB NUMBER AS REQUESTED. * T0780500 * * T0781000 * (4) THE SJB IS QUEUED TO THE $SVPSOP QUEUE, HASP IS POSTED, * T0781500 * AND THE USER TASK IS MADE TO WAIT FOR HASP TO RESPOND. * T0782000 * * T0782500 * (5) THE RESPONSE IS COPIED TO THE USER PARAMETER AREA, THE * T0783000 * PSO IS FREED IF THE SSSOCTRL FLAG IS ON OR AN ERROR IS * T0783500 * INDICATED IN THE RESPONSE WITHOUT HASP SETTING THE HIGH * T0784000 * ORDER BIT OF THE SJB PSO POINTER ON. CONTROL IS THEN * T0784500 * RETURNED TO THE USER VIA THE $EPILOG MACRO INSTRUCTION * T0785000 * WHICH FREES THE SJB FOR OTHERS. * T0785500 * * T0786000 * (6) IF DURING ANY PHASE OF PROCESSING IT IS DETERMINED THAT * T0786500 * HASP IS NOT UP, THE ROUTINE UNDOES ITS PROCESSING. IF * T0787000 * THE SJB HAS ALREADY BEEN PLACED ON THE QUEUE AND THE * T0787500 * OS WAIT MACRO HAS NOT BEEN ISSUED, THE CMS LOCK IS * T0788000 * OBTAINED AND THE SJB IS REMOVED FROM THE QUEUE (IF STILL * T0788500 * ON). THE PSO IS FREED AND THE HASP NOT UP DIAGNOSTIC IS * T0789000 * RETURNED TO THE USER. * T0789500 * * T0790000 * (7) IF THIS ROUTINE IS PREEMPTED, A RECOVERY ROUTINE IS ENTERED * T0790500 * TO REMOVE THE SJB FROM THE $SVPSOQ EITHER BY WAITNIG IN * T0791000 * PLACE OF THE ORIGINAL TCB/RB OR BY DIRECT REMOVAL IF HASP * T0791500 * ABENDS. THIS ROUTINE MAY BE ENTERED AT ENTRY PSOQUEUE ((4) * T0792000 * ABOVE) AS A SUBROUTINE OF THE RECOVERY ROUTINE SO HASP CAN * T0792500 * DISPOSE OF THE DATA SET REPRESENTED BY THE LAST OR CURRENT * T0793000 * REQUEST. RETURN IS DIRECT TO THE RECOVERY ROUTINE. * T0793500 * * T0794000 *********************************************************************** T0794500 EJECT T0795000 *********************************************************************** T0795500 * * T0796000 * INPUT REGISTERS - * T0796500 * * T0797000 * R0 = ADDRESS OF SSCVT * T0797500 * R1 = ADDRESS OF SSOB * T0798000 * R13 = ADDRESS OF SAVE AREA * T0798500 * R14 = RETURN * T0799000 * R15 = ENTRY BASE * T0799500 * * T0800000 * OUTPUT REGISTERS - * T0800500 * * T0801000 * R0-R14= UNCHANGED * T0801500 * R1 = ECB ADDRESS FOR WRITER TO WAIT ON DATA SETS * T0802000 * R15 = RETURN CODE * T0802500 * * T0803000 * NOTES * T0803500 * * T0804000 * THERE IS ONE AND ONLY ONE PROCESS SYSOUT (PSO) FOR EACH * T0804500 * SJB. UNPREDICTABLE RESULTS WILL OCCUR IF MULTIBLE TASKS * T0805000 * USE THIS INTERFACE ON AN UNCONTROLLED BASIS. * T0805500 * * T0806000 *********************************************************************** T0806500 EJECT T0807000 *********************************************************************** T0807500 * * T0808000 * ENTRY TO PROCESS SYSOUT - PICK UP PARAMETERS * T0808500 * * T0809000 *********************************************************************** T0809500 HOSSOUT $PROLOG SSOBSOUT,SSSOSIZE,LOCK=REQ LOCATE AND LOCK SJB T0810000 PSOBASE LA R8,PSEPILOG POINT EXIT TO CALL EPILOG T0810500 USING SJBDSECT,R13 SET SJB ADDRESSABILITY T0811000 USING SSSOBGN,R10 SET SSOB ADDRESSABILITY T0811500 NI SJBTFFG,255-SJBTFFGP RESET ANY REQUEST TO PURGE PSO T0812000 L R6,SJBPSOP PICK UP POSSIBLE PSO ADDRESS T0812500 L R1,$SVHASP TEST FOR T0813000 LTR R1,R1 HASP UP T0813500 BZ PSHASPUP SKIP NEXT IF UP T0814000 USING PSODSECT,R6 @OZ40277 T0814250 PSNOHASP LA R5,SSRTNTUP SET NOT UP RETURN T0814500 LTR R6,R6 CHECK FOR PSO PRESENT T0815000 BZ PSXIT EXIT IF NO PSO T0815500 TM PSOFLG2,PSOFPURG IF PSO ALREADY PURGED, @OZ40277 T0815525 BNZ PSFREE THEN JUST FREE THE PSO @OZ40277 T0815550 OC PSOIOTTR,PSOIOTTR IF NO PRIOR ALLOCATIONS, @OZ40277 T0815575 BZ PSFREE THEN JUST FREE THE PSO @OZ40277 T0815600 $GETMAIN RC,SP=241,LV=PSOLNGTH,KEY=1 GET A NEW PSO @OZ40277 T0815625 LTR R15,R15 CHECK IF PSO GOTTEN @OZ40277 T0815650 BNZ PSFREE BRANCH IF NOT @OZ40277 T0815675 OI PSOFLG2,PSOFDONE+PSOFPURG INDICATE PSO PURGED @OZ40277 T0815700 LR R14,R6 COPY PSO ADDRESS @OZ40277 T0815725 LR R3,R1 SAVE NEW PSO ADDRESS @OZ40277 T0815750 LR R0,R1 COPY NEW PSO ADDRESS @OZ40277 T0815775 LA R1,PSOLNGTH SET MOVE LENGTH @OZ40277 T0815800 LR R15,R1 MAKE LENGTHS EQUAL @OZ40277 T0815825 MVCL R0,R14 COPY THE PSO @OZ40277 T0815850 L R0,$SVPRGQ QUEUE THE @OZ40277 T0815875 ST R0,PSONEXT-PSODSECT(,R3) NEW PSO TO @OZ40277 T0815900 CS R0,R3,$SVPRGQ THE PSO @OZ40277 T0815925 BNE *-12 PURGE QUEUE @OZ40277 T0815950 B PSFREE FREE PSO T0816000 EJECT T0816500 *********************************************************************** T0817000 * * T0817500 * CHECK FOR FIRST ENTRY OF SEQUENCE * T0818000 * * T0818500 *********************************************************************** T0819000 * THIS LINE DELETED BY APAR @OZ40277 T0819500 PSHASPUP LTR R6,R6 T0820000 BNE PSMVCIN MOVE PARAMETERS T0820500 TM SSSOFLG2,SSSOCTRL IS THIS FIRST AND LAST T0821000 BZ PSGPSO IF NOT GET PSO T0821500 LA R15,SSSORTOK SET OK RETURN T0822000 CLI SSSOUFLG,0 IS THIS A GROUP REQUEST T0822500 BZ PSEPILOG IF NOT CONSIDER THIS A NOP T0823000 *********************************************************************** T0823500 * * T0824000 * GET WORK AREA FOR NEW SEQUENCE * T0824500 * * T0825000 *********************************************************************** T0825500 PSGPSO OI SJBTFFG,SJBTFFGG SET PSO GOTTEN THIS ENTRY T0826000 LA R4,PSOLNGTH GET LENGTH OF PSO T0826500 L R15,$SVGCELL POINT TO GET CELL T0827000 BALR R14,R15 ENTER IT T0827500 B PSNCELL EXIT IF NO CELL +0 T0828000 LR R6,R1 POINT TO CELL +4 T0828500 PSCELLG LA R5,PSOLNGTH-4 GET LENGTH OF PSO-4 T0829000 LA R4,4(0,R6) POINT TO OUR PORTION T0829500 SLR R0,R0 ZERO T0830000 SLR R1,R1 SOURCE ADDRESS AND LENGTH T0830500 MVCL R4,R0 ZERO WORK AREA T0831000 ST R6,SJBPSOP SET POINTER TO PSO T0831500 PSMVCIN MVC PSOUFLG(PSOPARML),SSSOUFLG MOVE ALL PARAMETERS T0832000 MVC PSOTCB,SJBTCB COPY TCB FOR NON LOCKED ABENDS T0832500 TIME BIN GET CURRENT DATE/TIME R41 T0832600 ST R1,PSOCRDT STORE DATE IN PSO R41 T0832700 *********************************************************************** T0833000 * * T0833500 * CONVERT DESTINATION TO ROUTE - JOB ID TO NUMBER * T0834000 * * T0834500 *********************************************************************** T0835000 TM PSOUFLG,SSSOROUT DOES USER WANT TO ROUTE TO DEST T0835500 BO PSODST CONVERT IF YES T0836000 TM PSOFLG1,SSSODST DID USER SPECIFY USE DESTINATION T0836500 BZ PSNODST SKIP CONVERT IF NO T0837000 PSODST DS 0H T0837500 LA R1,PSODEST POINT TO DESTINATION FIELD T0838000 SLR R2,R2 PRESET REG 2 TO R4 T0838100 IC R2,$SVTOSYS FIRST BYTE OF ROUTE CODE R4 T0838300 L R15,$SVDEST POINT TO VERIFY DESTINATION AND T0838700 BALR R14,R15 CONVERT ROUTINE - ENTER IT T0839000 B PSDEXIT FREE THE PSO AND EXIT +0 T0839500 STH R2,PSOROUTE SET ROUTE CODE +4 T0840000 PSNODST DS 0H T0840500 TM PSOFLG1,SSSOSJBI DID USER SPECIFY USE JOB ID T0841000 BZ PSNOSJBI SKIP CONVERT IF NO T0841500 LA R1,PSOJOBI POINT TO JOB ID FIELD T0842000 L R15,=A(TSCNVJB) POINT TO CONVERT ROUTINE T0842500 BALR R14,R15 CONVERT T0843000 LTR R0,R0 TEST FOR OK T0843500 BZ PSJEXIT FREE THE PSO AND EXIT T0844000 STH R0,PSOJOBNO SET JOB NUMBER T0844500 PSNOSJBI DS 0H T0845000 EJECT T0845500 *********************************************************************** T0846000 * * T0846500 * QUEUE REQUEST TO HASP - POST AND WAIT * T0847000 * * T0847500 * NOTE - THIS ROUTINE IS USED AS A SUBROUTINE BY @OZ44608 T0848000 * EOT, EPILOG, EOJ, AND EOM @OZ44608 T0848100 * * T0848500 *********************************************************************** T0849000 PSOQUEUE DS 0H T0849500 ICM R6,7,SJBPSOP+1 POINT TO PSO @OZ51577 T0849520 CLI PSOUFLG,0 CHECK FOR GROUP REQ @OZ40281 T0849550 BNE PSOENQ BRANCH IF YES @OZ40281 T0849600 TM PSOFLG2,SSSOCTRL IS REQ FOR TERMINATE @OZ40281 T0849650 BNO PSOENQ NO, CONTINUE @OZ40281 T0849700 TM SJBPSOP,X'40' DOES HASP WANT PSO... @OZ49322 T0849720 BO PSOENQ YES, TELL IT TO FREE @OZ49322 T0849740 OC PSOIOTTR,PSOIOTTR IF NO HELD @OZ40281 T0849750 BNZ PSOENQ DATASETS OR @OZ40281 T0849800 CLI PSOWKOFF,0 JOES ALLOCATED, THEN @OZ40281 T0849850 BE PSONOQ NO NEED TO TELL HASP @OZ40281 T0849900 PSOENQ LA R4,$SVPSOQ POINT TO PSO QUEUE @OZ40281 T0850000 L R15,=A(TSQUEUE) POINT TO QUEUING ROUTINE T0850500 BALR R14,R15 ENTER IT T0851000 $$POST ELMT=$SVPSO POST HASP T0851500 BNZ PSHABDQ IF HASP ABENDED DEQUEUE T0852000 PSWAIT WAIT 1,ECB=SJBECB WAIT T0852500 L R1,$SVHASP TEST FOR T0853000 LTR R1,R1 HASP UP T0853500 BNZ PSNOHASP EXIT IF NOT T0854000 *********************************************************************** T0854500 * * T0855000 * MOVE THE RESPONSE BACK TO HASP * T0855500 * * T0856000 *********************************************************************** T0856500 PSONOQ L R1,PSORETN PICK UP RETURN CODE @OZ40281 T0857000 LCR R5,R1 SET RETURN IN NEGATIVE FORM T0857500 TM SJBTFFG,SJBTFFGP TEST FOR PSO PURGE ON R41 T0857600 BO *+10 BR IF YES R41 T0857700 MVC SSSOUFLG(PSOPARML),PSOUFLG MOVE ALL PARAMETERS T0858000 CH R1,=Y(SSSORTOK) CHECK RETURN CODE T0858500 BNE PSBADRET TRY TO FREE AREA AND EXIT T0859000 TM PSOFLG2,SSSOCTRL IS THIS LAST OF A SERIES T0859500 BZ PSXIT SKIP AREA FREE IF NOT T0860000 PSFREE XC SJBPSOP,SJBPSOP ZERO SJB POINTER TO AREA T0860500 LR R1,R6 POINT TO CELL T0861000 L R15,$SVFCELL POINT TO FREE CELL T0861500 BALR R14,R15 FREE CELL T0862000 PSXIT LCR R15,R5 COMPLIMENT RETURN CODE T0862500 BR R8 RETURN T0863000 PSDENOQE LA R15,SSSOIDST SET INVALID DESTINATION T0863500 B PSEPILOG EXIT T0864000 PSJENOQE LA R15,SSSOINVA SET INVALID SEARCH ARGUMENTS T0864500 B PSEPILOG EXIT T0865000 PSLENOQE LA R15,SSSOUNAV SET UNABLE TO PROCESS NOW @OZ55639 T0865500 * THIS LINE DELETED BY APAR NUMBER @OZ55639 T0866000 EJECT R4 T0866100 PSEPILOG $EPILOG , EXIT THROUGH EPILOG T0866500 PSBADRET TM SJBPSOP,X'40' DOES HASP WANT PSO... @OZ38441 T0867000 BZ PSFREE IF NOT FREE IT @OZ38441 T0867500 B PSXIT EXIT T0868000 EJECT T0868500 *********************************************************************** T0869000 * * T0869500 * HASP DETERMINED NOT UP AFTER SJB ALREADY ON QUEUE * T0870000 * * T0870500 *********************************************************************** T0871000 PSHABDQ LR R5,R11 SAVE T0871500 LR R6,R12 SOME T0872000 LR R7,R13 REGISTERS T0872500 L R15,=A(TSETLOCK) SET CMS T0873000 BALR R2,R15 LOCK T0873500 LR R11,R5 RESTORE T0874000 LR R12,R6 THOSE T0874500 LR R13,R7 REGISTERS T0875000 L R15,=A(TSHABDQ) POINT TO ABNORMAL DEQ ROUTINE JN T0875500 BALR R14,R15 ENTER IT T0876000 L R15,=A(TSFRELOK) FREE CMS T0876500 BALR R2,R15 LOCK T0877000 LR R11,R5 RESTORE T0877500 LR R12,R6 THE T0878000 LR R13,R7 REGISTERS T0878500 L R6,SJBPSOP POINT TO PSO CELL @OZ38443 T0878600 LTR R2,R2 TEST FOR DEQUEUED T0879000 BZ PSWAIT WAIT, HASP GOT TO IT FIRST T0879500 B PSNOHASP EXIT T0880000 *********************************************************************** T0880500 * * T0881000 * TEXT IN JOB ID OR DESTINATION FIELDS INVALID * T0881500 * * T0882000 *********************************************************************** T0882500 PSDEXIT LA R8,PSDENOQE SET EXIT LOCATION FOR BAD DEST T0883000 B *+8 SKIP NEXT INSTRUCTION T0883500 PSJEXIT LA R8,PSJENOQE SET EXIT LOCATION FOR JOB ID ERROR T0884000 TM SJBTFFG,SJBTFFGG TEST FOR PSO JUST GOTTEN T0884500 BO PSFREE IF SO HASP HAS NOTHING TO DO HERE T0885000 OI PSOFLG2,SSSOCTRL SET LAST OF SERIES T0885500 B PSOQUEUE ENTER QUEUE ROUTINE AS SUBROUTINE T0886000 *********************************************************************** T0886500 * * T0887000 * CELL NOT IMMEDIATELY AVAILABLE - ASK HASP TO EXPAND * T0887500 * * T0888000 *********************************************************************** T0888500 PSNCELL ENQ MF=(E,$SVCENQ) ENQ T0889000 PSNCELLL LA R4,PSOLNGTH SET LENGTH AGAIN T0889500 L R15,$SVGCELL POINT TO GET CELL T0890000 BALR R14,R15 TRY GET CELL AGAIN T0890500 B PSNCELLA IF NO CELL, BRANCH +0 T0891000 LR R6,R1 POINT TO CELL +4 T0891500 DEQ MF=(E,$SVCENQ) DEQ T0892000 B PSCELLG ENTER NORMAL PROCESSING T0892500 PSNCELLA ICM R1,15,$SVHASP HASP UP T0893000 BNZ PSDEQNH EXIT IF NOT T0893500 LA R0,SJBECB POINT TO ECB TO POST T0894000 MVI SJBECB,0 ZERO ECB T0894500 L R15,$SVGCPOL POINT TO HASP NOTIFY ROUTINE T0895000 BALR R14,R15 ENTER IT T0895500 CLI SJBECB+3,0 TEST ECB FOR ZERO T0896000 BZ PSNCELLL LOOP IF OK T0896500 DEQ MF=(E,$SVCENQ) DEQ T0897000 B PSLENOQE EXIT, UNABLE TO PROCESS @OZ55639 T0897500 PSDEQNH DEQ MF=(E,$SVCENQ) DEQ T0898000 B PSNOHASP EXIT TO RETURN ERROR T0898500 DROP R6,R10,R12,R13 T0899000 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - CANCEL/STATUS' T0899500 *********************************************************************** T0900000 * * T0900500 * CANCEL/STATUS - SUBSYSTEM FUNCTIONS SSOBCANC/SSOBSTAT * T0901000 * * T0901500 * FUNCTION * T0902000 * * T0902500 * RECEIVE CONTROL FROM THE OPERATING SYSTEM CANCEL AND STATUS * T0903000 * PROCESSORS FOR THE PURPOSE OF INTERFACING WITH THE HASPXEQ * T0903500 * CANCEL/STATUS SERVICE ROUTINE FOR CANCELLING A UNIQUELY * T0904000 * IDENTIFIED JOB OR PROVIDE SELECTED STATUS INFORMATION ON * T0904500 * JOBS BY UNIQUE IDENTIFICATION, JOB NAME (ALL WITH SAME NAME), * T0905000 * OR USER IDENTIFICATION (ALL JOBS WITH NAME MATCHING THE USER * T0905500 * ID WITH ONE ADDITIONAL TRAILLING CHARACTER). THE FUNCTIONAL * T0906000 * OPERATIONS ARE DESCRIBBED BELOW. * T0906500 * * T0907000 * (1) A $PROLOG MACRO INSTRUCTION IS EXECUTED TO GET CONTROL * T0907500 * OF THE USER SJB (REQUESTOR MUST BE ONE OF OUR JOBS). * T0908000 * * T0908500 * (2) JOB ID IS CONVERTED TO JOB NUMBER AS REQUESTED. * T0909000 * * T0909500 * (3) THE SJB IS QUEUED TO THE $SVTSCS QUEUE, HASP IS POSTED * T0910000 * AND THE USER TASK IS MADE TO WAIT FOR HASP TO RESPOND. * T0910500 * * T0911000 * (4) THE RESPONSE IS COPIED TO THE USER PARAMETER AREA, THE * T0911500 * STATUS AREA (IF GOTTEN BY HASP) IS FREED, AND CONTROL IS * T0912000 * RETURNED TO THE USER VIA THE $EPILOG MACRO INSTRUCTION. * T0912500 * * T0913000 * (5) IF DURING ANY PHASE OF PROCESSING IT IS DETERMINED THAT * T0913500 * HASP IS NOT UP, THE ROUTINE UNDOES ITS PROCESSING. IF THE * T0914000 * SJB HAS ALREADY BEEN PLACED ON THE QUEUE AND THE OS WAIT * T0914500 * HAS NOT BEEN ISSUED, THE CMS LOCK IS OBTAINED AND THE SJB * T0915000 * IS REMOVED FROM THE QUEUE (IF STILL ON). THE HASP NOT UP * T0915500 * DIAGNOSTIC IS RETURNED TO THE USER. * T0916000 * * T0916500 * (6) IF THIS ROUTINE IS PREEMPTED, A RECOVERY ROUTINE IS ENTERED * T0917000 * TO REMOVE THE SJB FROM THE $SVTSCS QUEUE EITHER BY WAITING * T0917500 * IN PLACE OF THE ORIGINAL TCB/RB OR DIRECT REMOVAL IF HASP * T0918000 * ABENDS. * T0918500 * * T0919000 * INPUT REGISTERS * T0919500 * * T0920000 * R0 = ADDRESS OF SSCVT * T0920500 * R1 = ADDRESS OF SSOB * T0921000 * R13 = SAVE AREA * T0921500 * R14 = RETURN * T0922000 * R15 = ENTRY BASE * T0922500 * * T0923000 * OUTPUT REGISTERS * T0923500 * * T0924000 * R0-R14= UNCHANGED * T0924500 * R15 = RETURN CODE * T0925000 * * T0925500 EJECT R4 T0925600 *********************************************************************** T0926000 EJECT T0926500 *********************************************************************** T0927000 * * T0927500 * ENTRY TO CANCEL/STATUS - PICK UP PARAMETERS * T0928000 * * T0928500 *********************************************************************** T0929000 HOSSTAT $PROLOG SSOBSTAT,0,LOCK=REQ LOCATE AND LOCK USER'S SJB T0929500 TSSTAT AL R12,=A(TSCAN-TSSTAT) POINT TO TSCAN T0930000 BR R12 ENTER COMMON CODE T0930500 HOSCANC $PROLOG SSOBCANC,0,LOCK=REQ LOCATE AND LOCK USER'S SJB T0931000 TSCAN LR R8,R1 POINT TO SSOB (SSIB NOT REQUIRED) T0931500 USING SSOB,R8 T0932000 USING SJBDSECT,R13 BASES ARE T0932500 USING SSCSBGN,R10 ESTABLISHED T0933000 USING SSVT,R11 BY PROLOG T0933500 LA R5,SSRTNTUP SET HASP NOT UP T0934000 ICM R1,15,$SVHASP IS HASP UP T0934500 BNZ TSRELSE EXIT IF NOT T0935000 LA R5,SSRTLERR SET ABORT RETURN FOR LOGIC ERROR T0935500 EJECT T0936000 *********************************************************************** T0936500 * * T0937000 * FILL IN REQUEST PARAMETERS * T0937500 * * T0938000 *********************************************************************** T0938500 MVC SJBTULEN,SSCSULEN COPY USER ID LENGTH T0939000 MVC SJBTFUNC,SSOBFUNC COPY FUNCTION T0939500 MVC SJBTFLGS,SSCSFLGS T0940000 MVC SJBTJOBN,SSCSJOBN COPY JOB NAME T0940500 MVC SJBTDIMP,SSCSDIMP COPY ARRAY SIZE T0941000 STH R5,SJBTRETR SET DEFAULT RETURN T0941500 SLR R0,R0 ZERO JOB ID T0942000 ST R0,SJBTAREA ZERO AREA POINTER T0942500 STH R0,SJBTDIMR ZERO RESPONSE SIZE T0943000 CLI SSCSJOBI,C' ' DID REQUEST INDICATE JOB ID T0943500 BE TSNJOBID IF NOT SKIP CONVERT T0944000 LA R1,SSCSJOBI POINT TO JOB ID FIELD T0944500 L R15,=A(TSCNVJB) POINT TO CONVERT ROUTINE T0945000 BALR R14,R15 CONVERT T0945500 LA R15,SSCSYNTX SET SYNTAX ERROR RETURN T0946000 LTR R0,R0 CHECK FOR ERROR T0946500 BZ TSRELSEA REJECT REQUEST IF ERROR T0947000 TSNJOBID ST R0,SJBTJOBI SET JOB ID IN BINARY FORM T0947500 *********************************************************************** T0948000 * * T0948500 * FUNCTION ORIENTED SETTINGS * T0949000 * * T0949500 *********************************************************************** T0950000 CLC SSOBFUNC,=Y(SSOBCANC) IS THIS CANCEL T0950500 BE TSCANC IF YES, NO MORE TO FILL OUT T0951000 LH R0,SJBTDIMP PICK UP AREA SIZE T0951500 CH R0,=Y(SSCSELSZ) CHECK FOR AT LEAST ONE ELEMENT T0952000 BL TSRELSE ERROR IF NOT T0952500 *********************************************************************** T0953000 * * T0953500 * QUEUE REQUEST TO HASP * T0954000 * * T0954500 *********************************************************************** T0955000 TSCANC LA R4,$SVTSCS POINT TO CANCEL/STATUS QUEUE T0955500 L R15,=A(TSQUEUE) POINT TO QUEUING ROUTINE T0956000 BALR R14,R15 ENTER IT T0956500 $$POST ELMT=$SVJOB POST HASP T0957000 BZ TSWAIT WAIT FOR HASP IF STILL UP T0957500 LR R5,R11 SAVE T0958000 LR R6,R12 SOME T0958500 LR R7,R13 REGISTERS T0959000 L R15,=A(TSETLOCK) SET CMS T0959500 BALR R2,R15 LOCK T0960000 LR R11,R5 RESTORE SSVT BASE T0960500 LR R12,R6 PUT BASE BACK T0961000 LR R13,R7 RESTORE SJB BASE T0961500 L R15,=A(TSHABDQE) POINT TO ABNORMAL DEQUEUE ROUTINE T0962000 BALR R14,R15 ENTER IT T0962500 L R15,=A(TSFRELOK) FREE CMS T0963000 BALR R2,R15 LOCK T0963500 LR R11,R5 RESTORE T0964000 LR R12,R6 THE T0964500 LR R13,R7 REGISTERS T0965000 LTR R2,R2 TEST FOR DEQUEUED T0965500 BZ TSWAIT WAIT. HASP GOT TO IT FIRST T0966000 LA R5,SSRTNTUP SET HASP NOT UP T0966500 B TSFREEA FREE AREA IF PRESENT AND EXIT T0967000 EJECT T0967500 *********************************************************************** T0968000 * * T0968500 * WAIT AND FILL IN RESPONSE * T0969000 * * T0969500 *********************************************************************** T0970000 TSWAIT WAIT 1,ECB=SJBECB WAIT T0970500 LA R5,SSRTNTUP SET HASP NOT UP T0971000 ICM R1,15,$SVHASP TEST ECB FOR HASP UP T0971500 BNZ TSFREEA FREE AREA, IF PRESENT AND EXIT T0972000 LH R5,SJBTRETR PICK UP R15 RETURN T0972500 CH R5,=Y(SSRTOK) CHECK FOR OK RETURN T0973000 BNE TSFREEA FREE AREA T0973500 LH R6,SJBTRETB PICK UP SSOBRETN CODE T0974000 LCR R5,R6 SET COMPLIMENT FOR RECOMPLIMENT T0974500 CLI SJBTFUNC+1,SSOBCANC IS THIS CANCEL T0975000 BE TSCKSVC IF YES, TEST FOR SVC 34 REQUIRED T0975500 MVC SSCSDIMR,SJBTDIMR SET SIZE OF AREA T0976000 CH R6,=Y(SSCSMALL) CHECK FOR AREA TOO SMALL T0976500 BE TSFREEA FREE AREA T0977000 L R0,SJBTAREA POINT TO WORK AREA T0977500 LH R1,SJBTDIMR PICK UP AMOUNT TO MOVE T0978000 LTR R1,R1 CHECK FOR MOVE T0978500 BZ TSFREEA SKIP MOVE IF ZERO T0979000 LA R2,SSCSARBG POINT TO START OF ARRAY T0979500 LR R3,R1 COPY LENGTH T0980000 MVCL R2,R0 MOVE RESPONSE ARRAY T0980500 EJECT T0981000 *********************************************************************** T0981500 * * T0982000 * FREE WORK AREA * T0982500 * * T0983000 *********************************************************************** T0983500 TSFREEA L R1,SJBTAREA POINT TO AREA T0984000 LTR R1,R1 CHECK FOR ZERO T0984500 BZ TSRELSE RELEASE SJB IF NO AREA T0985000 MVC 0(4,R1),SJBTCCE PUT CCE POINTER INTO CELL T0985500 L R15,$SVFCELL POINT TO FREE CELL ROUTINE T0986000 BALR R14,R15 FREE CELL T0986500 TSRELSE LCR R15,R5 SET RETURN FOR EPILOG T0987000 TSRELSEA $EPILOG , EXIT THROUGH EPILOG T0987500 TSCKSVC EQU TSRELSE NO ACTION REQUIRED FOR CANCEL T0988000 DROP R8 T0988500 DROP R10 T0989000 DROP R12 T0989500 EJECT T0990000 *********************************************************************** T0990500 * * T0991000 * SUBROUTINE TO CONVERT EXTERNAL JOB ID TO JOB NUMBER * T0991500 * * T0992000 * REGISTERS * T0992500 * * T0993000 * R0 = ANSWER OR ZERO * T0993500 * R1 = INPUT TEXT * T0994000 * R2 = WORK * T0994500 * R3 = WORK * T0995000 * R4 = WORK * T0995500 * R14 = RETURN * T0996000 * R15 = ENTRY BASE * T0996500 * * T0997000 *********************************************************************** T0997500 TSCNVJB DS 0H T0998000 USING *,R15 T0998500 LA R2,L'SSCSJOBI-1 SET NUMERIC DIGIT LIMIT T0999000 TSCNVJBO SLR R0,R0 ZERO THE ACCUMULATOR T0999500 SLR R4,R4 ZERO BASE T1000000 CLI 0(R1),C'J' IS THIS 'JOB' T1000500 BE TSCNVJBL SKIP TO NUMERIC IF YES T1001000 LH R4,=H'10000' SET BASE RANGE FOR 'STC' T1001500 CLI 0(R1),C'S' CHECK FOR 'STC' T1002000 BE TSCNVJBL SKIP TO NUMERIC IF YES T1002500 AH R4,=H'10000' SET BASE RANGE FOR 'TSU' T1003000 CLI 0(R1),C'T' CHECK FOR 'TSU' T1003500 BNER R14 EXIT WITH ERROR T1004000 TSCNVJBL LA R1,1(0,R1) UP 1 T1004500 CLI 0(R1),C'0' CHECK FOR NUMERIC T1005000 BNL TSCNVJBA IF NOT LOW ASSUME NUMERIC T1005500 BCT R2,TSCNVJBL LOOP TO END T1006000 BR R14 EXIT WITH ZERO T1006500 TSCNVJBN CLI 0(R1),C'0' CHECK FOR BELOW NUMERIC T1007000 BL TSCNVCBL CHECK FOR BLANK OR END T1007500 TSCNVJBA IC R3,0(0,R1) PICK UP DIGIT T1008000 N R3,=X'0000000F' CUT OFF HIGH PART T1008500 MH R0,=H'10' MULTIPLY BY 10 T1009000 AR R0,R3 ADD T1009500 CH R0,=H'9999' MAKE SURE NOT ABOVE MAX T1010000 BH TSCNVJBO RESET JOB NUMBER AND RETURN T1010500 TSCNVJCT LA R1,1(0,R1) UP TO NEXT DIGIT T1011000 BCT R2,TSCNVJBN LOOP T1011500 B TSCNVEND EXIT WITH VALUE T1012000 TSCNVCBL CLI 0(R1),C' ' IS IT BLANK T1012500 BE TSCNVJCT IGNORE IF BLANK T1013000 TSCNVEND LTR R0,R0 CHECK FOR ZERO T1013500 BZR R14 EXIT WITH ZERO T1014000 AR R0,R4 ADD BASE T1014500 BR R14 RETURN WITH ANSWER T1015000 DROP R15 T1015500 EJECT T1016000 *********************************************************************** T1016500 * * T1017000 * SUBROUTINE TO QUEUE THE SJB TO ALTERNATE HASP WORK QUEUE * T1017500 * * T1018000 * REGISTERS - * T1018500 * * T1019000 * R0 = WORK (ON RETURN CONTAINS PREVIOUS QUEUE VALUE) * T1019500 * R1 = WORK * T1020000 * R2 = WORK * T1020500 * R3 = WORK * T1021000 * R4 = ADDRESS OF QUEUE HEAD * T1021500 * R13 = ADDRESS OF SJB * T1022000 * R14 = RETURN * T1022500 * R15 = ENTRY BASE * T1023000 * * T1023500 *********************************************************************** T1024000 USING *,R15 T1024500 TSQUEUE DS 0H T1025000 SLR R0,R0 ZERO T1025500 ST R0,SJBECB THE ECB T1026000 OI SJBTFFG,SJBTFFGM SET ECB STATUS MEANGINGFULL T1026500 LR R2,R13 POINT TO SJB T1027000 LM R0,R1,0(R4) PICK UP CURRENT QUEUE HEADER T1027500 TSQUL LR R3,R1 COPY COUNTER T1028000 ST R0,SJBTCHN PUT OLD ELEMENTS BEHIND T1028500 BCTR R3,0 REDUCE T1029000 CDS R0,R2,0(R4) QUEUE SJB T1029500 BNZ TSQUL LOOP IF NOT QUEUED T1030000 LTR R0,R0 DO WE TELL HASP T1030500 BR R14 RETURN T1031000 DROP R15 T1031500 EJECT T1032000 *********************************************************************** T1032500 * * T1033000 * SUBROUTINE TO SCAN FOR TSO QUEUED SJB ON USER ABEND * T1033500 * * T1034000 * REGISTERS - * T1034500 * * T1035000 * R0 = WORK * T1035500 * R1 = WORK - ZERO ON SJB NOT FOUND RETURN (CC SET) * T1036000 * R4 = ADDRESS OF QUEUE HEAD * T1036500 * R13 = ADDRESS OF SJB * T1037000 * R14 = RETURN * T1037500 * R15 = ENTRY BASE * T1038000 * * T1038500 * NOTES - * T1039000 * * T1039500 * THIS ROUTINE IS ENTERED FROM THE END OF TASK ROUTINE * T1040000 * WITH CMS LOCK ON. * T1040500 * * T1041000 *********************************************************************** T1041500 TSUABQS DS 0H T1042000 USING *,R15 T1042500 MVI $SVTSLOK,X'FF' TELL HASP TO SET LOCK T1043000 L R0,0(0,R4) PICK UP FIRST SJB T1043500 TSUABQSL LTR R1,R0 COPY AND SET CC T1044000 BZR R14 EXIT IF NOT ON THE QUEUE (CC=0) T1044500 L R0,SJBTCHN-SJBDSECT(,R1) POINT TO NEXT SJB T1045000 CR R1,R13 IS THIS OUR SJB T1045500 BNE TSUABQSL LOOP IF NOT T1046000 MVI SJBTFLOW,X'FF' FAKE HASP HAS SEEN T1046500 LTR R1,R1 SET CC T1047000 BR R14 EXIT WITH R1 AND CC NON-ZERO. T1047500 DROP R15 T1048000 EJECT T1048500 *********************************************************************** T1049000 * * T1049500 * SUBROUTINE TO RETRIEVE TSO QUEUED SJB WHEN HASP ABENDS * T1050000 * * T1050500 * REGISTERS - * T1051000 * * T1051500 * R0 = WORK * T1052000 * R1 = WORK * T1052500 * R2 = WORK - ZERO ON RETURN IF SJB NOT DEQUEUED (CC SET) * T1053000 * R3 = WORK * T1053500 * R4 = QUEUE POINTER * T1054000 * R13 = ADDRESS OF SJB * T1054500 * R14 = RETURN * T1055000 * R15 = ENTRY BASE * T1055500 * * T1056000 * NOTES - * T1056500 * * T1057000 * CMS LOCK IS HELD ON ENTRY. HASP IS EXPECTED TO HOLD CMS * T1057500 * LOCK WHEN DEQUEUING AND WHEN RESETTING THE HASP NOT UP * T1058000 * INDICATOR. * T1058500 * * T1059000 *********************************************************************** T1059500 TSHABDQ DS 0H T1060000 USING *,R15 T1060500 ICM R2,15,$SVHASP INSURE HASP NOT UP T1061000 BZR R14 ERROR EXIT T1061500 LM R2,R3,0(R4) PICK UP CHAIN INFO T1062000 TSHABDQX LTR R2,R2 TEST END T1062500 BZR R14 ERROR EXIT T1063000 CR R2,R13 IS IT OUR SJB T1063500 BNE TSHABDQN TRY NEXT T1064000 L R0,SJBTCHN-SJBDSECT(,R2) POINT TO NEXT T1064500 LR R1,R3 COPY SECURITY COUNT T1065000 CDS R2,R0,0(R4) TRY TO TAKE SJB OFF T1065500 BNZ TSHABDQX LOOP IF NOT OFF T1066000 TSHABDQE LTR R2,R2 SET CC T1066500 BR R14 EXIT T1067000 TSHABDQN LR R3,R2 COPY CURRENT POINTER T1067500 ICM R2,15,SJBTCHN-SJBDSECT(R2) POINT TO NEXT T1068000 BZR R14 EXIT IF ERROR T1068500 CR R2,R13 IS THIS OUR SJB T1069000 BNE TSHABDQN LOOP IF NOT T1069500 MVC SJBTCHN-SJBDSECT(,R3),SJBTCHN-SJBDSECT(R2) DEQUEUE T1070000 B TSHABDQE EXIT T1070500 DROP R15 T1071000 EJECT T1071500 *********************************************************************** T1072000 * * T1072500 * SUBROUTINE TO SET LOCK * T1073000 * * T1073500 * REGISTERS - * T1074000 * * T1074500 * R2 = RETURN * T1075000 * R11 = WORK * T1075500 * R12 = WORK * T1076000 * R13 = WORK * T1076500 * R14 = WORK * T1077000 * R15 = ENTRY BASE - WORK * T1077500 * * T1078000 *********************************************************************** T1078500 TSETLOCK DS 0H T1079000 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=(QUEUES,*-*,TSFRCT1079500 ELOK) ENQ ON TS QUEUES TO HASP T1080000 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,RELATED=(QUEUES,*-*,TSFRELCT1080500 OK) ENQ ON HASP TS QUEUES T1081000 BR R2 RETURN T1081500 SPACE 1 T1082000 *********************************************************************** T1082500 * * T1083000 * SUBROUTINE TO FREE LOCK * T1083500 * * T1084000 * REGISTERS - * T1084500 * R2 = RETURN * T1085000 * R11 = WORK * T1085500 * R12 = WORK * T1086000 * R13 = WORK * T1086500 * R14 = WORK * T1087000 * R15 = ENTRY BASE - WORK * T1087500 * * T1088000 *********************************************************************** T1088500 TSFRELOK DS 0H T1089000 SETLOCK RELEASE,TYPE=CMS,RELATED=(QUEUES,*-*,TSETLOCK) T1089500 SETLOCK RELEASE,TYPE=LOCAL,RELATED=(QUEUES,*-*,TSETLOCK) T1090000 BR R2 RETURN T1090500 DROP R13 T1091000 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - VERIFY USER ID' T1091500 *********************************************************************** T1092000 * * T1092500 * SUBSYSTEM FUNCTION SSOBUSER * T1093000 * * T1093500 * FUNCTION * T1094000 * * T1094500 * RECEIVE CONTROL FROM OS ROUTINES TO PROVIDE ACCEPTANCE OR * T1095000 * REJECTION OF DESTINATION PARAMETERS SUCH AS DEFAULT DESTINATION * T1095500 * FOR TIME SHARING USERS. THE USERVERF SUBROUTINE IS CALLED AND * T1096000 * YES OR NO ANSWER IS RETURNED TO THE CALLER. * T1096500 * * T1097000 * INPUT REGISTERS * T1097500 * * T1098000 * R0 = ADDRESS OF SSCVT * T1098500 * R1 = ADDRESS OF SSOB * T1099000 * R13 = SAVE AREA * T1099500 * R14 = RETURN * T1100000 * R15 = ENTRY BASE * T1100500 * * T1101000 * OUTPUT REGISTERS * T1101500 * * T1102000 * R0-R14= UNCHANGED * T1102500 * R15 = RETURN CODE * T1103000 * * T1103500 * WORK AREAS * T1104000 * * T1104500 * SSVT EXTENSION - CONTAINS HASP ROUTE CODE INFORMATION * T1105000 * * T1105500 *********************************************************************** T1106000 HOSUSER $ENTRY BASE=R15,ENTRY=NO PROVIDE ENTRY FOR ROUTINE T1106500 USER EQU HOSUSER T1107000 USING USAVE,R13 T1107500 STM R14,R12,USAVER SAVE CALLER'S REGISTERS T1108000 LR R12,R15 ESTABLISH BASE T1108500 USING USER,R12 T1109000 DROP R15 T1109500 LR R8,R0 POINT TO SSCVT T1110000 USING SSCT,R8 T1110500 ICM R11,15,SSCTSSVT POINT TO SSVT T1111000 BZ HOSERROR EXIT WITH ERROR T1111500 LR R10,R1 POINT TO SSOB T1112000 USING SSOB,R10 T1112500 L R1,SSOBINDV POINT TO FUNCTION AREA T1113000 LA R4,SSUSRTOK GET OK RETURN CODE T1113500 LA R1,SSUSUSER-SSUSBGN(0,R1) POINT TO DESTINATION T1114000 SLR R2,R2 ZERO REGISTER R4 T1114100 IC R2,$SVTOSYS SET DEFAULT FOR BYTE 1 R4 T1114300 BAL R14,USERVERF ENTER VERIFICATION T1114700 LA R4,SSUSNOUS SET INVALID RETURN (R14)+0 T1115000 ST R4,SSOBRETN SET RETURN (R14)+4 T1115500 LM R14,R12,USAVER PICK UP REGISTERS T1116000 LA R15,SSRTOK SET OK COMPLETION T1116500 BR R14 RETURN T1117000 HOSERROR LM R14,R12,USAVER PICK UP REGISTERS R4 T1117100 LA R15,SSRTNTUP SIGNAL HASP NOT UP R4 T1117200 BR R14 RETURN R4 T1117300 DROP R8 T1117500 DROP R10 T1118000 DROP R12 T1118500 EJECT T1119000 *********************************************************************** T1119500 * * T1120000 * SUBROUTINE TO CONVERT 'RXXX ' * T1120200 * 'UXXX ','LOCAL ','XXXXXXXX' (USER SPECIFIED) TO * T1121000 * BINARY ROUTE CODE AND PROVIDE VALIDITY CHECK. 'LOCAL ' * T1121400 * RESULTS IN 'XX00' ROUTE CODE (XX = SUPPLIED BY CALLER). * T1121500 * BLANK AND BINARY ZEROS RESULT IN X'0000' ROUTE CODE. * T1122000 * * T1122500 * REGISTERS - * T1123000 * * T1123500 * R0 = WORK * T1124000 * R1 = INPUT - ADDRESS OF 8 BYTE DESTINATION * T1124500 * OUTPUT- UNPREDICTABLE * T1125000 * R2 = INPUT - DEFAULT FIRST BYTE OF ROUTE * T1125200 * = OUTPUT- X'XXRR' OR '00UU' ROUTE CODE * T1125300 * R3 = WORK * T1126000 * R11 = ADDRESS OF SSVT - SET BY CALLER * T1126500 * R14 = RETURN- 0+(R14) - ERROR RETURN * T1127000 * 4+(R14) - OK RETURN - ( R2 VALID ) * T1127500 * R15 = BASE - SET BY CALLER IF ENTRY 'USERDEST' * T1128000 * * T1128500 *********************************************************************** T1129000 USERVERF BALR R15,0 ESTABLISH BASE FOR SUBROUTINE T1129500 USING *,R15 T1130000 USERDEST DS 0H T1130500 SLL R2,32-8 ALIGN DEFAULT HIGH BYTE R4 T1130600 LA R15,0(,R15) PURIFY BASE R4 T1131100 OR R15,R2 COMBINE R4 T1131200 LA R14,0(,R14) PURIFY ADDRESS R4 T1131300 OR R14,R2 COMBINE IN CASE NOT NATIVE R4 T1131400 SLR R2,R2 ZERO R4 T1131500 CLC 0(8,R1),=CL8' ' BLANKS R4 T1131600 BE 4(0,R14) RETURN WITH INDIRECT ROUTE CODE R4 T1131700 CLC 0(8,R1),=XL8'0' ZERO R4 T1131800 BZ 4(0,R14) RETURN WITH INDIRECT ROUTE CODE R4 T1131900 CLC 0(3,R1),=C'RMT' THIS 'RMT' R4 T1132000 BNE USNNA SKIP IF NOT R4 T1132100 LA R1,2(,R1) SET TO SCAN R4 T1132200 LA R0,6 'RMTNNNNN' R4 T1132300 B USLR ENTER COMMON CODE R4 T1132400 USNNA CLC 0(2,R1),=C'RM' THIS 'RM' R4 T1132500 BNE USNNB SKIP IF NOT R4 T1132600 LA R1,1(,R1) SET TO SCAN R4 T1132700 LA R0,7 'RMNNNNNN' R4 T1132800 B USLR ENTER COMMON CODE R4 T1132900 USNNB DS 0H R4 T1133000 LA R0,8 SET COUNTER R4 T1133100 USNN CLI 0(R1),C'R' THIS REMOTE R4 T1136100 BE USLR CONVERT REMOTE IF YES R4 T1136200 CLI 0(R1),C'U' THIS UNIT R4 T1136300 BNE USS SCAN DESTINATION TABLE IF NOT R4 T1136400 LA R15,0(,R15) CLEAR FIRST BYTE R4 T1136500 USLR LA R1,1(,R1) POINT TO NEXT CHARACTER R4 T1136600 BCT R0,USBR CHECK FOR BLANK R4 T1136700 CLM R15,8,=XL8'0' UXXX R4 T1136800 BZ USUR TEST FOR VALID RANGE R4 T1136900 CH R2,$SVROUT WITHIN REMOTE RANGE R4 T1137400 BH USS TRY DESTINATION TABLE R4 T1137500 IC R2,$SVROUTM(R2) PICK UP REMOTE ROUTING R4 T1137600 USCR SRDL R2,8 PUT REMOTE/UNIT INTO R3 R4 T1137700 LR R2,R15 FIRST BYTE INTO R2 R4 T1137800 SRL R2,32-8 NEXT TO REMOTE R4 T1137900 SLDL R2,8 COMBINE THE TWO BYTES R4 T1138000 B 4(0,R14) RETURN R4 T1138100 USUR CH R2,$SVNOUNT WITHIN UNIT RANGE R4 T1138200 BH USS TRY DESTINATION TABLE R4 T1138300 LTR R2,R2 RESULT ZERO R4 T1138400 BZR R14 ERROR EXIT R4 T1138500 B 4(0,R14) RETURN R4 T1138600 USBR CLI 0(R1),C' ' BLANK R4 T1138700 BE USLR LOOP R4 T1138800 CLI 0(R1),C'0' ZERO OR ABOVE R4 T1138900 BL USS TRY DESTINATION TABLE R4 T1139000 IC R3,0(,R1) PICK UP NUMERIC R4 T1139100 N R3,=A(X'F') PURIFY NUMBER R4 T1139200 MH R2,=H'10' MULTIPLY BY 10 R4 T1139300 ALR R2,R3 COMBINE DIGITS R4 T1139400 CH R2,=H'255' THIS TOO HIGH R4 T1139500 BNH USLR LOOP R4 T1139600 EJECT R4 T1139700 *********************************************************************** T1139800 * * T1139900 * SCAN REMOTE DESTINATION TABLE FOR MATCH * T1140000 * * T1140100 *********************************************************************** T1140200 USS ALR R1,R0 POINT TO END + 1 R4 T1140300 SH R1,=H'8' THEN FIRST R4 T1140400 LM R2,R3,$SVRDT POINT TO FIRST AND LAST OF TABLE R4 T1140500 USING RDTDSECT,R2 R4 T1140600 USLT CR R2,R3 ABOVE END R4 T1140700 BHR R14 ERROR EXIT R4 T1140800 CLC RDTNAME,0(R1) SAME NAME R4 T1140900 BE USFT EXIT IF FOUND R4 T1141000 LA R2,RDTSIZ(,R2) POINT TO NEXT R4 T1141100 B USLT LOOP R4 T1141200 USFT LR R0,R14 COPY DEFAULT FIRST BYTE R4 T1141300 SRL R0,32-8 SHIFT OUT UNDESIRABLE BITS R4 T1141400 SLL R0,8 ALIGN R4 T1141500 TM RDTFLAG,RDTFLAGU+RDTFLAGR UXXX OR RXXX R4 T1141600 BZ USNT SKIP IF NEITHER R4 T1141700 IC R0,RDTRMTNO SET REMOTE OR UNIT NUMBER R4 T1141800 TM RDTFLAG,RDTFLAGU WAS THIS UNIT R4 T1141900 BO USUT SET UNIT R4 T1142000 USNT TM RDTFLAG,RDTFLAGN FIRST BYTE DESIRED R4 T1142200 BZ USOT SKIP NEXT IF NOT R4 T1142300 ICM R0,2,RDTSYS SET FIRST BYTE R4 T1142400 USOT LR R2,R0 COPY ANSWER R4 T1142500 ICM R2,2,=XL8'0' ZERO FIRST BYTE R4 T1142600 IC R0,$SVROUTM(R2) PICK UP REMOTE ROUTING R4 T1143600 LR R2,R0 SET ANSWER R4 T1143700 B 4(0,R14) RETURN R4 T1143800 USUT ICM R0,2,=XL8'0' ZERO FIRST BYTE R4 T1143900 LR R2,R0 SET ANSWER R4 T1144000 B 4(0,R14) RETURN R4 T1144100 DROP R2 R4 T1144200 DROP R15 T1150000 TITLE 'HASP $$POST SUBROUTINE' T1150500 *********************************************************************** T1151000 * * T1151500 * $$POST - SUBROUTINE TO TELL HASP TO $POST A PCE AND * T1152000 * POST THE HASP TASK ( CROSS MEMORY ). * T1152500 * * T1153000 * REGISTERS - * T1153500 * R0 = MASK TO AND WITH $SVECF FIELD IF R1 = 0 - ALTERED * T1154000 * R1 = ADDRESS OF $$POST ELEMENT - ALTERED * T1154500 * R2 = RETURN * T1155000 * R11 = ADDRESS OF SSVT - SET BY CALLER * T1155500 * R14 = WORK, UNPREDICTABLE ON EXIT * T1155600 * R15 = BASE - SET BY CALLER - ALTERED * T1156500 * * T1157000 * NOTES - * T1157500 * * T1158000 * CALLER MUST QUEUE WORK REQUEST FOR PCE BEFORE $$POSTING. * T1158500 * * T1159000 * THIS ROUTINE EXPECTS THAT THE HASP DISPATCHER WILL * T1159500 * TEST $SVPOSTW TO DETERMINE IF ANY PCE'S ARE TO BE * T1160000 * $POSTED ( RESETTING THE FLAG ). IF $POSTS ARE REQUIRED, * T1160500 * EACH PCE IS $POSTED AS REQUIRED. THE $SVECF FIELD FLAGS * T1161000 * ARE SET ON AT TESTING, BUT SPECIFIC PCE REQUESTS * T1161500 * MUST BE RESET BY THE $POSTED PROCESSOR BEFORE FINAL * T1162000 * TESTS FOR WORK ARE MADE. * T1162500 * * T1163000 *********************************************************************** T1163500 $$POST DS 0H T1164000 USING *,R15 T1164500 LTR R1,R1 IS R1 ZERO T1165000 BNZ SNPECF IF NOT DO PCE POST T1165500 L R1,$SVECF PICK UP OLD ECF T1166000 SNPECFL OR R0,R1 COMBINE REQUESTS T1166500 CS R1,R0,$SVECF TRY TO POST BIT T1167000 BNE SNPECFL LOOP IF NO POST T1167500 B SP POST HASP MAIN TASK T1168000 SPACE 1 R4 T1168500 SNPECF MVI 0(R1),X'FF' SET ECF AS PENDING R4 T1168600 * SET PENDING AT THIS POINT T1169000 SP L R14,$SVHECBA ADDR OF ECB AND $$POST WORK FLAG R4 T1169500 MVI $SVPOSTW(R14),X'FF' SHOW POST REQUIRED R4 T1169600 L R0,=X'40000000' PICK UP POST WORD T1170000 L R1,0(,R14) GET CONTENTS OF HASP ECB R4 T1170200 SPTEST LTR R1,R1 TEST FOR WAITING T1171000 BM SPLONG LONG POST IF WAITING T1171500 CS R1,R0,0(R14) TRY QUICK POST R4 T1171600 BNZ SPTEST TEST AGAIN IF NO GO T1172500 B SNTHASP SKIP LONG POST T1173000 SPLONG CLC PSAAOLD-PSA,$SVPOSTE+4 ARE WE IN HASP MEMORY... R4 T1174000 BNE SPLONGXM DO CROSS MEMORY POST IF NOT T1174500 LR R1,R14 POST MAIN R4 T1174600 POST (1) TASK R4 T1174700 L R15,$SVHASP GET HASP STATUS T1175500 LTR R15,R15 SET CONDITION CODE T1176000 BR R2 RETURN T1176500 SPLONGXM POST MF=(E,$SVPOSTE) POST HASP R4 T1177500 SNTHASP L R15,$SVHASP SET HASP CONDITION T1178000 LTR R15,R15 SET CONDITION CODE T1178500 BR R2 RETURN TO CALLER T1179000 SPACE 1 R4 T1180200 DROP R13,R15 R4 T1180300 SPACE 1 R4 T1180400 LTORG R4 T1180500 TITLE 'HASP VFL INSTRUCTION SIMULATION ROUTINE' R4 T1180600 *********************************************************************** T1180700 * * T1180800 * $VFL - VFL INSTRUCTION SIMULATION ROUTINE * T1180900 * * T1181000 * R0 - LENGTH OF FIELDS, UNPREDICTABLE ON EXIT * T1181100 * R1 - ADDRESS OF 'TO' FIELD, UNPREDICTABLE ON EXIT * T1181200 * R13 - SAVE AREA ADDRESS * T1181300 * R14 - RETURN ADDRESS * T1181400 * R15 - ADDRESS OF 'FROM' FIELD, UNPREDICTABLE ON EXIT * T1181500 * * T1181600 *********************************************************************** T1181700 SPACE 1 R4 T1181800 CNOP 0,8 R4 T1181900 $$VFL STM R2,R4,28(R13) SAVE WORK REGISTERS R4 T1182100 SPACE 1 R4 T1182200 BALR R4,0 PROVIDE LOCAL R4 T1182300 USING *,R4 ADDRESSABILITY R4 T1182400 SPACE 1 R4 T1182500 LR R3,R1 RELOAD 'TO' ADDRESS R4 T1183500 SRL R1,24 EXTRACT INSTRUCTION INDEX R4 T1183600 LA R2,256 PROVIDE CONSTANT FOR LOOP R4 T1183700 SPACE 1 R4 T1183800 VFLCOMPR CLR R0,R2 IF REMAINING LENGTH LE 256, R4 T1183900 BNH VFLLAST BR FOR FINAL OPERATION R4 T1184000 EX R0,VFLINST1(R1) OPERATE ON NEXT 256-BYTE SEGMENT R4 T1184100 ALR R3,R2 POINT TO NEXT R4 T1184200 ALR R15,R2 'TO' AND 'FROM' SEGMENTS R4 T1184300 SLR R0,R2 REDUCE REMAINING FIELD LENGTH R4 T1184400 B VFLCOMPR AND BR TO CONTINUE OPERATION R4 T1184500 SPACE 1 R4 T1184600 CNOP 0,8 R4 T1184700 VFLLAST LR R2,R0 RELOAD AND DECREMENT R4 T1184800 BCTR R2,R0 FOR FINAL EXECUTE R4 T1184900 EX R2,VFLINST2(R1) OPERATE ON REMAINING BYTES R4 T1185000 LM R2,R4,28(R13) RESTORE WORK REGISTERS R4 T1185200 BR R14 AND RETURN R4 T1185600 SPACE 1 R4 T1185700 DROP R4 KILL LOCAL ADDRESSABILITY R4 T1185900 SPACE 1 R4 T1186100 VFLINST1 NC 0(256,R3),0(R15) *** EXECUTE ONLY *** R4 T1186200 OC 0(256,R3),0(R15) *** EXECUTE ONLY *** R4 T1186300 XC 0(256,R3),0(R15) *** EXECUTE ONLY *** R4 T1186400 SPACE 1 R4 T1186500 VFLINST2 NC 0(*-*,R3),0(R15) *** EXECUTE ONLY *** R4 T1186600 OC 0(*-*,R3),0(R15) *** EXECUTE ONLY *** R4 T1186700 XC 0(*-*,R3),0(R15) *** EXECUTE ONLY *** R4 T1186800 TITLE 'HASP SUBSYSTEM SUPPORT MODULE - CELL CONTROL' R4 T1191500 *********************************************************************** T1191600 * * T1191700 * $SVGCELL - SUBROUTINE TO GET A FREE CELL * T1191800 * * T1191900 * REGISTERS - * T1192000 * * T1192100 * R0 = ADDRESS OF SJB * T1192200 * R1 = ADDRESS OF TCB * T1192300 * R2 = WORK * T1192400 * R3 = WORK * T1192500 * R4 = LENGTH - ALTERED TO (LENGTH-1)/256 * T1192600 * R7 = WORK * T1192700 * R11 = SSVT * T1192800 * R14 = RETURN - (R14+0=ERROR, R14+4=OK) * T1192900 * R15 = ENTRY BASE * T1193000 * * T1193100 *********************************************************************** T1193200 USING CCEDSECT,R7 T1193300 TSGCELL DS 0H T1193400 USING *,R15 T1193500 BCTR R4,0 CALCULATE T1193600 SRA R4,8 (B-1)/256= NUM 256 BYTE BLKS -1 T1193700 LA R7,$SVCELLS-(CCECCE-CCEDSECT) POINT TO CELL 0 T1194000 TSGCL L R7,CCECCE POINT TO NEXT CELL CONTROL T1194500 LTR R7,R7 END T1195000 BZR R14 EXIT WITH NOT FOUND T1195500 CLM R4,1,CCECSIZ CHECK FOR SIZE OK T1196000 BH TSGCL GET NEXT CELL IF REQUEST HIGH T1196500 BLR R14 EXIT WITH NOT FOUND IF LOW T1197000 * TEST CELL FOR AVAILABLE T1197500 LM R2,R3,CCESJB+CCETCB-CCETCB PICK UP ALLOCATION WORDS T1198000 TSGCE LTR R2,R2 IS CELL AVAILABLE T1198500 BNZ TSGCL LOOP IF NOT T1199000 CDS R2,R0,CCESJB CLAIM T1199500 BNZ TSGCE LOOP IF NOT CLAIMED T1200000 * CELL CLAIMED T1200500 L R1,CCECLOC-1 POINT TO LOCATION T1201000 LA R1,0(0,R1) PURIFY T1201500 ST R7,0(0,R1) SET LOCATION FOR FREEING T1202000 B 4(0,R14) RETURN T1202500 EJECT T1203000 *********************************************************************** T1203500 * * T1204000 * $SVGCPOL - SUBROUTINE TO TELL HASP MORE CELLS ARE NEEDED * T1204500 * * T1205000 * REGISTERS - * T1205500 * * T1206000 * R0 = ADDRESS OF USER ECB * T1206500 * R1 = WORK * T1207000 * R2 = WORK * T1207500 * R3 = WORK * T1208000 * R4 = (LENGTH-1)/256 * T1208500 * R7 = WORK * T1209000 * R11 = ADDRESS OF SSVT * T1209500 * R14 = RETURN * T1210000 * R15 = ENTRY BASE * T1210500 * * T1211000 * NOTES - * T1211500 * * T1212000 * AN ENQ USING $SVCENQ LIST MUST BE HELD BEFORE ENTRY. * T1212500 * * T1213000 *********************************************************************** T1213500 TSGCPOL DS 0H T1214000 USING *,R15 T1214500 LR R1,R0 POINT TO ECB T1215000 MVI 0(R1),0 INSURE ZERO T1215500 LR R1,R11 SAVE SSVT BASE T1216000 LR R2,R12 SAVE USER BASE T1216500 LR R3,R13 SAVE SJB OR SAVE AREA BASE T1217000 LR R7,R14 SAVE RETURN T1217500 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=($SVCPOST,*-*,*-CT1218000 *) T1218500 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,RELATED=($SVCPOST,*-*,*-*) T1219000 LR R11,R1 PUT SSVT BASE BACK T1219500 L R1,PSAAOLD-PSA PICK UP ASCB ADDRESS T1220000 ST R4,$SVCTREQ SET CELL TYPE T1220500 STM R0,R1,$SVCPOST SET ECB AND ASCB ADDRESSES T1221000 LR R1,R11 RESAVE SSVT BASE T1221500 SETLOCK RELEASE,TYPE=CMS,RELATED=($SVCPOST,*-*,*-*) T1222000 SETLOCK RELEASE,TYPE=LOCAL,RELATED=($SVCPOST,*-*,*-*) T1222500 LR R11,R1 RESTORE T1223000 LR R12,R2 SAVED T1223500 LR R13,R3 REGISTERS T1224000 LR R3,R0 COPY ECB POINTER T1224500 $$POST ELMT=$SVASYNC TELL HASP T1225000 LTR R15,R15 IS HASP STILL UP T1225500 BALR R15,0 REESTABLISH BASE T1226000 USING *,R15 T1226500 BNZ TSGCPOLA SKIP WAIT IF NOT T1227000 WAIT ECB=(R3) WAIT FOR HASP T1227500 TSGCPOLA LR R14,R7 RESTORE RETURN T1228000 BR R14 EXIT T1228500 EJECT T1229000 *********************************************************************** T1229500 * * T1230000 * $SVFCELL - SUBROUTINE TO FREE A CELL BY ADDRESS * T1230500 * * T1231000 * REGISTERS - * T1231500 * * T1232000 * R0 = WORK * T1232500 * R1 = ADDRESS OF CELL STORAGE * T1233000 * R2 = WORK * T1233500 * R3 = WORK * T1234000 * R7 = WORK * T1234500 * R11 = SSVT * T1235000 * R14 = RETURN * T1235500 * R15 = ENTRY BASE * T1236000 * * T1236500 *********************************************************************** T1237000 TSFCELL DS 0H T1237500 USING *,R15 T1238000 L R7,0(0,R1) POINT TO CELL CONTROL T1238500 SLR R0,R0 ZERO FOR SJB T1239000 ST R0,CCESJB FREE THE CELL T1239500 CLI CCECSIZ,(512-1)/256 CHECK FOR LARGE CELL T1240000 BNHR R14 EXIT T1240500 MVI $SVVARF,X'FF' TELL HASP TO FREE ASAP T1241000 BR R14 RETURN T1241500 * HASP WILL FREE ON NEXT ASYNC FUNCTION T1242000 EJECT T1242500 *********************************************************************** T1243000 * * T1243500 * $SVFCELA - SUBROUTINE TO FREE STORAGE BY SJB/TCB ADDRESS * T1244000 * * T1244500 * REGISTERS - * T1245000 * * T1245500 * R0 = ADDRESS OF SJB * T1246000 * R1 = ADDRESS OF TCB OR ZERO * T1246500 * R2 = WORK * T1247000 * R3 = WORK * T1247500 * R7 = WORK * T1248000 * R11 = ADDRESS OF SSVT * T1248500 * R14 = RETURN * T1249000 * R15 = ENTRY BASE (HIGH BYTE ZERO ON ENTRY) * T1249500 * * T1250000 *********************************************************************** T1250500 TSFCELA DS 0H T1251000 USING *,R15 T1251500 LTR R1,R1 TEST FOR TCB GIVEN T1252000 BZ *+8 SKIP NSI IF NOT T1252500 ICM R15,8,=X'80' TURN ON TCB REQUIRED FLAG T1253000 SLR R2,R2 SET UNALLOCATED INDICATOR T1253500 LA R7,$SVCELLS-(CCECCE-CCEDSECT) POINT TO HEADER T1254000 TSFCELAL L R7,CCECCE POINT TO NEXT CCE T1254500 LTR R7,R7 TEST FOR END T1255000 BZR R14 EXIT IF END T1255500 C R0,CCESJB DOES SJB MATCH T1256000 BNE TSFCELAL LOOP IF NOT T1256500 LTR R15,R15 TEST FOR TCB MATCH REQUIRED T1257000 BP TSFCELLN FREE CELL NOW IF NOT T1257500 C R1,CCETCB TEST FOR TCB MATCH T1258000 BNE TSFCELAL LOOP IF NOT T1258500 TSFCELLN ST R2,CCESJB UNALLOCATE CELL T1259000 CLI CCECSIZ,(512-1)/256 CHECK FOR LARGE CELL T1259500 BNH TSFCELAL LOOP IF NOT T1260000 MVI $SVVARF,X'FF' TELL HASP TO FREE ASAP T1260500 B TSFCELAL LOOP T1261000 EJECT T1261500 *********************************************************************** T1262000 * * T1262500 * $SVGCMNS - SUBROUTINE TO GET CELLS AND CELL ELEMENTS * T1263000 * * T1263500 * REGISTERS - * T1264000 * * T1264500 * R0 = CLAIM CODE - WORK * T1265000 * R1 = WORK - ON EXIT CONTAINS ADDRESS OF STORAGE OR ZERO * T1265500 * R2 = WORK * T1266000 * R3 = WORK * T1266500 * R4 = (B-1)/256 = NUMBER OF 256 BYTE BLOCKS REQUIRED * T1267000 * R7 = WORK - ON EXIT CONTAINS ADDRESS OF CCE OR ZERO * T1267500 * R11 = ADDRESS OF SSVT * T1268000 * R14 = RETURN * T1268500 * R15 = ENTRY BASE * T1269000 * * T1269500 * NOTES - * T1270000 * * T1270500 * THIS ROUTINE IS ENTERED IN KEY 1 BY 'SAFE TASKS' WHEN A * T1271000 * CELL MUST BE GOTTEN WITHOUT WAITING FOR HASP. * T1271500 * * T1272000 *********************************************************************** T1272500 TSGCMNS DS 0H T1273000 USING *,R15 T1273500 L R2,=X'FF000000' PICK UP FREE STORAGE INDICATION T1274000 LA R7,$SVCELLS-(CCECCE-CCEDSECT) POINT TO CELL HEAD T1274500 TSGCMNSL LR R1,R7 SAVE PREVIOUS ELEMENT T1275000 L R7,CCECCE POINT TO NEXT CCE T1275500 LTR R7,R7 CHECK FOR END T1276000 BZ TSGCMNSB EXIT IF END T1276500 CLM R4,1,CCECSIZ TEST CELL SIZE T1277000 BH TSGCMNSL LOOP T1277500 BL TSGCMNSB BUILD CCE IF BEYOND T1278000 C R2,CCESJB TEST FOR FREE T1278500 BNE TSGCMNSL LOOP T1279000 L R3,CCETCB PICK UP SECOND WORD T1279500 CDS R2,R0,CCESJB CLAIM T1280000 BNE TSGCMNS LOOP IF NOT CLAIMED T1280500 TSGCMNSG LA R0,1(0,R4) (B-1)/256+1 = NUMBER 256 BYTE BLOCKS T1281000 SLA R0,8 STORAGE SIZE T1281500 LR R3,R14 COPY RETURN REGISTER T1282000 GETMAIN RC,LV=(0),SP=231 GET STORAGE T1282500 LTR R15,R15 SET CONDITION CODES T1283000 L R15,$SVGCMNS ESTABLISH BASE T1283500 LR R14,R3 ESTABLISH RETURN T1284000 BNZ TSGCMNSE ERROR T1284500 ST R7,0(0,R1) SET CCE LOCATION T1285000 STCM R1,7,CCECLOC SET LOCATION T1285500 BR R14 EXIT WITH R7 POINTING TO ELEMENT T1286000 TSGCMNSE ST R2,CCESJB FREE THE CCE T1286500 TSGCMNSX SLR R7,R7 ZERO R7 T1287000 SLR R1,R1 ZERO R1 T1287500 BR R14 EXIT T1288000 TSGCMNSB LR R7,R1 BACK UP TO LAST CCE T1288500 TSGCMNSQ L R1,$SVCELLF POINT TO FIRST FREE QUEUE CCE T1289000 TSGCMNST LTR R1,R1 TEST FOR PRESENT T1289500 BZ TSGCMNSC EXIT IF MORE ARE REQUIRED T1290000 L R3,CCECCE-CCEDSECT(,R1) PICK UP CHAIN FIELD T1290500 CS R1,R3,$SVCELLF REMOVE T1291000 BNZ TSGCMNST LOOP IF NOT REMOVED T1291500 STC R4,CCECSIZ-CCEDSECT(,R1) SET SIZE INDICATION T1292000 ST R0,CCESJB-CCEDSECT(,R1) SET ID T1292500 TSGCMNSR L R3,CCECCE POINT TO NEXT T1293000 ST R3,CCECCE-CCEDSECT(,R1) SET INTO CURRENT T1293500 CS R3,R1,CCECCE CHAIN CCE T1294000 BNZ TSGCMNSR RETRY T1294500 LR R7,R1 POINT TO CURRENT T1295000 B TSGCMNSG GET MAIN FOR ELEMENT T1295500 TSGCMNSC LR R3,R14 SAVE RETURN T1296000 LR R2,R0 SAVE OWNER ID T1296500 GETMAIN RC,LV=CCEL*64,SP=231 GET ROOM FOR 64 CCES T1297000 LR R0,R2 RESTORE OWNERSHIP ID T1297500 LR R14,R3 RESTORE RETURN T1298000 LTR R15,R15 SET CONDITION CODES T1298500 L R15,$SVGCMNS PICK UP BASE T1299000 BNZ TSGCMNSX ERROR EXIT T1299500 LA R3,64 SET NUMBER OF CCES IN BLOCK T1300000 TSGCMNSF L R2,$SVCELLF POINT TO OLD FREE QUEUE T1300500 ST R2,CCECCE-CCEDSECT(,R1) PUT OLD BEHIND T1301000 CS R2,R1,$SVCELLF PUT NEW ON FRONT T1301500 BNZ *-8 LOOP IF NO GO T1302000 LA R1,CCEL(,R1) UP 1 CCE T1302500 BCT R3,TSGCMNSF LOOP FOR ALL CCES T1303000 L R2,=X'FF000000' RESTORE FREE ID T1303500 B TSGCMNSQ LOOP T1304000 DROP R7 T1304500 DROP R15 T1305000 LTORG T1305500 TITLE '$PROLOG -- SUBSYSTEM FUNCTION ENTRY ROUTINE' T1306000 RSOX EQU R10 DEFINE SSOB EXT BASE REG. T1306500 RSVT EQU R11 DEFINE SSVT BASE REGISTER. T1307000 RSIB EQU R8 DEFINE SSIB BASE REGISTER. T1307500 RSJB EQU R13 DEFINE SJB BASE REGISTER. T1308000 $PROLOG DS 0H T1308500 * T1309000 * SAVE REGISTERS AND SET ADDRESSABILITY T1309500 * T1310000 STM R14,R12,12(R13) SAVE REGISTERS. T1310500 BALR R12,0 ESTABLISH BASE REGISTER. T1311000 SSPLBASE DS 0H T1311500 USING *,R12 SET LOCAL ADDRESSABILITY. T1312000 * T1312500 * SAVE ENTRY KEY AND SET KEY ZERO T1313000 * T1313500 MODESET EXTKEY=ZERO,SAVEKEY=16(,R13),WORKREG=2 SET KEY. T1314000 * T1314500 * SET UP REGISTERS --- T1315000 * RSIB (R8) POINTS TO SSIB T1315500 * RSOX (R10) POINTS TO SSOB EXTENSION T1316000 * RSVT (R11) POINTS TO SSVT T1316500 * T1317000 USING SSOBEGIN,R1 SET MAIN SSOB ADDRESSABILITY. T1317500 L RSIB,SSOBSSIB POINT R8 TO SSIB. T1318000 USING SSIBEGIN,RSIB SET ADDRESSABILITY FOR SSIB. T1318500 L RSOX,SSOBINDV POINT R10 TO SSOB EXTENSION. T1319000 LR RSVT,R0 LET SSCVT BE ADDRESSED. T1319500 L RSVT,SSCTSSVT-SSCT(,RSVT) POINT R11 TO SSVT. T1320000 USING SSOBGN,RSOX SET SSOB EXTENSION ADDRESSAB. T1320500 * T1321000 * IF SJB LOCK NOT WANTED, SKIP LOCK LOGIC T1321500 * T1322000 TM 0(R15),X'80' IF NO LOCK WANTED, T1322500 BZ SSPLRET GO ENTER SUBSYSTEM FUNCTION. T1323000 CLI 1(R15),SSOBEOT END-OF-TASK... R41 T1323100 BNE SSPLNEOT BR IF NO (OK) R41 T1323200 L R6,PSATOLD-PSA POINT TO CURRENT TCB R41 T1323300 USING TCB,R6 PROVIDE TCB ADDRESSABILITY R41 T1323400 L R6,TCBJSCB POINT TO JSCB R41 T1323500 USING JSCB,R6 PROVIDE JSCB ADDRESSABILITY R41 T1323600 L R6,JSCBACT POINT TO ACTIVE JSCB R41 T1323700 L R5,JSCBSSIB POINT TO SSIB @OZ57048 T1323800 ICM R6,15,SSIBSUSE-SSIBEGIN(R5) DOES SJB EXIST... @OZ57048 T1323900 BZ SSPLRET1 BR IF NO R41 T1324000 USING SJBDSECT,R6 PROVIDE SJB ADDRESSABILITY R41 T1324100 L R2,$SVHAVT GET HAVT @OZ57048 T1324110 L R3,PSAAOLD-PSA GET ASID @OZ57048 T1324120 LH R3,ASCBASID-ASCBEGIN(,R3) FOR INDEX @OZ57048 T1324130 SLL R3,2 INTO HAVT @OZ57048 T1324140 L R4,0(R3,R2) GET SJB FOR THIS ASID @OZ57048 T1324150 LTR R4,R4 SJB FOR THIS JES2... @OZ57048 T1324152 BZ SSPLRET1 BR IF NO @OZ57048 T1324154 CLC SJBTCBP-SJBDSECT(,R4),PSATOLD-PSA STC TCB... @OZ57048 T1324160 BNE SSPLNSTC BR IF NO @OZ57048 T1324170 MVC SSIBSUSE-SSIBEGIN(,R5),=XL4'00' ZERO SJB ADDR @OZ57048 T1324180 B SSPLRET1 BR TO RETURN @OZ57048 T1324190 SSPLNSTC CLI SJBXQFN1+1,SSOBJBSL JOB IN JOB SELECT... @OZ57048 T1324200 BE SSPLRET1 BR IF YES R41 T1324300 TM SJBFLG1,SJB1XBMC XBM CONTINUATION... R41 T1324400 BZ SSPSJBCK BR IF NO (OK) R41 T1324500 SPACE 1 R41 T1324600 SSPLRET1 MODESET KEYADDR=16(,R13),WORKREG=2 SET CALLER'S KEY R41 T1324700 RETURN (14,12),RC=0 RETURN TO CALLER R41 T1324800 * T1324900 * POINT TO SJB FROM EITHER CURRENT SSIB OR, T1325000 * IF USER REQUIRES, FROM JSCB'S SSIB. T1325100 * T1325200 SSPLNEOT DS 0H R41 T1325300 L R6,SSIBSUSE GET SJB POINTER FROM SSIB. T1325500 LTR R6,R6 IF NON-ZERO POINTER, T1326000 BNZ SSPSJBCK GO CHECK IT. T1326500 TM 0(R15),X'60' IF LOCK NOT =SDB OR =REQ, T1327000 BZ SSPNSDB BRANCH. T1327500 L R6,PSATOLD-PSA POINT TO CURRENT TCB. T1328000 USING TCB,R6 GET ADDRESSABILITY. T1328500 L R6,TCBJSCB POINT TO JSCB FROM TCB. T1329000 USING JSCB,R6 GET ADDRESSABILITY. T1329500 L R6,JSCBACT POINT TO ACTIVE JSCB R41 T1329600 L R6,JSCBSSIB POINT TO SSIB FROM JSCB. T1330000 DROP RSIB DROP OLD SSIB BASE. T1330500 USING SSIBEGIN,R6 GET ADDRESSABILITY. T1331000 L R6,SSIBSUSE POINT TO SJB FROM SSIB. T1331500 USING SJBDSECT,R6 SET SJB ADDRESSABILITY. T1332000 USING SSIBEGIN,RSIB RESTORE SSIB ADDRESSABILITY. T1332500 SSPSJBCK DS 0H T1333000 CLC SJBSSNM,$SVSSNM DONT LOCK IF THIS SJB @OZ15844 T1333100 BNE SSPNSDB DOES NOT BELONG TO US @OZ15844 T1333200 CLC SJBID,=CL4'SJB' IF SJB ID IS OKAY, T1333500 BE SSPACQL GO GET THE LOCK. T1334000 * T1334500 * IF SJB REQUIRED BUT NOT FOUND, ERROR T1335000 * T1335500 SSPNSDB TM 0(R15),X'40' IS LOCK=REQ... T1336000 BZ SSPLRET IF NOT, ENTER SUBSYS FUNCTION. T1336500 MODESET KEYADDR=16(,R13),WORKREG=2 ELSE SET CALLER KEY T1337000 RETURN (14,12),RC=SSRTNSUP AND GIVE CODE TO CALLER. T1337500 DROP R1 DROP SSOB BASE. T1338000 EJECT T1338500 * T1339000 * FORMAT OF LOCK HEADER (SJBLOCKH) --- T1339500 * +0 - TCB UNDER WHICH SJB IS LOCKED. VALID ONLY T1340000 * IF +4 IS NONZERO. T1340500 * +4 - ZERO MEANS SJB IS UNLOCKED. T1341000 * - MINUS MEANS SJB LOCKED, NO WAITERS. T1341500 * - PLUS - POINTS TO MOST-RECENT LOCK ELEMENT. T1342000 * T1342500 * FORMAT OF LOCK ELEMENT --- T1343000 * +0 - EVENT CONTROL BLOCK T1343500 * +4 - ZERO IS INVALID T1344000 * - MINUS MEANS NO MORE WAITERS (ELEMENTS). T1344500 * - PLUS - POINTS TO NEXT WAITER. T1345000 * +8 - ADDRESS OF WAITING CALLER'S TCB T1345500 * T1346000 SSPACQL DS 0H T1346500 * @OZ40161 T1346600 * ASYNCHRONOUS INTERRUPTS MUST BE PROHIBITED WHILE A USER OF @OZ40161 T1346620 * HASPSSSM HOLDS OR WAITS FOR THE SJB LOCK. THIS RESTRICTION @OZ40161 T1346640 * PREVENTS AN INTERLOCK SITUATION FROM ARISING IF AN IRB @OZ40161 T1346660 * MAKES A SUBSYSTEM REQUEST WHILE A 'BURIED' PRB HOLDS THE @OZ40161 T1346680 * LOCK. BIT TCBFX IN TCBFLGS1, WHICH PREVENTS ASYNCHRONOUS @OZ40161 T1346700 * INTERRUPTS, WILL BE RESET TO ITS INITIAL VALUE WHEN THE @OZ40161 T1346720 * LOCK IS RELINQUISHED. @OZ40161 T1346740 * @OZ40161 T1346760 L R8,PSATOLD-PSA GET CURRENT TCB @OZ40161 T1346780 USING TCB,R8 SET TCB ADDRESSABILITY @OZ40161 T1346800 TM TCBFLGS1,TCBFX IF NO IRB'S ALLOWED... @OZ40161 T1346820 BO SSPLK02 SKIP. @OZ40161 T1346840 OI TCBFLGS1,TCBFX ELSE PROHIBIT THEM NOW @OZ40161 T1346860 B SSPLK04 SKIP NEXT. @OZ40161 T1346880 SSPLK02 SLR R8,R8 REMEMBER CALLER DID IT. @OZ40161 T1346900 DROP R8 DROP TCB ADDRESSABILITY @OZ40161 T1346920 SSPLK04 DS 0H @OZ40161 T1346940 * T1347000 * TRY GETTING LOCK BEFORE GETTING LOCK ELEMENT T1347500 * T1348000 SLR R0,R0 ZERO OUT T1348500 LR R1,R0 R0 AND R1. T1349000 L R2,PSATOLD-PSA POINT R2 TO CURRENT TCB T1349500 LNR R3,R2 AND MAKE R3 MINUS. T1350000 CDS R0,R2,SJBLOCKH IF SJB IS UNLOCKED, T1350500 BNE SSPLK06 (SJB IS LOCKED, GO WAIT) @OZ40161 T1351000 LTR R8,R8 SEE IF $PROLOG SET TCBFX @OZ40161 T1351050 BNZ SSPLK3 GO TO SERVICE IF SO @OZ40161 T1351100 OI SJBLKFG,SJBFX ELSE DON'T RESET AT EXIT @OZ40161 T1351150 B SSPLK3 GO TO SERVICE NOW @OZ40161 T1351200 SSPLK06 DS 0H @OZ40161 T1351250 * T1351500 * SJB IS ALREADY LOCKED. SEE IF PURGE REQUIRED. T1352000 * T1352500 LR R3,R1 SET LOCK CHAINWORD IN R3. T1353000 LR R1,R0 SET R1=OWNING TCB. T1353500 USING TCB,R1 SET TCB ADDRESSABILITY. T1354000 CLR R1,R2 IF LOCK HOLDER IS CURRENT TCB, T1354500 BE SSPLK10 PURGE LOCK HOLDER. T1355000 LRA R1,0(,R1) IS ADDRESS VALID... R41 T1355100 BC 7,SSPLK10 BR IF NO TO PURGE LOCK R41 T1355200 LR R1,R0 REFRESH TCB POINTER R41 T1355300 CLC TCBTCBID,=C'TCB ' IS THIS A TCB... R41 T1355400 BNE SSPLK10 BR IF NO TO PURGE LOCK R41 T1355500 TM TCBFLGS5,TCBFC+TCBABWF UNLESS HE'S DYING, R41 T1355600 BNZ SSPLK10 IF SO, PURGE LOCK @OZ37207 T1356000 TM TCBFLGS1,TCBFA IF HOLDER NOT IN ABTERM, @OZ37207 T1356050 BZ SSPLK20 ...GO WAIT FOR LOCK @OZ37207 T1356100 SSPLK05 ICM R1,15,TCBLTC ELSE EXAMINE SUBTASK CHAIN @OZ37207 T1356150 BZ SSPLK20 ...NO MORE, WAIT FOR LOCK @OZ37207 T1356200 CLR R1,R2 IF CURRENT TCB NOT SUBTASK @OZ37207 T1356250 BNE SSPLK05 TRY NEXT SUBTASK @OZ37207 T1356300 DROP R1 DROP TCB ADDRESSABILITY. T1356500 * T1357000 * PURGE REQUIRED. CALL SUBROUTINE TO PURGE. T1357500 * T1358000 SSPLK10 DS 0H T1358500 LR R2,R0 SET LOCK OWNER'S TCB IN R2. T1359000 BAL R4,$TESTLLK GO PURGE THE LOCK HOLDER. T1359500 BC 8+4,SSPLK04 NO NEW HOLDER, TRY AGAIN @OZ40161 T1360000 * T1360500 * $TESTLLK FOUND AND POSTED A GOOD WAITER. T1361000 * THEREFORE WE MUST GET A LOCK ELEMENT. T1361500 * T1362000 SSPLK20 DS 0H T1362500 $GETMAIN RU,SP=241,LV=16,KEY=0 GET LOCK ELEMENT. T1363000 LR R5,R1 POINT R5 TO NEW ELEMENT. T1363500 SPACE 2 @OZ19265 T1363550 CLI SJBXQFN1+1,SSOBTERM IF NOT IN TERMINATION @OZ19265 T1363600 BNE SSPLK21 ...CONTINUE @OZ19265 T1363650 LR R7,R8 ELSE SAVE TCBFX INDICATOR, @OZ40161 T1363670 LA R8,X'45' SET ABORT INDICATOR, @OZ40161 T1363700 B SSPLK2 AND ESCAPE @OZ19265 T1363750 SPACE 2 @OZ19265 T1363800 SSPLK21 DS 0H @OZ19265 T1363850 * T1364000 * NOW WE HAVE AN ELEMENT. TRY AGAIN FOR LOCK. T1364500 * T1365000 SLR R0,R0 ZERO REGISTER 0. T1365500 ST R0,0(,R5) ZERO OUT ECB. T1366000 LR R7,R8 SAVE TCBFX INDICATOR @OZ40161 T1366100 SSPLK1 LR R1,R0 ZERO REGISTER 1. T1366500 L R2,PSATOLD-PSA POINT R2 TO CURRENT TCB. T1367000 LNR R3,R2 MAKE R3 MINUS. T1367500 CDS R0,R2,SJBLOCKH IF SJB IS NOW UNLOCKED, T1368000 LA R8,0 SET GOOD POST CODE @OZ19265 T1368250 BE SSPLK2 GET LOCK AND FREE ELEMENT. T1368500 STM R1,R2,4(R5) SET CHAIN, TCB IN ELEMENT. T1369000 LR R2,R0 SET UP CDS SO HDR+0 IS UNCHGD, T1369500 LR R3,R5 HDR+4 POINTS TO NEW ELEMENT. T1370000 CDS R0,R2,SJBLOCKH TRY TO GET ON WAITING CHAIN. T1370500 $PLWAIT1 DS 0H SYMBOL USED BY $TESTLLK. T1371000 LA R0,0 ZERO R0 BUT DON'T TOUCH CC. T1371500 BNE SSPLK1 IF CDS FAILED, REPEAT. T1372000 * T1372500 * WE'RE NOW ON WAITING CHAIN. ISSUE WAIT. T1373000 * T1373500 WAIT 1,ECB=(R5) WAIT FOR SJB LOCK. T1374000 $PLWAIT2 DS 0H SYMBOL USED BY $TESTLLK. T1374500 L R8,0(,R5) GET POST CODE @OZ19265 T1374660 LA R8,0(,R8) ZERO HIGH ORDER BYTE @OZ19265 T1374820 * T1375000 * AFTER WAIT, FREE THE LOCKING ELEMENT. T1375500 * T1376000 SSPLK2 DS 0H T1376500 * @OZ40161 T1376520 * R7 (TCBFX INDICATOR) WILL BE LOST OVER $FREMAIN. @OZ40161 T1376540 * THEREFORE, THIS IS A GOOD TIME TO NOTE IN THE SJB @OZ40161 T1376560 * WHETHER ASYNCHRONOUS INTERRUPTS WERE PROHIBITED WHEN @OZ40161 T1376580 * SSSM WAS ENTERED, IF WE HOLD THE SJB LOCK. @OZ40161 T1376600 * OF COURSE, IF WE DON'T HAVE THE LOCK, TCBFX SHOULD @OZ40161 T1376620 * BE RESET TO ITS ORIGINAL VALUE BEFORE EXITING. @OZ40161 T1376640 * @OZ40161 T1376660 LTR R8,R8 DO WE HAVE THE SJB LOCK... @OZ40161 T1376680 BNZ SSPLK22 NO, POST CODE IS NONZERO @OZ40161 T1376700 LTR R7,R7 YES, DID WE SET TCBFX... @OZ40161 T1376720 BNZ SSPLK23 YES, WE'LL RESTORE IT. @OZ40161 T1376740 OI SJBLKFG,SJBFX NO, WE'LL LEAVE IT... @OZ40161 T1376760 B SSPLK23 WHEN WE GIVE UP THE SJB @OZ40161 T1376780 SSPLK22 LTR R7,R7 NO LOCK, SEE WHO SET TCBFX @OZ40161 T1376800 BZ SSPLK23 CALLER SET IT, LET IT BE. @OZ40161 T1376820 NI TCBFLGS1-TCB(R7),255-TCBFX ELSE LET IRB'S RUN @OZ40161 T1376840 SSPLK23 DS 0H @OZ40161 T1376860 $FREMAIN RU,A=(R5),SP=241,LV=16,KEY=0 FREE ELEMENT. T1377000 LTR R8,R8 IF POSTED BY TERMINATION @OZ19265 T1377160 BNZ SSPLRET1 ...WAVE GOODBYE @OZ19265 T1377320 SSPLK3 DS 0H T1377500 * T1378000 * WE HAVE SJB LOCK. ABORT INTERRUPTED FUNCTIONS T1378500 * T1379000 SLR R15,R15 ZERO USER BASE T1379500 CH R15,SJBXQFN1 DID WE INTERRUPT A FUNCTION T1380000 BZ SSPLNFUN SKIP ABORT ROUTINES IF NO T1380500 CLC SJBXQFN1,=Y(SSOBRTRN) IS IT TOO BIG T1381000 BH SSPLNFUN SKIP ABORT ROUTINES IF YES T1381500 LR R8,R6 COPY SJB POINTER T1382000 LH R15,SJBXQFN1 PICK UP FUNCTION T1382500 ALR R15,R15 DOUBLE T1383000 L R12,SSPLEOTB POINT TO ABORT ROUTINE BASE T1383500 LH R15,HETTAB-HOSEOTB(R15,R12) PICK UP ENTRY T1384000 BAL R14,0(R15,R12) ENTER ABORT ROUTINE T1384500 USING *,R14 T1385000 L R12,=A(SSPLBASE) PICK UP OUR BASE T1385500 DROP R14 T1386000 LR R6,R8 RETURN SJB POINTER T1386500 SSPLNFUN DS 0H T1387000 * T1387500 * WE NOW OWN SJB LOCK. CHAIN SAVE AREAS. T1388000 * T1388500 LM R15,R1,16(R13) RESTORE REGS 15 THROUGH 1. T1389000 USING SSOBEGIN,R1 SET SSOB ADDRESSABILITY. T1389500 L RSIB,SSOBSSIB POINT TO SSIB T1390000 LA R15,0(,R15) ZERO REGISTER 15 BYTE 0. T1390500 ST R6,8(,R13) BACK-CHAIN SAVE AREA. T1391000 ST R13,4(,R6) FORWARD-CHAIN SAVE AREA. T1391500 LR RSJB,R6 POINT R13 TO SJB SAVE AREA. T1392000 DROP R6 DROP OLD SJB BASE. T1392500 USING SJBDSECT,RSJB USE NEW SJB BASE. T1393000 O R15,=X'80000000' SHOW SJB LOCK HELD. T1393500 MVC SJBXQFN1,SSOBFUNC SHOW FUNCTION IN PROCESS. T1394000 * T1394500 * ENTER SUBSYSTEM FUNCTION HERE T1395000 * T1395500 SSPLRET DS 0H T1396000 LA R12,4 GET CONSTANT FOUR. T1396500 ALR R12,R15 SET SUBSYS FUNC ADDRESSABILITY. T1397000 BR R12 ENTER FUNCTION. T1397500 SSPLEOTB DC 0F'0',X'80',AL3(HOSEOTB) END OF TASK BASE T1398000 TITLE '$EPILOG -- SUBSYSTEM FUNCTION EXIT ROUTINE' T1398500 $EPILOG DS 0H T1399000 USING *,R14 SET LOCAL ADDRESSABILITY. T1399500 * T1400000 * SAVE RETURN CODE IN R0 SAVE AREA SLOT T1400500 * T1401000 ST R15,20(,R13) SAVE RETURN CODE. T1401500 * T1402000 * IF NO SJB LOCK, JUST RETURN TO CALLER. T1402500 * T1403000 LTR R12,R12 IF SJB LOCK, R12 IS NEGATIVE. T1403500 BNM SSENOLK BRANCH IF NO LOCK HELD. T1404000 * T1404500 * SJB LOCK. SHOW NO FUNCTION ACTIVE. T1405000 * T1405500 SLR R0,R0 ZERO R0 AND MAKE T1406000 STH R0,SJBXQFN1 SJBXQFN1 ZERO. T1406500 * T1407000 * SJB LOCK. DECHAIN SJB SAVE AREA. RE-SAVE T1407500 * RETURN CODE. T1408000 * T1408500 LR R4,R13 USE R4 AS SJB POINTER. T1409000 L R13,4(,R13) POINT TO ORIGINAL SAVE AREA. T1409500 ST R15,20(,R13) RE-SAVE RETURN CODE AT R0. T1410000 DROP RSJB SWITCH SJB ADDRESSABILITY T1410500 USING SJBDSECT,R4 TO R4. T1411000 L R1,SJBFLOW PICK UP OLD FLOW FLAGS. T1411500 SSELKA TM SJBTFFG,SJBTFFGP TEST FOR PURGE ON. T1412000 BO SSELKB GO TO PURGE IF YES. T1412500 CS R1,R0,SJBFLOW ZERO FLAGS. T1413000 BNZ SSELKA LOOP IF NOT SET. T1413500 B SSELKC CONTINUE UNLOCK. T1414000 * T1414500 * PURGE PSO FROM THE SJB T1415000 * T1415500 SSELKB NI SJBTFFG,255-SJBTFFGM RESET ECB MEANINGFULL. T1416000 MVI SJBTFLOW,X'0' RESET QUEUE STATUS. T1416500 ICM R6,15,SJBPSOP PICK UP PSO POINTER. T1417000 BZ SSELKC EXIT IF EMPTY. T1417500 LR R13,R4 PUT SJB POINTER BACK IN R13. T1418000 OI PSOFLG2-PSODSECT(R6),SSSOCTRL SET TERMINATE PSO. T1418500 LA R8,SSOBSOUT SET FUNCTION ID R41 T1419000 STH R8,SJBXQFN1 IN CASE OF ABEND R41 T1419500 ICM R12,7,=AL3(PSOBASE) POINT TO PSO QUEUE ROUTINE BASE. T1420000 BAL R8,PSOQUEUE-PSOBASE(R12) CALL PSO QUEUEING ROUTINE. T1420500 USING *,R8 T1421000 L R14,=A($EPILOG) GET BASE BACK. T1421500 DROP R8 T1422000 SLR R0,R0 ZERO R0. T1422500 LR R4,R13 RESET R4 POINTER TO SJB. T1423000 L R13,4(,R13) RESET R13 POINTER TO USER SAVE. T1423500 STH R0,SJBXQFN1 RESET FUNCTION INDICATOR. T1424000 SSELKC ST R0,SJBFLOW RESET FLOW FLAGS. T1424500 SLR R8,R8 ASSUME TCBFX SET AT ENTRY @OZ40161 T1424600 TM SJBLKFG,SJBFX WAS IT ON AT ENTRY TO SSSM @OZ40161 T1424650 BO SSELKD YES, SKIP @OZ40161 T1424700 L R8,PSATOLD-PSA NO, GET TCB@ TO CHANGE @OZ40161 T1424750 SSELKD NI SJBLKFG,255-SJBFX RESET SJB FOR NEXT OWNER @OZ40161 T1424800 * T1425000 * USE SUBROUTINE $TESTLLK TO RELEASE LOCK T1425500 * T1426000 LR R6,R4 POINT R6 TO SJB. T1426500 LM R2,R3,SJBLOCKH SET R2, R3 EQUAL TO HEADER. T1427000 BAL R4,$TESTLLK CALL $TESTLLK TO RELEASE LOCK. T1427500 BC 4,$TESTLLK IF CDS FAILED, TRY AGAIN. T1428000 LTR R8,R8 ARE WE TO RESET TCBFLGS1.. @OZ40161 T1428100 BZ SSENOLK NO, JUST LEAVE IT @OZ40161 T1428150 USING TCB,R8 YES, SET ADDRESSABILITY @OZ40161 T1428200 NI TCBFLGS1,255-TCBFX ALLOW IRB'S TO RUN @OZ40161 T1428250 DROP R8 DROP ADDRESSABILITY @OZ40161 T1428300 * T1428500 * RESTORE CALLER KEY AND REGISTERS T1429000 * T1429500 SSENOLK DS 0H T1430000 MODESET KEYADDR=16(,R13),WORKREG=2 RESTORE CALLER KEY. T1430500 LM R14,R12,12(R13) RESTORE CALLER REGISTERS. T1431000 * T1431500 * IF NEGATIVE RETURN CODE, RETURN IT POSITIVE IN R15. T1432000 * ELSE STORE IT IN SSOBRETN AND RETURN R15=0. T1432500 * T1433000 LCR R15,R0 IF NEGATIVE RETURN CODE, T1433500 BPR R14 RETURN POSITIVE IN R15. T1434000 ST R0,SSOBRETN ELSE RETURN IT IN SSOBRETN, T1434500 SLR R15,R15 ZERO REGISTER 15, T1435000 BR R14 AND RETURN TO USER. T1435500 DROP , DROP ALL ADDRESSABILITY. T1436000 TITLE '$TESTLLK - PURGE HASP LOCAL LOCK' T1436500 * T1437000 * T1437500 * PURGE SUBROUTINE FOR HASP LOCAL (SJB) LOCK T1438000 * T1438500 * T1439000 $TESTLLK DS 0H T1439500 BALR R15,0 SET LOCAL BASE. T1440000 USING *,R15 SET LOCAL ADDRESSABILITY. T1440500 USING SJBDSECT,R6 SET SJB ADDRESSABILITY. T1441000 * TEST LOCK HEADER CHAIN WORD TO DETERMINE ACTION T1441500 TLL10 DS 0H T1442000 LTR R3,R3 FIND SIGN OF CHAIN WORD. T1442500 * IF MINUS, NO WAITERS EXIST - CLEAR LOCK HEADER T1443000 BM TLL20 IF MINUS NO WAITERS EXIST. T1443500 * IF PLUS, GIVE THE LOCK TO THE FIRST LOCK ELEMENT T1444000 BP TLL30 IF PLUS R3 POINTS TO LOCK ELM. T1444500 * IF ZERO, NOBODY HOLDS THE LOCK T1445000 BZR R4 LOCK AVAILABLE - RETURN CC=0. T1445500 SPACE 3 T1446000 * LOCK HEADER CHAIN WORD IS MINUS T1446500 TLL20 DS 0H T1447000 SLR R0,R0 ZERO R0 T1447500 LR R1,R0 AND R1. T1448000 CDS R2,R0,SJBLOCKH TRY TO RELEASE LOCK. T1448500 BR R4 IF LOCK RELEASED RETURN CC=0, T1449000 * ELSE RETURN CC=1. T1449500 SPACE 3 T1450000 * LOCK HEADER CHAIN WORD IS PLUS T1450500 TLL30 DS 0H T1451000 L R0,8(,R3) POINT R0 TO WAITER'S TCB. T1451500 L R1,4(,R3) GET NEW CHAIN WORD IN R1. T1452000 CDS R2,R0,SJBLOCKH PASS LOCK TO THE WAITER. T1452500 BNER R4 IF FAILURE RETURN CC=1. T1453000 * THE FOLLOWING TESTS DETERMINE WHETHER A POST WILL GIVE CONTROL T1453500 * TO THE WAITING FUNCTION. THE WAITING FUNCTION WILL NOT T1454000 * RECEIVE CONTROL IF ITS TCB IS THE SAME AS THE CURRENT TCB OR IF T1454500 * ITS TCBABWF NON-DISPATCHABILITY FLAG IS ON. T1455000 LR R2,R0 POINT R2 TO THE NEW TCB. T1455500 USING TCB,R2 SET TCB ADDRESSABILITY. T1456000 CL R2,PSATOLD-PSA IS NEW TCB SAME AS CURRENT... T1456500 BE TLL40 IF SO, PURGE. T1457000 TM TCBFLGS5,TCBABWF IS NEW TCB IN ABNORMAL WAIT... T1457500 BO TLL40 IF SO, PURGE. T1458000 L R5,TCBRBP POINT TO CURRENT RB. T1458500 USING RBBASIC,R5 SET RB ADDRESSABILITY. T1459000 TLL33 DS 0H T1459500 TM RBSTAB1,RBFTSVRB IF PRB OR SVRB, T1460000 BNM TLL36 GO CHECK ITS PSW. T1460500 TM RBSTAB1,RBFTIRB IF NOT IRB OR TIRB, T1461000 BZ TLL36 GO CHECK ITS PSW. T1461500 TM RBSTAB2,RBTCBNXT IF TCB IS NEXT SET CC=3. T1462000 L R5,RBLINK POINT TO NEXT RB OR TCB. T1462500 BZ TLL33 BRANCH TO CHECK RB. T1463000 B TLL40 BUT IF TCB, GO PURGE. T1463500 TLL36 DS 0H T1464000 L R5,RBOPSW+4 GET RESUME INSTRUCTION ADR. T1464500 DROP R5 THERE GOES RB ADDRESSABILITY. T1465000 CL R5,=A($PLWAIT1) IF CURRENT NON-INTERRUPT T1465500 BL TLL40 REQUEST BLOCK IS WAITING T1466000 CL R5,=A($PLWAIT2) OR ABOUT TO WAIT, T1466500 BNH TLL50 GO POST HIS WAIT ELEMENT. T1467000 SPACE 1 T1467500 * THE WAITING FUNCTION WILL NOT RECEIVE CONTROL. T1468000 * FREE THE STORAGE AND DO NEXT ITEM ON THE CHAIN. T1468500 TLL40 DS 0H T1469000 LR R0,R1 SET UP REGISTERS SO THAT T1469500 LR R1,R3 R2, R3 SAME AS SJBLOCKH T1470000 LR R3,R0 AND R1 IS LOCK ELEMENT TO FREE. T1470500 FREEMAIN R,A=(1),SP=241,LV=16 FREE LOCK ELEMENT. T1471000 * RE-ESTABLISH R15 ADDRESSABILITY T1471500 BALR R15,0 SET TEMPORARY LOCAL BASE T1472000 USING *,R15 AND ADDRESSABILITY. T1472500 L R15,=A(TLL10) SET LOCAL BASE. T1473000 USING TLL10,R15 SET LOCAL ADDRESSABILITY. T1473500 * GO TO THE TOP AGAIN TO GET RID OF ANY OTHER BAD GUYS T1474000 B TLL10 GO PROCESS NEXT WAITER. T1474500 SPACE 1 T1475000 * LOOKS LIKE WAITING FUNCTION WILL RECEIVE CONTROL. T1475500 * POST NEW LOCK OWNER AND RETURN CC=2 TO CALLER. T1476000 TLL50 DS 0H T1476500 POST 0(,R3) POST NEW LOCK OWNER. T1477000 SLR R0,R0 SET CONDITION CODE TO 2. T1477500 BR R4 RETURN TO CALLER. T1478000 DROP R2,R6,R15 DROP TCB, SJB, LOCAL BASES. T1478500 TITLE '$SDBINIT -- ROUTINE TO INITIALIZE AN SDB' T1479000 * T1479500 * $SDBINIT - ROUTINE TO INITIALIZE AN SDB T1480000 * T1480500 * INPUT --- T1481000 * RSDB POINTS TO SDB TO INITIALIZE T1481500 * RSJB POINTS TO SJB TO WHICH SDB BELONGS T1482000 * RSVT POINTS TO HASP SSVT T1482500 * T1483000 * OPERATION --- T1483500 * 1. THE SDB IS MADE ZERO UP TO SDBCCW1 T1484000 * 2. SDBID AND SDBLENG ARE SET T1484500 * 3. SDBSJB AND SDBSDB ARE SET T1485000 * 4. SDBJKEY IS SET T1485500 * 4A. SDBOUTLM IS SET TO -1. T1486000 * 5. SDBPBFLM IS SET T1486500 * 6. THE IOB IS INITIALIZED --- T1487000 * A. FLG1 IS SET TO X'42' T1487500 * B. ECB IS POINTED TO SDBECB T1488000 * C. ST IS POINTED TO SDBCCW1 T1488500 * D DCB IS POINTED TO SJBDCB T1489000 * 7. THE CHANNEL PROGRAM IS INITIALIZED AS SHOWN T1489500 * IN THE DSECT. T1490000 * T1490500 * FIELDS LEFT TO BE INITIALIZED --- T1491000 * FLAGS - SDBFLG1, SDBFLG2 T1491500 * SDBPIOT,SDBPDDB,SDBDKEY,SDBAIOT T1492000 * SDBDEB T1492500 * SDBTRKF,SDBTRK, SDBTRKL T1493000 * SDBPBF,SDBUBF T1493500 EJECT T1494000 SSDBINIT DS 0H T1494500 $SDBINIT EQU SSDBINIT T1495000 STM R14,R12,12(R13) SAVE REGISTERS. T1495500 LR R12,R15 ESTABLISH T1496000 USING $SDBINIT,R12 ADDRESSABILITY. T1496500 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. R4 T1496800 $GETMAIN RC,LV=SDBLNG,SP=230,KEY=5 GET MAIN FOR SDB. T1497000 ST R1,60(,R13) SET R10 IN SAVE AREA. T1497500 BNZ SDIFAIL BRANCH IF STORAGE NOT GOT. T1498000 LR RSDB,R1 ELSE SET SDB BASE REGISTER. T1498500 USING SJBDSECT,RSJB T1499000 USING SDBDSECT,RSDB T1499500 * CLEAR THE SDB UP TO SDBCCW1 T1500000 L R4,0(,R1) SAVE TCB ACROSS CLEAR. T1500500 LR R0,RSDB POINT TO AREA T1501000 LA R1,SDBCCW1-SDBDSECT AND LENGTH TO CLEAR. T1501500 SR R3,R3 CLEAR TO ZEROES. T1502000 MVCL R0,R2 CLEAR THE SDB. T1502500 * SET SDB IDENTIFIER AND LENGTH T1503000 MVC SDBID(6),SDIID SET ID AND LENGTH T1503500 * SAVE TCB POINTER TO BE USED FOR FREEMAIN OF SDB T1504000 ST R4,SDBTCBM SAVE FREEMAIN TCB POINTER. T1504500 * SET SDBSJB AND SDBSDB T1505000 ST RSJB,SDBSJB SET SDBSJB. T1505500 MVC SDBSDB,SJBSDB CHAIN NEW SDB LIFO ONTO T1506000 ST RSDB,SJBSDB THE SJB CHAIN OF SDBS. T1506500 ST R11,SDBSVT SET POINTER TO HASP SSVT. T1507000 OI SDBTAB+(TABFLAG-TABDSECT),TABMINOR SETUP AS MINOR TAB R4 T1507100 * SET SDBJKEY T1507500 MVC SDBJKEY,SJBJKEY SET JOB KEY FROM SJB. T1508000 * SET SDBOUTLM TO -1 T1508500 L R0,=F'-1' SET OUTPUT LIMIT T1509000 ST R0,SDBOUTLM TO -1. T1509500 * SET SDBPBFLM T1510000 MVI SDBPBFLM+1,20 SET PROT BUF LIM TO 20. T1510500 * INITIALIZE IOB T1511000 MVI SDBIFLG1,X'42' SET IOBFLAG1,TO X'42'. T1511500 LA R15,SDBECB POINT IOBECB T1512000 ST R15,SDBIECB TO SDBECB AND T1512500 MVI 0(R15),X'40' SET ECB POSTED. T1513000 LA R0,SDBCCW1 POINT IOBSTART T1513500 ST R0,SDBIST TO SDBCCW1. T1514000 LA R0,SJBDCB POINT IOBDCBPT T1514500 ST R0,SDBIDCB TO SJBDCB. T1515000 * INITIALIZE THE CHANNEL PROGRAM T1515500 MVC SDBCCW1(32),SDICCW1 SET SKELETON CHANNEL PROGRAM. T1516000 LA R0,SDBCCW1+5 POINT SDBCCW1 T1516500 STCM R0,7,SDBCCW1+1 TO SECTOR NUMBER. T1517000 LA R0,SDBIFDAD+3 POINT SDBCCW2 T1517500 STCM R0,7,SDBCCW2+1 TO SEARCH ARGUMENT. T1518000 MVC SDBCCW4+6(2),$SVBFSIZ SET DATA LENGTH R4 T1518300 LA R0,SDBCCW2 POINT SDBCCW3 T1518500 STCM R0,7,SDBCCW3+1 TO TIC TARGET ADDRESS. T1519000 * RETURN TO CALLER T1519500 SR R15,R15 SHOW $SDBINIT COMPLETED OKAY. T1520000 SDIFAIL DS 0H T1520500 ST R15,16(,R13) SET R15 IN SAVE AREA. T1521000 LTR R15,R15 TEST RETURN CODE. T1521500 BZ SDIEXIT BRANCH IF SUCCESSFUL. T1522000 $MID 357 ELSE WRITE AN ERROR MESSAGE. T1522500 WTO '&MID.STORAGE UNAVAILABLE FOR SDB',ROUTCDE=10, CT1523000 DESC=6 T1523500 SDIEXIT DS 0H T1524000 LM R14,R12,12(R13) RESTORE REGISTERS. T1524500 LTR R15,R15 SET CC ACCORDING TO R15. T1525000 BR R14 RETURN TO CALLER. T1525500 DROP , DROP ALL BASES. T1526000 * T1526500 * DATA AREAS T1527000 * T1527500 SDIID DC 0CL6' ',CL4'SDB',AL2(SDBLNG) SDB IDENTIFIER T1528000 SDICCW1 CCW X'03',0,X'60',1 SKELETON NO-OP/SET-SECTOR T1528500 CCW X'31',0,X'60',5 SKELETON SEARCH-ID-EQUAL T1529000 DC FS24'8,0' SKELETON TIC T1529500 CCW X'06',0,0,*-* SKELETON READ R4 T1530000 TITLE '$SJBINIT -- ROUTINE TO INITIALIZE AN SJB' T1530500 * T1531000 * $SJBINIT - ROUTINE TO INITIALIZE AN SJB T1531500 * T1532000 * INPUT --- T1532500 * RSJB POINTS TO SJB TO INITIALIZE T1533000 * T1533500 * OPERATION --- T1534000 * 1. THE SJB IS MADE ZERO UP TO SJBCCW1 T1534500 * 2. SJBID AND SJBLENG ARE SET T1535000 * 3. SJBECBP, SJBASCBP, AND SJBERRET ARE SET T1535500 * 4. SJBLOCKH IS MADE ZERO, AND ECBP, ASCBP, AND ERRET T1536000 * ARE SET UP FOR CROSS-MEMORY POSTING. T1536500 * 5. THE IOB IS INITIALIZED T1537000 * A. FLG1 IS SET TO X'42' T1537500 * B. ECB IS POINTED TO SJBECB T1538000 * C. ST IS POINTED TO SJBCCW1 T1538500 * D. DCB IS POINTED TO SJBDCB T1539000 * 6. THE CHANNEL PROGRAM IS INITIALIZED AS SHOWN T1539500 * IN THE DSECT T1540000 * 7. THE ACBS, DEBS, AND RPL ARE INITIALIZED T1540500 * AS SHOWN IN THE DSECT T1541000 * 8. THE HASP DCB AND DEB ARE MOVED TO SJBDCB AND SJBDEB T1541500 * AND ADCONS IN THEM ARE SET CORRECTLY. DEBAVT IS T1542000 * POINTED TO HAMAVT. T1542500 * T1543000 * FIELDS LEFT TO BE INITIALIZED --- T1543500 * SJBJCT T1544000 * SJBJCTTR T1544500 * SJBIOT T1545000 * SJBPIT, SJBPATID, SJBCLAS, SJBJQE T1545500 * SJBXBSDB, SJBXBJNM T1546000 * SJBJOBID T1546500 * SJBJOBNM T1547000 EJECT T1547500 SSJBINIT DS 0H T1548000 $SJBINIT EQU SSJBINIT T1548500 BALR R12,0 ESTABLISH T1549000 USING *,R12 ADDRESSABILITY. T1549500 LR R6,R14 SAVE RETURN ADDRESS. T1550000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T1550500 SLR R1,R1 COMPUTE R4 T1550600 IC R1,$SVNUMDA STORAGE R4 T1550700 SLL R1,4 REQUIRED FOR R4 T1550800 LA R0,SJBDEB-SJBDSECT+4*(8+4*1)(,R1) SJB R4 T1550900 $GETMAIN RC,LV=(R0),SP=241,KEY=1 GET MAIN FOR SJB R4 T1551000 BNZ SJIERR BRANCH IF GETMAIN FAILED. T1551500 LR RSJB,R1 SET THE SJB BASE REGISTER. T1552000 USING SJBDSECT,RSJB T1552500 * CLEAR SJB FROM SJBFLG1 TO SJBCCW1 R4 T1553000 LA R0,SJBFLG1 SET STARTING ADDRESS R4 T1553500 LA R1,SJBCCW1-SJBFLG1 AND LENGTH FOR CLEAR R4 T1554000 MVCL R0,R14 R15 MUST BE 0. CLEAR SJB. T1554500 * SET SJB IDENTIFIER AND SJB LENGTH R41 T1555000 MVC SJBID,=CL4'SJB' SET SJB ID R4 T1555500 MVC SJBLENG,4(RSJB) MOVE LENGTH SET BY HGFMAIN R41 T1556000 MVC SJBSSNM,$SVSSNM SET OWNING SUBSYSTEM NAME @OZ15844 T1556500 * SET SJBECBP, SJBASCBP, SJBTCBP, AND SJBERRET @OZ53355 T1557500 LA R0,SJBECB POINT ECB POINTER T1558000 ST R0,SJBECBP TO ECB. T1558500 L R1,CVTPTR POINT TO CVT. T1559000 LA R0,CVTBRET-CVT(,R1) POINT ERRET TO T1559500 ST R0,SJBERRET 'BR 14'. T1560000 L R1,PSATOLD-PSA GET CURRENT TCB POINTER @OZ53355 T1560100 ST R1,SJBTCBP STORE IT IN THE SJB @OZ53355 T1560200 L R1,PSAAOLD-PSA GET CURRENT ASCB POINTER. T1560500 ST R1,SJBASCBP STORE IT IN THE SJB. T1561000 LH R1,ASCBASID-ASCB(,R1) GET CURRENT ASID. T1561500 STH R1,SJBASID STORE IT IN THE SJB. T1562000 * ADD SJB TO THE HASP ADDRESS SPACE VECTOR TABLE (HAVT) T1562500 ALR R1,R1 MULTIPLY ASID T1563000 ALR R1,R1 BY FOUR. T1563500 AL R1,$SVHAVT POINT TO ENTRY IN HAVT. T1564000 L R2,0(,R1) GET FIRST SJB @OZ55219 T1564100 LTR R2,R2 IS THERE ONE... @OZ55219 T1564150 BZ SJI05 NO, CONTINUE @OZ55219 T1564200 TM SJBFLG2-SJBDSECT(R2),SJB2INIT IS IT INIT... @OZ55219 T1564250 BZ SJI05 NO, CONTINUE @OZ55219 T1564300 OI SJBLKFG-SJBDSECT(R2),SJBPRIM SET PRIMARY INIT @OZ56375 T1564350 SJI05 DS 0H @OZ55219 T1564400 SL R1,=A(SJBSJB-SJBDSECT) PREPARE TO RUN CHAIN. T1564500 DROP RSJB DROP RSJB AS SJB BASE. T1565000 USING SJBDSECT,R1 SET SJB BASE TO R1. T1565500 SJI10 DS 0H T1566000 LR R2,R1 SAVE PREVIOUS SJB POINTER. T1566500 L R1,SJBSJB POINT TO NEXT SJB. T1567000 LTR R1,R1 ARE WE AT CHAIN END... T1567500 BNZ SJI10 IF NOT, LOOP TILL WE ARE. T1568000 USING SJBDSECT,R2 SET SJB BASE TO R2 (PREV). T1568500 ST RSJB,SJBSJB CHAIN SJB ON HAVT SLOT FIFO. T1569000 DROP R1,R2 DROP TWO SJB BASES. T1569500 USING SJBDSECT,RSJB SET SJB BASE TO RSJB. T1570000 * INITIALIZE THE IOB T1570500 MVI SJBIFLG1,X'42' SET IOBFLAG1 TO X'42'. T1571000 LA R0,SJBECB POINT IOBECB T1571500 ST R0,SJBIECB TO SJBECB. T1572000 LA R0,SJBCCW1 POINT IOBSTART T1572500 ST R0,SJBIST TO SJBCCW1. T1573000 LA R0,SJBDCB POINT IOBDCBPT T1573500 ST R0,SJBIDCB TO SJBDCB. T1574000 * INITIALIZE THE CHANNEL PROGRAM T1574500 MVC SJBCCW1(32),SJICCW1 SET SKELETON CHANNEL PROGRAM. T1575000 LA R0,SJBCCW1+5 POINT SJBCCW1 T1575500 STCM R0,7,SJBCCW1+1 TO SECTOR NUMBER. T1576000 LA R0,SJBIFDAD+3 POINT SJBCCW2 T1576500 STCM R0,7,SJBCCW2+1 TO SEARCH ARGUMENT. T1577000 MVC SJBCCW4+6(2),$SVBFSIZ SET DATA LENGTH R4 T1577300 LA R0,SJBCCW2 POINT SJBCCW3 T1577500 STCM R0,7,SJBCCW3+1 TO TIC TARGET ADDRESS. T1578000 * INITIALIZE ACBS, DEBS, RPL T1578500 MVC SJBLACB(SJBIACB-SJBLACB),SJILACB SET LOG SKELETONS. T1579000 USING IFGACB,R1 USE THE ACB DSECT. T1579500 USING DEBBASIC,R2 USE THE DEB DSECT. T1580000 LA R1,SJBLACB GET ADDRESS OF LOG ACB. T1580500 LA R2,SJBLDEB GET ADDRESS OF LOG DEB. T1581000 ST R1,DEBDCBAD POINT DEB TO ACB. T1581500 MVI DEBDEBID,X'0F' SET DEB ID FIELD. T1582000 ST R2,ACBDEB-1 POINT ACB TO DEB. T1582500 LA R2,SJBLRPL POINT HASP JOB LOG RPL T1583000 ST R1,RPLDACB-IFGRPL(,R2) TO ACB. T1583500 MVC ACBINRTN,=A(HAMNULL) ALLOW EARLY LOG USE. T1584000 MVC SJBIACB(SJBMACB-SJBIACB),SJIIACB SET INT TXT SKELETON. T1584500 LA R1,SJBIACB GET ADDRESS OF INTTXT ACB. T1585000 LA R2,SJBIDEB GET ADDRESS OF INTTXT DEB. T1585500 ST R1,DEBDCBAD POINT DEB TO ACB. T1586000 MVI DEBDEBID,X'0F' SET DEB ID FIELD. T1586500 ST R2,ACBDEB-1 POINT ACB TO DEB. T1587000 MVC SJBMACB(SJBJACB-SJBMACB),SJIMACB SET MSGS SKELETON. T1587500 LA R1,SJBMACB GET ADDRESS OF MESSAGE ACB. T1588000 LA R2,SJBMDEB GET ADDRESS OF MESSAGE DEB. T1588500 ST R1,DEBDCBAD POINT DEB TO ACB. T1589000 MVI DEBDEBID,X'0F' SET DEB ID FIELD. T1589500 ST R2,ACBDEB-1 POINT ACB TO DEB. T1590000 MVC SJBJACB(SJBDCB+40-SJBJACB),SJIJACB SET JOURNAL SKEL. T1590500 LA R1,SJBJACB GET ADDRESS OF JOURNAL ACB. T1591000 LA R2,SJBJDEB GET ADDRESS OF JOURNAL DEB. T1591500 ST R1,DEBDCBAD POINT DEB TO ACB. T1592000 MVI DEBDEBID,X'0F' SET DEB ID FIELD. T1592500 ST R2,ACBDEB-1 POINT ACB TO DEB. T1593000 * INITIALIZE SPOOL DCB AND DEB T1593500 MVC SJBDCB+40(12),$SVDCB+40 SET SKELETON DCB IN SJB R4 T1593600 SLR R1,R1 SET R4 T1593700 IC R1,$SVNUMDA SKELETON R4 T1593800 SLL R1,4 DIRECT R4 T1593900 LA R1,32+16(,R1) ACCESS R4 T1594000 L R14,$SVDEB DEB R4 T1594100 LA R0,SJBDEB IN R4 T1594200 LR R15,R1 NEW R4 T1594300 MVCL R0,R14 SJB R4 T1594400 LA R1,SJBDEB GET ADR OF HASP DEB. T1594500 LA R2,SJBDCB GET ADR OF HASP DCB. T1595000 USING DEBBASIC,R1 USE DEB DSECT. T1595500 USING DCBDSECT,R2 USE DCB DSECT. T1596000 L R0,=A(HAMAVT) SET APPENDAGE VECTOR T1596500 STCM R0,7,DEBAPPAD+1 TABLE ADDRESS IN DEB. T1597000 ST R1,DCBDEBAD SET ADR OF DEB IN DCB. T1597500 ST R2,DEBDCBAD SET ADR OF DCB IN DEB. T1598000 MVI DEBDEBID,X'0F' SET DEB IDENTIFIER. T1598500 * RETURN TO CALLER. T1599000 SR R15,R15 SHOW NORMAL COMPLETION. T1599500 BR R6 RETURN TO CALLER. T1600000 * T1600500 * T1601000 * ERROR - STORAGE UNAVAILABLE FOR SJB T1601500 * T1602000 * T1602500 SJIERR DS 0H T1603000 $MID 362 SET HASP ID FOR MESSAGE. T1603500 WTO '&MID.STORAGE UNAVAILABLE FOR SJB',ROUTCDE=10, CT1604000 DESC=6 T1604500 LA R15,4 SET R15 NONZERO. T1605000 LTR R15,R15 SET CONDITION CODE NONZERO. T1605500 BR R6 RETURN TO CALLER. T1606000 DROP R1,R2,R12,RSJB DROP BASES. T1606500 * T1607000 * DATA AREAS T1607500 * T1608000 SJICCW1 CCW X'03',0,X'60',1 SKELETON NO-OP/SET-SECTOR T1609000 CCW X'31',0,X'60',5 SKELETON SEARCH-ID-EQUAL T1609500 CCW X'08',0,0,1 SKELETON TIC. T1610000 CCW X'06',0,0,*-* SKELETON READ R4 T1610500 SJILACB ACB MACRF=(ADR,SEQ,OUT) T1611000 DC 8A(0) DEB FOR LOG T1611500 RPL ACB=0 T1612000 SJIIACB ACB MACRF=(ADR,SEQ,IN) T1612500 DC 8A(0) T1613000 SJIMACB ACB MACRF=(ADR,SEQ,OUT) T1613500 DC 8A(0) T1614000 SJIJACB ACB MACRF=(ADR,SEQ,DIR,IN,OUT) T1614500 DC 8A(0) T1615000 TITLE '$SVJLOK - ACQUIRE JOB COMMUNICATION QUEUES LOCK' T1615500 * T1616000 * T1616500 * $ S V J L O K T1617000 * T1617500 * T1618000 * ACQUIRE THE JOB COMMUNICATION QUEUES LOCK. THIS LOCK T1618500 * MUST BE OBTAINED BY ANYBODY MANIPULATING THE $SVJ QUEUES T1619000 * - $SVJPCLS, $SVJPNUM, $SVJXCLS, $SVJXNUM, $SVJTERM, T1619500 * $SVJRENQ. THIS LOCK MUST BE PROCURED BEFORE REMOVING T1620000 * AN SJB FROM A QUEUE AND MUST NOT BE RELEASED UNTIL THE T1620500 * SJB HAS BEEN RETURNED TO A QUEUE IF APPROPRIATE (FOR T1621000 * REMOVAL FROM $SVJTERM OR $SVJRENQ ONLY, AN SJB MAY BE T1621500 * LEFT OFF ALL QUEUES). T1622000 * T1622500 * THE LOCK HEADER IS $SVJLOCK. ITS FORMAT IS -- T1623000 * +0 - ASCB UNDER WHICH RESOURCE IS HELD. VALID ONLY IF T1623500 * +4 IS NONZERO - OTHERWISE THIS FULLWORD MUST BE T1624000 * ZERO. T1624500 * +4 - ZERO MEANS RESOURCE IS UNLOCKED. T1625000 * MINUS MEANS RESOURCE IS HELD BUT NO WAITERS EXIST. T1625500 * PLUS - POINTS TO MOST-RECENT WAIT ELEMENT T1626000 * T1626500 * THE WAIT ELEMENT IS A 32-BYTE CHUNK OF SP241 OR A PRE- T1627000 * ASSEMBLED AREA IN HASPXEQ, FORMATTED AS FOLLOWS --- T1627500 * +0 - IF IN HASPXEQ, CHARACTERS 'HASP' T1628000 * OTHERWISE USED AS ECB T1628500 * +4 - CHAIN WORD AS ABOVE IN $SVJLOCK T1629000 * +8 - ASCB POINTER AS ABOVE T1629500 * +12 - ECB POINTER FOR XMPOST T1630000 * +16 - ASCB POINTER FOR XMPOST T1630500 * +20 - ERROR RETURN ADDRESS FOR XMPOST T1631000 * NOTE - +16 AND +20 ARE SET BY UNLOCK ROUTINE T1631500 * +24 - IF IN HASPXEQ, UNUSED T1632000 * OTHERWISE SJB POINTER T1632500 * T1633000 * T1633500 * T1634000 * ATTEMPT TO LOCK WITHOUT GETMAIN T1634500 * T1635000 * T1635500 $SVJLOK DS 0H T1636000 SLR R0,R0 ASSUME LOCKING DOUBLEWORD T1636500 LR R1,R0 IS ZERO. T1637000 L R2,PSAAOLD-PSA WE'LL CHANGE IT TO T1637500 LNR R3,R2 ASCB PTR AND MINUS NUMBER. T1638000 CDS R0,R2,$SVJLOCK ACQUIRE THE LOCK. T1638500 BER R14 RETURN IF SUCCESS. T1639000 * T1639500 * T1640000 * GET MAIN STORAGE FOR A LOCK ELEMENT T1640500 * T1641000 * T1641500 STM R14,R12,12(R13) SAVE REGISTERS IN SJB. T1642000 BALR R12,0 ESTABLISH ADDRESSABILITY T1642500 USING *,R12 AND TELL THE ASSEMBLER. T1643000 $GETMAIN RU,SP=241,LV=32,KEY=1 GET A LOCK ELEMENT. T1643500 LR R4,R1 SAVE STORAGE ADDRESS IN R4. T1644000 MVI 0(R1),0 CLEAR THE ECB (+0). T1644500 ST R1,12(,R1) SET ECB POINTER (+12). T1645000 ST RSJB,24(,R1) SET SJB POINTER (+24). T1645500 * T1646000 * T1646500 * NOW WE HAVE AN ELEMENT. TRY AGAIN FOR LOCK T1647000 * T1647500 * T1648000 SVJL10 DS 0H T1648500 SLR R0,R0 ASSUME AS ABOVE THAT T1649000 LR R1,R0 LOCK IS NOT HELD. T1649500 L R2,PSAAOLD-PSA POINT R2 TO ASCB. T1650000 LNR R3,R2 MAKE R3 NEGATIVE. T1650500 CDS R0,R2,$SVJLOCK TRY AGAIN TO GET LOCK. T1651000 BE SVJL20 IF SUCCESS, FREE WAIT ELEMENT. T1651500 * T1652000 * CAN'T GET LOCK NOW - QUEUE WAIT ELEMENT T1652500 * T1653000 STM R1,R2,4(R4) SET CHAIN (+4), CUR ASCB (+8). T1653500 LR R2,R0 USE OWNING ASCB POINTER. T1654000 LR R3,R4 SET TENTATIVE CHAIN POINTER. T1654500 CDS R0,R2,$SVJLOCK TRY TO QUEUE WAIT ELEMENT. T1655000 BNE SVJL10 BRANCH IF UNSUCCESSFUL. T1655500 * T1656000 * WAIT ELEMENT IS QUEUED - WAIT FOR RESOURCE T1656500 * T1657000 WAIT 1,ECB=(R4) WAIT FOR POST. T1657500 * T1658000 * T1658500 * UPON BEING POSTED, FREE THE WAIT ELEMENT T1659000 * T1659500 * T1660000 SVJL20 DS 0H T1660500 $FREMAIN RU,A=(R4),SP=241,LV=32,KEY=1 FREE LOCK ELEMENT. T1661000 LM R14,R12,12(R13) RESTORE REGISTERS. T1661500 * T1662000 * T1662500 * WE HOLD THE RESOURCE. RETURN TO ITS USER. T1663000 * T1663500 * T1664000 DROP R12 DROP LOCAL ADDRESSABILITY. T1664500 BR R14 RETURN TO RESOURCE USER. T1665000 TITLE '$SVJUNLK - RELEASE JOB COMMUNICATION QUEUES LOCK' T1665500 * T1666000 * T1666500 * $ S V J U N L K T1667000 * T1667500 * T1668000 * SEE ABOVE FOR DESCRIPTION OF HEADER AND WAIT ELEMENT FORMATS T1668500 * T1669000 * T1669500 * INSPECT THE LOCK'S CURRENT STATE T1670000 * T1670500 * T1671000 $SVJUNLK DS 0H T1671500 USING *,R15 SET LOCAL ADDRESSABILITY. T1672000 LM R2,R3,$SVJLOCK GET LOCK HEADER CONTENTS. T1672500 SVJU10 DS 0H T1673000 LTR R3,R3 TEST CURRENT LOCK STATE. T1673500 BP SVJU20 BRANCH IF SOMEONE WAITING. T1674000 * IF ZERO CHAIN WORD, LOCK RECOVERY - MAKE THE LOCK ZERO. T1674500 * T1675000 * T1675500 * NO WAITERS EXIST. RELEASE LOCK AND RETURN. T1676000 * T1676500 * T1677000 SLR R0,R0 PREPARE TO ZERO OUT T1677500 LR R1,R0 THE LOCK HEADER. T1678000 CDS R2,R0,$SVJLOCK IF STILL NO WAITERS, UNLOCK. T1678500 BER R14 RETURN IF SUCCESSFUL. T1679000 B SVJU10 ELSE TEST LOCK STATE AGAIN. T1679500 * T1680000 * T1680500 * SOMEBODY'S WAITING ON THE LOCK. GIVE HIM THE T1681000 * LOCK AND POST HIM. T1681500 * T1682000 * T1682500 SVJU20 DS 0H T1683000 L R0,8(,R3) R0 = NEW OWNER'S ASCB. T1683500 L R1,4(,R3) R1 = NEW CHAIN WORD. T1684000 CDS R2,R0,$SVJLOCK SWITCH LOCK TO NEW OWNER. T1684500 BNE SVJU10 IF FAILURE, TEST STATE AGAIN. T1685000 CLC $SVSSNM,0(R3) IS LOCK ELEMENT HASP'S... T1685500 BE SVJU30 BRANCH IF SO T1686000 * POST NON-HASP LOCK ELEMENT OWNER T1686500 ST R0,16(,R3) ELSE COMPLETE POST ARG LIST T1687000 L R4,CVTPTR BY SETTING ASCB POINTER T1687500 LA R4,CVTBRET-CVT(,R4) AND ERROR RETURN T1688000 ST R4,20(,R3) (POINT TO X'07FE' IN CVT). T1688500 POST MF=(E,12(,R3)) POST THE NEW LOCK OWNER. T1689000 BR R14 RETURN TO CALLER. T1689500 * POST HASP LOCK ELEMENT OWNER T1690000 SVJU30 DS 0H T1690500 LR R4,R14 SAVE RETURN ADDRESS R4 T1690600 $$POST ELMT=$SVJOB POST HASP FOR JOB. T1691000 LR R14,R4 RESTORE RETURN ADDRESS R4 T1691100 BR R14 RETURN TO CALLER. T1691500 TITLE '$SJBRQ - MOVE SJB TO A DIFFERENT $SVJ QUEUE' T1692000 * T1692500 * T1693000 * $ S J B R Q T1693500 * T1694000 * T1694500 * REQUIREMENTS - T1695000 * JOB COMMUNICATION QUEUES LOCK MUST BE HELD T1695500 * SJBQUEUE MUST POINT TO HEADER OF QUEUE CURRENTLY CON- T1696000 * TAINING SJB. ZERO MEANS SJB IS NOT ON ANY QUEUE. T1696500 * R1 MUST POINT TO HEADER OF QUEUE NEWLY TO CONTAIN SJB. T1697000 * IF ZERO, SJB WILL NOT BE RE-ENQUEUED. T1697500 * RSJB MUST POINT TO AN SJB. T1698000 * T1698500 * T1699000 * REMOVE SJB FROM ITS CURRENT QUEUE T1699500 * T1700000 * T1700500 $SJBRQ DS 0H T1701000 USING *,R15 SET LOCAL ADDRESSABILITY. T1701500 USING SJBDSECT,RSJB SET SJB BASE TO RSJB. T1702000 L R2,SJBQUEUE GET QUEUE HDR POINTER INTO R2. T1702500 LTR R2,R2 TEST IT. T1703000 BZ SJBR20 IF ZERO, SKIP DEQUEUE. T1703500 SL R2,=A(SJBXQCHN-SJBDSECT) ELSE PREPARE TO CHAIN. T1704000 DROP RSJB DROP RSJB AS SJB BASE. T1704500 USING SJBDSECT,R2 SET SJB BASE TO R2. T1705000 SJBR10 DS 0H T1705500 LTR R3,R2 SAVE AND TEST PREV SJB PTR. T1706000 BZ SJBR20 IF ZERO, SJB WASN'T ON QUEUE. T1706500 L R2,SJBXQCHN POINT R2 TO NEXT SJB. T1707000 CLR R2,RSJB IS THIS THE ONE TO DEQUEUE... T1707500 BNE SJBR10 IF NOT, LOOP ONWARDS. T1708000 L R0,SJBXQCHN PICK UP NEXT PTR FROM THIS. T1708500 USING SJBDSECT,R3 SET SJB BASE TO R3 (PREV). T1709000 ST R0,SJBXQCHN SET NEXT PTR IN PREV. T1709500 DROP R2,R3 DROP TWO SJB BASES. T1710000 * T1710500 * T1711000 * ADD SJB LIFO TO THE NEW QUEUE T1711500 * T1712000 * T1712500 SJBR20 DS 0H T1713000 USING SJBDSECT,RSJB SET SJB BASE TO RSJB. T1713500 ST R1,SJBQUEUE SET QUEUE HEADER PTR IN SJB. T1714000 LTR R1,R1 IF NO QUEUE HEADER, T1714500 BZR R14 RETURN. T1715000 L R0,0(,R1) GET CUR Q HEADER VALUE. T1715500 ST R0,SJBXQCHN STORE IT IN SJB CHAIN WORD. T1716000 ST RSJB,0(,R1) STORE SJB ADR IN Q HEADER. T1716500 BR R14 RETURN. T1717000 DROP RSJB DROP SJB BASE. T1717500 TITLE '$SJBFREE - RELEASE SJB STORAGE' T1718000 * T1718500 * T1719000 * $ S J B F R E E T1719500 * T1720000 * T1720500 * REQUIREMENTS - T1721000 * SJB LOCK MUST BE HELD (HEADER SJBLOCKH) T1721500 * SVJ LOCK MUST NOT BE HELD (HEADER $SVJLOCK) T1722000 * T1722500 * T1723000 * T1723500 * REMOVE SJB FROM $SVHAVT T1724000 * T1724500 * T1725000 $SJBFREE DS 0H T1725500 USING *,R15 SET LOCAL ADDRESSABILITY. T1726000 USING SJBDSECT,RSJB SET SJB BASE TO RSJB. T1726500 LR R5,R15 SAVE BASE ACROSS SVC @OZ19265 T1726520 LR R4,R14 SAVE RETURN ACROSS SVC @OZ19265 T1726540 SPACE 1 @OZ19265 T1726560 * POST ANYONE ON THE SJBLOCKH CHAIN WITH X'45' @OZ19265 T1726580 SPACE 1 @OZ19265 T1726600 SJBF01 DS 0H @OZ19265 T1726620 TM SJBFLG2,SJB2EOM IF ENTRY FROM END OF MEM @OZ40161 T1726625 BO SJBF09A BRANCH AROUND @OZ40161 T1726630 L R1,SJBLOCKH+4 GET FIRST WAITER @OZ19265 T1726640 LTR R1,R1 ANY WAITER... @OZ19265 T1726660 BNP SJBF09 ...NO, CONTINUE @OZ19265 T1726680 L R3,4(,R1) REMOVE WAITER @OZ19265 T1726700 CS R1,R3,SJBLOCKH+4 FROM THE @OZ19265 T1726720 BNE SJBF01 CHAIN @OZ19265 T1726740 LA R0,X'45' GET COMPLETION CODE @OZ19265 T1726760 POST (1),(0) POST WAITER @OZ19265 T1726780 LR R15,R5 RESTORE BASE REG @OZ19265 T1726800 B SJBF01 GO LOOK FOR ANOTHER @OZ19265 T1726820 SJBF09 DS 0H @OZ19265 T1726840 TM SJBLKFG,SJBFX WAS TCBFX BIT ON AT ENTRY. @OZ40161 T1726843 BO SJBF09A BRANCH IF SO @OZ40161 T1726846 L R1,PSATOLD-PSA BUT IF NOT, @OZ40161 T1726849 NI TCBFLGS1-TCB(R1),255-TCBFX ALLOW IRBS TO RUN @OZ40161 T1726852 SJBF09A DS 0H @OZ40161 T1726855 LR R14,R4 RESTORE RETURN REG @OZ19265 T1726860 LH R1,SJBASID GET ASID FROM SJB. T1727000 ALR R1,R1 MULTIPLY BY FOUR. T1727500 ALR R1,R1 T1728000 AL R1,$SVHAVT POINT TO ENTRY IN HAVT. T1728500 SL R1,=A(SJBSJB-SJBDSECT) PREPARE TO CHAIN. T1729000 DROP RSJB DROP RSJB AS SJB BASE. T1729500 USING SJBDSECT,R1 SET SJB BASE TO R1. T1730000 SJBF10 DS 0H T1730500 LTR R2,R1 SAVE AND TEST PREV SJB PTR. T1731000 BZ SJBF20 IF ZERO, SJB WASN'T ON HAVT. T1731500 L R1,SJBSJB POINT TO NEXT SJB. T1732000 CLR R1,RSJB IS THIS THE ONE TO DECHAIN... T1732500 BNE SJBF10 IF NOT, LOOP ONWARDS. T1733000 L R0,SJBSJB PICK UP NEXT POINTER FROM THIS. T1733500 USING SJBDSECT,R2 SET SJB BASE TO R2. T1734000 ST R0,SJBSJB SET NEXT POINTER IN PREVIOUS. T1734500 DROP R1,R2 DROP TWO SJB BASES. T1735000 * T1735500 * T1736000 * DECHAIN SJB SAVE AREA AND SHOW UNLOCKED T1736500 * T1737000 * T1737500 SJBF20 DS 0H T1738000 LH R0,SJBLENG-SJBDSECT(,RSJB) GET SJB LENGTH R4 T1738300 LR R1,RSJB POINT R1 TO THE SJB. T1738500 L R13,4(,R1) DECHAIN SJB SAVE AREA. T1739000 N R12,=X'7FFFFFFF' SHOW R13 NOT SJB POINTER. T1739500 * T1740000 * T1740500 * FREE THE STORAGE OCCUPIED BY THE SJB T1741000 * T1741500 * T1742000 LR R5,R14 SAVE RETURN ADDRESS. T1742500 $FREMAIN RC,A=(R1),LV=(R0),SP=241,KEY=1 FREE SJB R4 T1743000 * T1743500 * T1744000 * RETURN TO CALLER T1744500 * T1745000 * T1745500 BR R5 RETURN. T1746000 DROP R15 DROP LOCAL BASE. T1746500 TITLE '$SDBFREE -- ROUTINE TO FREE AN SDB' T1747000 * T1747500 * T1748000 * $SDBFREE -- ROUTINE TO FREE AN SDB T1748500 * T1749000 * T1749500 SSDBFREE DS 0H T1750000 $SDBFREE EQU SSDBFREE T1750500 STM R14,R12,12(R13) SAVE REGISTERS. T1751000 LR R12,R15 ESTABLISH T1751500 USING $SDBFREE,R12 ADDRESSABILITY. T1752000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T1752500 * T1753000 * IF I/O IS ACTIVE, WAIT T1753500 * T1754000 CLI SDBICMP,X'48' WAS LAST OP PURGED... @OZ44636 T1754100 BE SDF05A BRANCH IF YES.. @OZ44636 T1754200 L R1,SDBECB LOAD ECB R41 T1754500 SDF05 LR R2,R1 RELOAD ECB R41 T1754600 N R2,=XL4'7F000000' RESET WAIT BIT R41 T1754700 CS R1,R2,SDBECB REPLACE ECB R41 T1754800 BNE SDF05 TRY AGAIN IF UNSUCCESSFUL R41 T1754900 WAIT 1,ECB=SDBECB WAIT FOR I/O TO COMPLETE. T1755000 * T1755500 * FREE ALL BUFFERS T1756000 * T1756500 SDF05A DS 0H @OZ44636 T1756550 L R8,SDBSJB POINT TO CORRECT SJB @OZ33647 T1756600 TM SDBFLG1,SDB1FOPN IF INTERNAL DATA SETS, @OZ40000 T1756630 BNZ SDF06 ALWAYS FREE THE BUFFERS @OZ40000 T1756660 USING SJBDSECT,R8 GET ADDRESSABILITY @OZ33647 T1756700 CLI SJBXQFN1+1,SSOBUNAL IF ENTRY FROM UNALLOCATION @OZ33647 T1756800 BE SDF08 DON'T TRY TO FREE BUFFERS @OZ33647 T1756900 CLI SJBXQFN1+1,SSOBTERM IF ENTRY FROM TERMINATE @OZ40000 T1756910 BE SDF08 DONT TRY TO FREE BUFFERS @OZ40000 T1756920 SDF06 DS 0H @OZ40000 T1756930 L RBUF,SDBPBF FREE ALL T1757000 BAL R5,SDFBFREP PROTECTED BUFFERS. T1757500 L RBUF,SDBGBF FREE ALL @OZ45166 T1757600 BAL R5,SDFBFREP PROTECTED BUFFERS. @OZ45166 T1757700 L RBUF,SDBUBF FREE ALL T1758000 BAL R5,SDFBFREU UNPROTECTED BUFFERS. T1758500 L RBUF,SDBHBF FREE ALL T1759000 SDF07 DS 0H @OZ41634 T1759100 BAL R5,SDFBFREU HOLD BUFFERS. T1759500 LTR RBUF,RBUF END OF BUFFER CHAIN ? @OZ41634 T1759600 BNZ SDF07 NO, LOOP BACK @OZ41634 T1759700 L RBUF,SDBFBF FREE ALL T1760000 BAL R5,SDFBFREP CH-END FREE BUFFERS. T1760500 L RBUF,SDBPBFX FREE ALL T1761000 BAL R5,SDFBFREP UNWRITTEN PROTECTED BUFFERS. T1761500 SDF08 DS 0H @OZ33647 T1762000 * THIS LINE DELETED BY APAR NUMBER @OZ33647 T1762500 LA R1,SJBSDB SET UP REGISTER 1 TO T1763000 S R1,=A(SDBSDB-SDBDSECT) CHAIN SDBS FROM SJB. T1763500 SDF10 CL RSDB,SDBSDB-SDBDSECT(,R1) IF SUBJECT SDB IS NEXT, T1764000 BE SDF20 GO DECHAIN IT. T1764500 L R1,SDBSDB-SDBDSECT(,R1) ELSE POINT TO NEXT SDB. T1765000 LTR R1,R1 IF THERE'S A NEXT, T1765500 BNZ SDF10 GO TEST ITS SDBSDB FIELD. T1766000 B SDF30 ELSE SKIP DECHAINING. T1766500 SDF20 MVC SDBSDB-SDBDSECT(,R1),SDBSDB DECHAIN SUBJECT SDB. T1767000 SDF30 DS 0H POTENTIAL ERROR - SDB NOT ON CHAIN. T1767500 MVC 0(4,RSDB),SDBTCBM SET FREEMAIN TCB POINTER. T1768000 $FREMAIN RU,A=(RSDB),LV=SDBLNG,SP=230,KEY=5,TCB=YES T1768500 LM R14,R12,12(R13) RESTORE REGISTERS. T1769000 BR R14 RETURN TO CALLER. T1769500 * T1770000 * SUBROUTINES TO FREE BUFFERS T1770500 * T1771000 SDFBFREU DS 0H T1771500 USING BFD,RBUF USE BUFFER DSECT. T1772000 LTR R1,RBUF IF NO BUFFER TO FREE, T1772500 BZR R5 RETURN. T1773000 L RBUF,BFBF ELSE POINT TO NEXT BUFFER T1773500 $FREEBUF TYPE=UNPROT,A=(R1) AND FREE CURRENT. T1774000 BR R5 RETURN @OZ41634 T1774500 SPACE 1 T1775000 SDFBFREP DS 0H T1775500 LTR R1,RBUF IF NO BUFFER TO FREE, T1776000 BZR R5 RETURN. T1776500 L RBUF,BFBF ELSE POINT TO NEXT BUFFER T1777000 $FREEBUF TYPE=PROT,A=(R1) AND FREE CURRENT. T1777500 B SDFBFREP THEN REPEAT. T1778000 DROP , DROP ALL BASES. T1778500 TITLE 'LITERAL POOL FOR $PROLOG - $SDBFREE' T1779000 LTORG T1779500 TITLE 'HASP SUBSYSTEM SUPPORT MODULE -- REQUEST/RETURN JOB ID' T1780000 *********************************************************************** T1780500 * * T1781000 * REQUEST/RETURN JOB ID - SUBSYSTEM FUNCTIONS SSOBRQST/SSOBRTRN* T1781500 * * T1782000 * INPUT REGISTERS - * T1782500 * * T1783000 * R0 = ADDRESS OF SSCVT * T1783500 * R1 = ADDRESS OF SSOB * T1784000 * R13 = SAVE AREA * T1784500 * R14 = RETURN * T1785000 * R15 = ENTRY BASE * T1785500 * * T1786000 * OUTPUT REGISTERS - * T1786500 * * T1787000 * R0-R14 = UNCHANGED * T1787500 * R15 = RETURN CODE * T1788000 * * T1788500 *********************************************************************** T1789000 SPACE 2 T1789500 HOSREQID $PROLOG SSOBRQST,SSRRSIZE,LOCK=YES T1790000 SPACE 1 T1790500 USING SJBDSECT,RSJB PROVIDE SJB ADDRESSABILITY T1791000 USING SSRQBGN,RSOX PROVIDE SSOB EXT'N ADDRESSABILITY T1791500 USING SSIB,RSIB PROVIDE SSIB ADDRESSABILITY T1792000 USING $SVDSECT,RSVT PROVIDE SSVT ADDRESSABILITY T1792500 SPACE 1 T1793000 LTR R12,R12 TEST FOR SJB T1793500 BM HRQ010 BR IF YES T1794000 EJECT T1794500 * T1795000 * C R E A T E A N S J B T1795500 * T1796000 SPACE 1 T1796500 LR R5,SAVE SAVE ADDRESS OF USER SAVE AREA T1797000 CALL $SJBINIT CREATE AN SJB T1797500 BALR R12,0 RE-ESTABLISH T1797600 USING *,R12 ADDRESSABILITY T1797700 LA R12,HRQBASE ON T1797800 USING HRQBASE,R12 RETURN. T1797900 BNZ HRQFAIL BR IF SJB NOT BUILT T1798000 ST RSJB,8(,R5) CHAIN T1798500 ST R5,SJBSAVE+4 SAVE AREAS T1799000 L R0,PSATOLD-PSA SET LOCK HEADER T1799500 LNR R1,R0 TO SHOW T1800000 STM R0,R1,SJBLOCKH SJB IN USE T1800500 MVI SJBXQFN1+1,SSOBRQST SHOW REQUEST JOB ID FUNCTION T1801000 ST RSJB,SSIBSUSE CHAIN SJB TO SSIB T1801500 ST RSIB,SJBSSIB AND SSIB TO SJB T1802000 XC SJBTCBP,SJBTCBP CLEAR FOR END OF TASK @OZ57048 T1802100 OI SJBFLG1,SJB1SJID SHOW SELECT-BY-JOB-ID T1802500 SPACE 1 T1803000 * T1803500 * G E T J O B I D F R O M S U B S Y S T E M T1804000 * T1804500 SPACE 1 T1805000 HRQ010 DS 0H T1805500 BALR R12,0 ESTABLISH T1806000 USING HRQBASE,R12 ADDRESSABILITY T1806500 SPACE 1 T1807000 HRQBASE DS 0H T1807500 MVI SSIBJBID,1 CAUSE QUEUE TO PENDING-BY-NUM T1808000 MVC SJBSECB,SSRRSECB SAVE STOP ECB ADDRESS T1808500 SL R12,=A(HRQBASE-HJSBASE) GET JOB SELECT BASE T1809000 BR R12 BR TO INTERFACE TO SUBSYSTEM T1809500 SPACE 1 T1810000 HRQ020 DS 0H T1810500 LA R15,SSRROK SET 'GOOD' RETURN CODE T1811000 $EPILOG KEY=0 AND RETURN TO REQUESTER T1811500 SPACE 1 T1812000 HRQFAIL DS 0H T1812500 BALR R12,0 RE-ESTABLISH T1813000 USING *,R12 ADDRESSABILITY T1813500 LA R12,0(,R12) SHOW NO SJB T1814000 LA R15,SSRRFAIL SET 'FAILED' RETURN CODE T1814500 $EPILOG KEY=0 AND RETURN TO REQUESTER T1815000 EJECT T1815500 HOSRETID $PROLOG SSOBRTRN,SSRRSIZE,LOCK=YES T1816000 SPACE 1 T1816500 SL R12,=A(*-HJEBASE) RETURN JOB ID IS HANDLED T1817000 USING HJEBASE,R12 SET JBTM ADDRESSABILITY T1817500 B HJERTRN ENTER TERMINATION T1818000 SPACE 1 T1818500 DROP RSJB,RSOX,RSIB,RSVT,R12 T1819000 TITLE 'HOSJBSL - JOB SELECTION SUBSYSTEM FUNCTION' T1819500 * T1820000 * T1820500 * HASP JOB SELECTION SUBSYSTEM FUNCTION T1821000 * T1821500 * T1822000 HOSJBSL $PROLOG SSOBJBSL,SSJSIZE,LOCK=YES T1822500 USING BFD,RBUF SET BUFFER ADDRESSABILITY. T1823000 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T1823500 USING SSIB,RSIB SET SSIB ADDRESSABILITY. T1824000 USING SSJSBGN,RSOX SET SSOB EXT ADDRESSABILITY. T1824500 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T1825000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T1825500 LTR R12,R12 IF SJB ALREADY EXISTS, T1826000 BM HJS100 BRANCH. T1826500 * T1827000 * T1827500 * FIRST INITIATOR CALL - CONSTRUCT AN SJB T1828000 * T1828500 * T1829000 LR R5,R13 SAVE USER SAVE AREA POINTER. T1829500 CALL $SJBINIT CREATE SUBSYSTEM JOB BLOCK. T1830000 BALR R12,0 RE-ESTABLISH T1830100 USING *,R12 ADDRESSABILITY T1830200 LA R12,HJSBASE ON T1830300 USING HJSBASE,R12 RETURN. T1830400 BNZ HJS800 ERROR IF NO STORAGE. T1830500 ST RSJB,8(,R5) POINT USER SAVE AREA TO SJB. T1831000 ST R5,SJBSAVE+4 POINT SJB TO USER SAVE AREA. T1831500 L R0,PSATOLD-PSA SET R0 = CURRENT TCB, R1 MINUS. T1832000 LNR R1,R0 SET SJB TO LOOK AS IF T1832500 STM R0,R1,SJBLOCKH LOCK WERE OBTAINED. T1833000 MVI SJBXQFN1+1,SSOBJBSL SHOW SJB LOCKED FOR JOB SELECT. T1833500 ST RSJB,SSIBSUSE SAVE SJB POINTER IN SSIB. T1834000 ST RSIB,SJBSSIB SET LIFE-OF-JOB SSIB PTR IN SJB T1834500 OI SJBFLG1,SJB1SJID ASSUME SELECT-JOB-BY-JOB-ID. T1835000 OI SJBLKFG,SJBFIRST SHOW FIRST REQUEST @OZ35293 T1835100 * T1835500 * T1836000 * SUBSYSTEM JOB BLOCK EXISTS - RE-ESTABLISH ADDR. T1836500 * T1837000 * T1837500 HJS100 DS 0H T1838000 BALR R12,0 ESTABLISH PERMANENT T1838500 USING *,R12 LOCAL ADDRESSABILITY. T1839000 HJSBASE DS 0H T1839500 O R12,=X'80000000' SHOW SJB LOCKED, SAVE AREA CT1840000 CHAINED. T1840500 * T1841000 * T1841500 * NOW EITHER STOP INITIATOR OR SELECT JOB T1842000 * T1842500 * T1843000 TM SJBFLG2,SJB2PNIT IF WE ARE TO STOP INITIATOR, T1843500 BO HJS805 BRANCH. T1844000 SPACE 1 T1845500 NI SJBFLG1,SJB1SJID RESET ALL FLG1 BUT SELECT-ID T1846000 MVI SJBFLG2,0 AND ALL OF FLG2. T1846500 LM R0,R1,SSIBJBID GET REQUESTED JOB ID FROM SSIB T1847000 STM R0,R1,SJBJOBID AND PUT IT IN THE SJB. T1847500 ALR R0,R1 IS ANY JOB ID SPECIFIED... T1848000 BNZ *+8 SKIP IF SELECT-BY-ID. T1848500 NI SJBFLG1,255-SJB1SJID ELSE SHOW SELECT-BY-CLASS. T1849000 TM SJBFLG1,SJB1SJID IF SYSTEM TASK, T1849500 BO HJS150 DON'T DECREMENT $SVPIDLE. T1850000 L R0,$SVPIDLE GET INITIATOR COUNTER. T1850500 HJS140 DS 0H T1851000 LTR R1,R0 IF NOT POSITIVE, T1851500 BNP HJS800 STOP THIS INITIATOR. T1852000 BCTR R1,0 DECREMENT COUNT BY ONE T1852500 CS R0,R1,$SVPIDLE AND STORE NEW COUNT. T1853000 BNE HJS140 IF INTERFERENCE, CHECK AGAIN. T1853500 HJS150 DS 0H T1854000 * SELECT JOB BY ID OR BY CLASS ACCORDING TO SJB1SJID T1854500 CALL $SVJLOK ACQUIRE HASP CMS LOCK. T1855000 NI SJBFLG2,255-SJB2CNCL RESET THE CANCEL FLAG. T1855500 LA R1,$SVJPCLS ASSUME SELECT-JOB-BY-CLASS. T1856000 TM SJBFLG1,SJB1SJID IF SELECT-BY-ID FLAG IS OFF, T1856500 BZ *+8 SKIP. T1857000 LA R1,$SVJPNUM SET SELECT-BY-ID QUEUE. T1857500 SLR R0,R0 ZERO OUT T1858000 ST R0,SJBECB THE ECB. T1858500 CALL $SJBRQ QUEUE SJB PENDING JOB. T1859000 CALL $SVJUNLK RELEASE HASP CMS LOCK. T1859500 $$POST ELMT=$SVJOB POST HASPXEQ FOR JOB. T1860000 WAIT 1,ECB=SJBECB WAIT TILL HASP SELECTS JOB. T1860500 * T1861000 * T1861500 * EXAMINE STATUS AFTER XEQ HAS POSTED US T1862000 * T1862500 * T1863000 TM SJBFLG2,SJB2PNIT IF HASP WANTS INIT STOPPED, T1863500 BO HJS805 BRANCH. T1864000 TM SJBFLG2,SJB2JNFD IF JOB-BY-ID NOT FOUND, T1864500 BO HJS850 BRANCH. T1865000 * T1865500 * T1866000 * A JOB HAS BEEN FOUND FOR THIS INITIATOR T1866500 * T1867000 * T1867500 HJS200 DS 0H T1868000 TIME BIN GET JOB'S STARTING TIME & DATE. T1868500 STM R0,R1,SJBDBLWK SAVE TEMPORARILY IN SJB. T1869000 * T1869500 * T1870000 * GET STORAGE FOR JCT, IF REQUIRED T1870500 * T1871000 * T1871500 L R1,SJBJCT IS JCT STORAGE T1872000 LTR R1,R1 ALREADY ASSIGNED... T1872500 BNZ HJS210 BRANCH IF SO. T1873000 CALL HCBGM GET JCT STORAGE. T1873500 BNZ HJS830 ERROR IF NO STORAGE. T1874000 ST R1,SJBJCT SAVE JCT POINTER IN SJB. T1874500 HJS210 DS 0H T1875000 * T1875500 * T1876000 * READ IN THE HASP JOB CONTROL TABLE T1876500 * T1877000 * T1877500 L R0,SJBJCTRK SET R0 = JCT TRACK ADDRESS. T1878000 CALL HCBRD READ IN THE JCT. T1878500 LR R7,R1 SET JCT ADDRESSABILITY. T1879000 BZ HJS220 BRANCH IF JCT READ OKAY. T1879500 CALL HCBFM ELSE FREE JCT STORAGE. T1880000 SLR R7,R7 ZERO OUT THE JCT POINTER T1880500 ST R7,SJBJCT IN THE SJB. T1881000 B HJS840 ERROR READING JCT. T1881500 HJS220 DS 0H T1882000 * T1882500 * T1883000 * MOVE JOB IDENTIFIERS TO SJB AND SSIB T1883500 * T1884000 * T1884500 TM JCTJOBFL,JCTNOJNL TEST FOR JOB JOURNALLING R4 T1884600 BO SKIP10 BR IF NO R4 T1884700 OI SJBFLG2,SJB2JNL ELSE INDICATE SO IN SJB R4 T1884800 SKIP10 MVC JCTXEQON(8),SJBDBLWK SET DATE, TIME OF JOB START. T1885000 MVC SJBJOBNM,JCTJNAME SET JOB NAME IN SJB. T1885500 TM SJBFLG1,SJB1XBMC IF XBM CONTINUATION, T1885600 BO *+12 HAVE NO SSIB. T1885700 LM R0,R1,SJBJOBID GET HASP JOB IDENTIFIER. T1886000 STM R0,R1,SSIBJBID SET IT IN SSIB. T1886500 SLR R0,R0 ZERO OUT T1887000 ST R0,SJBLOGQ SJBLOGQ. T1887500 MVC JCTPRIO,SJBPRIO MOVE SELECTION PRTY TO JCT. T1888000 MVC SJBESTLN,JCTESTLN SET PRINT AND PUNCH T1888500 MVC SJBESTPU,JCTESTPU EXCESSION LIMITS. T1889000 SPACE 1 @OZ18212 T1889100 SPACE 1 @OZ18212 T1889200 MVC JCTCPUID,$SVSID SET SYS ID IN JMR AND @OZ18212 T1889300 MVC JCTEXSID,$SVSID JCT FOR SMF TYPE 26 @OZ18212 T1889400 OI JCTFLAG1,JCT1CKPT FLAG JCT FOR CHECKPOINT R41 T1889500 CLI SJBXQFN1+1,SSOBRQST TEST FOR REQUEST-JOB-ID R4 T1889600 BE HJS250 BR IF YES R4 T1889700 * T1891700 * T1891800 * SET CONVERTER RETURN CODE IN THE SSOB EXTENSION T1891900 * T1892000 * T1892100 TM SJBFLG1,SJB1SJID IF THIS JOB IS T1892200 BZ *+16 SELECT-BY-ID, T1892500 ICM R0,15,JCTCNVRC MOVE CONVERTER RETURN CODE T1893000 ST R0,SSJSSERR TO SSOB. T1893500 BNZ HJS560 TERMINATE IF ANY ERROR DETECTED. T1894000 * T1894500 * T1895000 * IF EXECUTION BATCH MONITOR CONTINUATION, T1895500 * SET NEW JOB KEY IN ALL SDBS. T1896000 * T1896500 * T1897000 TM SJBFLG1,SJB1XBMC IF NOT XBM CONTINUATION, T1897500 BZ HJS250 BRANCH. T1898000 L R0,SJBJKEY SET R0 = JOB KEY. T1898500 L R1,SJBSDB POINT TO FIRST SDB. T1899000 HJS230 DS 0H T1899500 LTR R1,R1 IF END OF SDBS, T1900000 BZ HJS240 END LOOP. T1900500 USING SDBDSECT,R1 SET SDB ADDRESSABILITY. T1901000 ST R0,SDBJKEY SET JOB KEY IN SDB. T1901500 L R1,SDBSDB POINT TO NEXT SDB T1902000 B HJS230 AND LOOP. T1902500 HJS240 DS 0H T1903000 DROP R1 DROP SDB ADDRESSABILITY. T1903500 * T1904000 * T1904500 * IF EXECUTION BATCH MONITOR CONTINUATION, T1905000 * READ NEW INPUT IOT, COPY THE 'JCL' PDDB T1905500 * AND TRACK GROUP MAP TO THE OLD 1ST IOT AND T1906000 * GET NEW TRACKS FOR ANY OTHER OLD IOTS. T1906500 * T1907000 * T1907500 L RIOT,SJBIOT SAVE POINTER TO PREVIOUS 1ST IOT. T1908000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T1908500 LA R2,JCTIOT SET TRACK CHAIN POINTER. T1909000 LA R3,SJBIOT SET DUMMY STORAGE CHAIN POINTER. T1909500 BAL R4,HJSRDIOT READ IN THE ONLY IOT. T1910000 ST RIOT,SJBIOT RESTORE POINTER TO PREVIOUS 1ST IOT. T1910500 L R15,$SVMAPL COPY R4 T1911000 LA R15,TGMAP-TGMDSECT(,R15) ALL R4 T1911200 LA R14,IOTTGMAP TGM R4 T1911400 LA R4,IOTTGMAP-IOTDSECT(,R1) FIELDS R4 T1911600 LR R5,R15 TO R4 T1911800 MVCL R14,R4 OLD IOT R4 T1912000 L RIOT,SJBIOT RESTORE IOT ADDRESS R4 T1912200 MVC IOTMSTAB(TABAIOT-TABDSECT),IOTMSTAB-IOTDSECT(R1) R41 T1912300 OI JCTFLAG1,JCT1CKPT FLAG JCT FOR CHECKPOINT R4 T1912400 L R15,$SVPDDB1 MOVE R4 T1912600 LA R14,IOTPDBOJ(R15,RIOT) JCL R4 T1912800 LA R4,IOTPDBOJ(R15,R1) PDDB R4 T1913000 MVC 0(PDBLENG,R14),0(R4) TO OLD IOT R4 T1913200 OI PDBFLAG1-PDBDSECT(R14),PDB1NSOT DON'T LET JCL PRINT R4 T1913400 MVC IOTTRACK,JCTIOT MOVE NEW IOT TRK ADDR TO OLD IOT. T1913600 CALL HCBFM FREE NEW IOT STORAGE T1914000 SLR R2,R2 SET R2 TO ZERO. T1914500 LA R4,IOTMSTAB SET R4 TO MASTER TAB FOR $STRAK R4 T1914600 HJS246 DS 0H T1915500 MVC IOTJBKEY,SJBJKEY SET KEY IN OUTPUT IOT. T1916000 OI IOTFLAG1,IOT1CKPT FLAG IOT FOR CHECKPOINT. T1916500 ST R2,IOTIOTTR ZERO TRACK CHAIN POINTER. T1917000 L R3,IOTIOT IF NO MORE T1917500 LTR R3,R3 OUTPUT IOTS, T1918000 BZ HJS570 CONTINUE WITH XBMC WORK. T1918500 LR R1,R4 ELSE POINT TO ALLOC TGM & T1919000 CALL $STRAK GET TRACK FOR NEXT IOT. T1919500 ST R1,IOTIOTTR SET CHAINING TRACK. T1920000 LR RIOT,R3 POINT TO NEXT IOT. T1920500 ST R1,IOTTRACK SET ITS TRACK IN IT. T1921000 B HJS246 GO DO THIS NEXT IOT. T1921500 * T1922000 * T1922500 * FOR NON-EXECUTION BATCH MONITOR CONTINUATION, T1923000 * READ IN THE REGULAR IOT(S) T1923500 * T1924000 * T1924500 HJS250 DS 0H T1925000 LA R2,JCTIOT SET TRACK CHAIN POINTER. T1925500 LA R3,SJBIOT SET STORAGE CHAIN POINTER. T1926000 BAL R4,HJSRDIOT READ ALL REGULAR IOTS. T1926500 * T1927000 * T1927500 * READ IN JOB'S OUTPUT CONTROL RECORD(S) @OZ19486 T1928000 * T1928500 * T1929000 L R1,SJBOCT GET OCR STORAGE ADDRESS. T1929500 TM SJBFLG1,SJB1XBM IF BATCH MONITOR, T1930000 BO HJS300 DON'T READ OCTS. T1930500 L R0,JCTOCTTR GET OCR TRACK ADDRESS. T1931000 LTR R0,R0 IF JOB HAS NO OCR, T1931500 BZ HJS310 GO FREE OCR STORAGE. T1932000 LTR R1,R1 JOB HAS OCR. IF OCR STORAGE T1932500 BNZ HJS280 ADDRESS EXISTS, GO READ IT. T1933000 CALL HCBGM ELSE GET OCR STORAGE. T1933500 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T1934000 ST R1,SJBOCT SET POINTER TO OCR IN SJB. T1934500 HJS280 DS 0H T1935000 CALL HCBRD READ IN THE OCR. T1935500 BNZ HJS840 ERROR - CAN'T READ OCR. @OZ19486 T1936000 ICM R0,15,OCTOCTTR-OCTDSECT(R1) TTR OF NXT OCT @OZ19486 T1936100 BZ HJS320 NO MORE, EXIT LOOP @OZ19486 T1936200 LR R5,R1 SAVE ADDRESS OF OCT N @OZ19486 T1936300 CALL HCBGM GET STORAGE FOR OCT N+1 @OZ19486 T1936400 BNZ HJS830 IF NO STORAGE, ABORT @OZ19486 T1936500 ST R1,OCTOCT-OCTDSECT(,R5) CHAIN OCT N+1 @OZ19486 T1936600 B HJS280 LOOP TO READ OCT N+1 @OZ19486 T1936700 SPACE 2 @OZ19486 T1936800 HJS300 DS 0H T1937000 L RIOT,SJBIOT POINT TO THE 1ST IOT. T1937500 AL RIOT,$SVPDDB1 DON'T PRINT R4 T1938000 OI IOTPDBOI+PDBFLAG1-PDBDSECT(RIOT),PDB1NSOT JCL IMAGES R4 T1938300 HJS310 DS 0H T1938500 CALL HCBFM FREE OCR STORAGE T1939000 SLR R0,R0 AND ZERO T1939500 ST R0,SJBOCT OCR POINTER IN SJB. T1940000 HJS320 DS 0H T1940500 * T1941000 * T1941500 * IF JOB SELECT CODE IS BEING USED BY T1942000 * REQUEST-JOB-ID FUNCTION, RETURN THERE T1942500 * T1943000 * T1943500 CLI SJBXQFN1+1,SSOBRQST IF NOT REQUEST-JOB-ID, T1944000 BNE HJS340 CONTINUE. T1944500 SL R12,=A(HJSBASE-HRQBASE) SET BASE TO HOSRQST. T1945000 USING HRQBASE,R12 TELL THE ASSEMBLER. T1945500 B HRQ020 RETURN TO HOSRQST CODE. T1946000 HJS340 DS 0H T1946500 USING HJSBASE,R12 RESET LOCAL ADDRESSABILITY. T1947000 * T1947500 * T1948000 * PRIOR TO FAKE-OPENS, ALTER ADDRESSABILITY T1948500 * T1949000 * T1949500 DROP RSOX DROP RSOX TO PICK UP RSDB. T1950000 LR RSIB,RSOX POINT RSIB (R8) TO SSOB EXT. T1950500 USING SSJSBGN,RSIB SET SSOB EXT ADDRESSABILITY. T1951000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T1951500 * T1952000 * T1952500 * MOVE CERTAIN INFORMATION TO SSOB EXTENSION T1953000 * T1953500 * T1954000 * R4 T1954100 * PERFORM PASSWORD PROCESSING R4 T1954200 * R4 T1954300 TM SJBFLG1,SJB1XBM IF BATCH MONITOR, @OZ41304 T1954340 BO HJS350 NO PASSWORD USED @OZ41304 T1954360 LA R3,$JSPSLEN GET NECESSARY LENGTH FOR PASSWRDS R4 T1954400 CH R3,SSJSLEN COMPARE TO ACTUAL LENGTH R4 T1954500 BH HJS350 BR IF NOT LONG ENOUGH R4 T1954600 LA R3,JCTPASS GET ADDR OF JCT CURRENT PASS R4 T1954900 LA R1,SSJSPASS GET ADDR OF SSOB CURRENT PASS R4 T1955000 BAL R14,HJS345 BR TO MOVE FROM JCT TO SSOB R4 T1955100 LA R3,JCTNUPAS GET ADDR OF JCT NEW PASS R4 T1955400 LA R1,SSJSPAS2 GET ADDR OF SSOB NEW PASS R4 T1955500 BAL R14,HJS345 BR TO MOVE FROM JCT TO SSOB R4 T1955600 CLI JCTNUPAS,X'00' TEST FOR NEW PASSWORD R4 T1955700 BE HJS350 BR IF NO NEW PASSWORD R4 T1955800 MVC JCTPASS,JCTNUPAS MOVE NEW PASS TO CURRENT FIELD R4 T1955900 XC JCTNUPAS,JCTNUPAS ZERO NEW PASSWORD FIELD R4 T1956000 B HJS350 THEN BR TO CONTINUE R4 T1956100 SPACE 2 R4 T1956200 * R4 T1956300 * R4 T1956400 * JOB SELECT SUBROUTINE TO MOVE PASSWORDS FROM JCT TO SSOB R4 T1956500 * R4 T1956600 * R4 T1956700 HJS345 LR R15,R1 SAVE SSOB ADDR R4 T1956800 MVC 1(8,R1),0(R3) STORE PASSWRD IN SSOB R4 T1956900 LA R3,8 GET SIZE OF MAX PASSWORD R4 T1957000 SPACE 1 R4 T1957100 HJS346 TM 8(R1),X'BF' CHECK END OF FIELD FOR BLANK/ZERO R4 T1957200 BNZ HJS347 BR IF END OF PASSWORD R4 T1957300 BCTR R1,0 BACK UP ONE BYTE R4 T1957400 BCT R3,HJS346 SUBT TO GET VALID CHAR NUM R4 T1957500 SPACE 1 R4 T1957600 HJS347 DS 0H END OF PASSWORD FOUND R4 T1957700 STC R3,0(R15) STORE LENGTH OF PASSWORD R4 T1957800 BR R14 RETURN R4 T1957900 SPACE 1 R4 T1958000 $JSPSLEN EQU SSJSPAS2+L'SSJSPAS2-SSJSBGN EXT'N LEN NEEDED FOR PWDS R4 T1958100 EJECT R4 T1958200 HJS350 DS 0H R4 T1958300 MVC SSJSSTEP,JCTJSSTP MOVE RESTART STEP TO SSOBX. T1958400 NI JCTJSFLG,255-SSRQHOLD RESET RESTART HOLD FLAG. T1958500 MVC SSJSFLG1,JCTJSFLG MOVE RESTART FLAGS TO SSOBX. T1958600 LA R0,JCTJMR SET JMR POINTER T1958700 ST R0,SSJSJMR IN SSOB EXTENSION. T1958800 * T1958900 * T1959000 * FAKE-OPEN INTERNAL TEXT DATA SET T1959100 * T1959200 * T1959300 TM SJBFLG1,SJB1XBM IF NOT XBM, T1959500 BZ *+8 SKIP. T1960000 OI JCTJOBFL,JCTNOJNL PREVENT JOURNALING. T1960500 LA R3,SJBIACB POINT TO ACB. T1961000 ST R3,SSJSTACB STORE POINTER IN SSOBX. T1961500 L RIOT,SJBIOT POINT TO THE 1ST IOT. T1962000 L R15,$SVPDDB1 POINT TO R4 T1962100 LA R0,IOTPDBOT(RIOT,R15) INTERNAL TEXT PDDB R4 T1962200 CALL HFOPSUB CREATE AN SDB. T1962500 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T1963000 MVC SDBDDNM,=CL8'$INTTEXT' SHOW EBCDIC INTTEXT. T1963500 CALL HOOLDINP OPEN INTERNAL TEXT DATA SET. T1965000 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T1965500 CALL HCNVFDAD SET STARTING TRACK IN IOB. T1966000 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T1966500 EXCP SDBIOB PRIME THE DATA SET. T1967000 WAIT 1,ECB=SDBECB WAIT FOR I/O TO END. T1967500 * T1968000 * T1968500 * FAKE-OPEN JOB JOURNAL DATA SET T1969000 * T1969500 * T1970000 TM JCTJOBFL,JCTNOJNL IF JOB IS TO JOURNAL, T1970500 BZ HJS360 BRANCH. T1971000 * IF NO JOB JOURNAL EXISTS --- T1971500 SLR R3,R3 ZERO OUT JOURNAL T1972000 ST R3,SSJSJACB ACB POINTER IN SSOBX. T1972500 B HJS440 ELSE CONTINUE FAKE OPEN. T1973000 HJS360 DS 0H T1973500 * IF JOB JOURNAL EXISTS --- T1974000 LA R3,SJBJACB POINT TO JOURNAL ACB. T1974500 ST R3,SSJSJACB SET POINTER IN SSOBX. T1975000 L R15,$SVPDDB1 POINT TO R4 T1975100 LA R0,IOTPDBON(RIOT,R15) JOB JOURNAL PDDB R4 T1975200 CALL HFOPSUB CREATE SDB (R1=PDDB ON RETURN) R4 T1975300 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T1976000 MVC SDBDDNM,=CL8'$JOURNAL' SHOW EBCDIC JOURNAL. T1976500 * IF NEW JOURNAL, OPEN FOR OUTPUT T1978000 CLI SSJSFLG1,0 IF RESTART FLAGS NOT ALL OFF, T1978500 BNE HJS400 OPEN JOURNAL FOR INPUT. T1979000 HJS380 DS 0H T1979500 CALL HONEWOUT OPEN JOURNAL FOR OUTPUT. T1980000 BZ HJS440 CONTINUE IF OKAY. T1980500 B HJS830 ERROR - NO STORAGE AVAILABLE. T1981000 HJS400 DS 0H T1981500 * IF OLD JOURNAL, OPEN FOR INPUT, READ, AND WAIT T1982000 USING PDBDSECT,R1 SET PDDB ADDRESSABILITY. T1982500 TM PDBFLAG1,PDB1NULL IF JOURNAL NEVER USED, T1983000 BO HJS380 TRY TO OPEN FOR OUTPUT. T1983500 CALL HOOLDINP OPEN JOURNAL FOR INPUT. T1984000 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T1984500 CALL HCNVFDAD SET TRACK ADDRESS IN IOB. T1985000 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T1985500 EXCP SDBIOB START FIRST READ OF JOURNAL. T1986000 WAIT 1,ECB=SDBECB WAIT FOR ITS COMPLETION. T1986500 TM SDBFLG2,SDB2IOE IF NO I/O ERROR, T1987000 BZ HJS440 CONTINUE. T1987500 NI SSJSFLG1,255-SSJSWARM IF MORE THAN WARM START, T1988000 BNZ HJS440 LEAVE JOURNAL AS INPUT. T1988500 * ON WARM START, JOB JOURNAL DIDN'T MAKE IT. THE JOB NEVER GOT T1989000 * INITIATED. RESET JOURNAL TO OUTPUT. T1989500 $FREEBUF TYPE=PROT,A=SDBPBF FREE PROTECTED BUFFER. T1990000 SLR R0,R0 CLEAR REGISTER R4 T1990100 ST R0,SDBPBF CLEAR POINTER TO PBF R4 T1990200 $FREEBUF TYPE=UNPROT,A=SDBUBF FREE UNPROTECTED BUFFER. T1990500 SLR R0,R0 ZERO JOURNAL SDB'S T1991000 STH R0,SDBFLG1 FLAG BYTES 1 AND 2. T1991500 ST R0,SDBUBF CLEAR POINTER TO UBF R4 T1991600 L R7,SJBJCT RESTORE JCT ADDRESS R41 T1991700 B HJS380 GO OPEN JOURNAL FOR OUTPUT. T1992000 HJS440 DS 0H T1992500 * T1993000 * T1993500 * FAKE-OPEN SYSTEM MESSAGES DATA SET T1994000 * T1994500 * T1995000 LA R3,SJBMACB POINT TO SYSMSG ACB. T1995500 ST R3,SSJSMACB STORE ACB POINTER IN SSOBX. T1996000 L R15,$SVPDDB1 POINT TO R4 T1996100 LA R0,IOTPDBOM(RIOT,R15) SYSTEM MESSAGES PDDB R4 T1996200 CALL HFOPSUB CREATE SDB (R1=PDDB ON RETURN) R4 T1996300 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T1997000 MVC SDBRECCT,PDBRECCT-PDBDSECT(R1) BEGIN REC CNT @OZ19451 T1997250 OI SDBFLG1,SDB1OUT SHOW DATA SET SYSOUT. T1997500 MVC SDBDDNM,=CL8'$SYSMSGS' SHOW EBCDIC SYSMSGS. T1998000 NI PDBFLAG1,255-PDB1NULL SHOW DATA SET OPENED. R4 T1998100 L WA,JCTMSGSC GET CONTINUATION TRACK R41 T1999000 BAL WE,HJSREOPN REPOSITION DS IF WARM START R41 T1999100 BNZ HJSOPNOL BR IF WARM START R41 T1999200 SPACE 1 R41 T1999300 L R0,PDBMTTR GET STARTING MTTR IN R0. T2000000 DROP R1 DROP PDDB BASE. T2000500 LA R1,X'100' CONVERT MTTR T2001000 SRDL R0,8 TO RBA AND STORE IN T2001500 STM R0,R1,SDBTRKF SDB AS STARTING RBA. T2002000 CALL HOOLDOUT OPEN FOR OUTPUT. T2002500 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T2003000 L R0,JCTMSGSC GET SYSMSG CONTINUATION TRACK. T2003500 CALL HJSRETAB REBUILD TRACK ALLOC. BLOCK R41 T2003700 LA R1,X'100' CHANGE IT TO T2004000 SRDL R0,8 RBA FORMAT. T2004500 STM R0,R1,SDBTRK SET RBA IN SDBTRK. T2005000 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T2005500 STM R0,R1,BFRBA SET RBA IN BFRBA. T2006000 * T2006500 * T2007000 * FAKE-OPEN HASP JOB LOG DATA SET T2007500 * T2008000 * T2008500 HJSOPNOL DS 0H R41 T2008600 LA R3,SJBLACB POINT TO HASP LOG ACB. T2009000 L R15,$SVPDDB1 POINT TO R4 T2009100 LA R0,IOTPDBOL(RIOT,R15) HASP JOB LOG PDDB R4 T2009200 CALL HFOPSUB CREATE SDB (R1=PDDB ON RETURN) R4 T2009300 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T2010000 MVC SDBRECCT,PDBRECCT-PDBDSECT(R1) BEGIN REC CNT @OZ19451 T2010250 OI SDBFLG1,SDB1OUT SHOW DATA SET SYSOUT. T2010500 MVC SDBDDNM,=CL8'$JES2LOG' SHOW EBCDIC JES2LOG. T2011000 NI PDBFLAG1-PDBDSECT(R1),255-PDB1NULL SHOW DATASET OPENED. T2012500 L WA,JCTJLOGC GET CONTINUATION TRACK R41 T2012600 BAL WE,HJSREOPN REPOSITION DS IF WARM START R41 T2012700 BNZ HJS550 BR IF WARM START R41 T2012800 SPACE 1 R41 T2012900 CALL HOOLDOUT OPEN DATA SET FOR OUTPUT. T2013000 BNZ HJS830 ERROR - NO STORAGE AVAILABLE. T2013500 L R0,JCTJLOGC GET CONTINUATION TRACK. T2014000 CALL HJSRETAB REBUILD TRACK ALLOC. BLOCK R41 T2014300 LA R1,X'100' CONVERT IT TO T2014500 SRDL R0,8 RBA FORMAT. T2015000 STM R0,R1,SDBTRK SET RBA IN SDBTRK. T2015500 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T2016000 STM R0,R1,BFRBA SET RBA IN BFRBA. T2016500 HJS550 DS 0H R41 T2016600 L R0,SSJSJACB IF JOB HAS T2017000 LTR R0,R0 NO JOURNAL T2017500 BNZ HJS560 DATA SET, BUT WILL T2018000 CLI SSJSFLG1,0 WARM START OR RESTART, T2018500 BNE HJS870 WRITE MESSAGE. T2019000 HJS560 DS 0H T2019500 * T2023000 * T2023500 * CONCLUDE JOB SELECTION T2024000 * T2024500 * T2025000 TM SJBFLG1,SJB1SJID IF SELECT-BY-ID, T2025500 BO HJS575 BRANCH. T2026000 HJS570 DS 0H T2026500 TM $SVSTUS,$SVSTXST IF HASP IS NOT MONITORING T2027000 BZ HJS575 TIME EXCESSIONS, BRANCH. T2027500 * T2028000 * T2028500 * ALLOW HASP TO MONITOR TIME EXCESSIONS T2029000 * T2029500 * T2030000 L R1,JCTETIME PROVIDE HASP T2030500 LNR R1,R1 WITH INITIAL T2031000 ST R1,SJBXSTIM TIME INTERVAL T2031500 $$POST ELMT=$SVXSTIM POST HASPTIME FOR WORK T2032000 HJS575 DS 0H T2032500 TM SJBFLG1,SJB1XBMC IF XBM CONTINUATION, T2033000 BO HJS600 RETURN TO HAMGET. T2033500 * T2034000 * T2034500 * CALL IEFIB600, THE SCHEDULER WORK AREA CREATOR T2035000 * T2035500 * T2036000 TM SJBFLG1,SJB1SJID IF NOT SELECT-BY-ID, T2036500 BZ HJS580 DON'T CHECK CONVERTER CODE. T2037000 L R0,SSJSSERR EXAMINE CONVERTER T2037500 LTR R0,R0 COMPLETION CODE. T2038000 BNZ HJS830 IF NON-ZERO, SKIP IEFIB600. T2038500 HJS580 DS 0H T2039000 TM SJBFLG1,SJB1XBM TEST FOR XBM. @OZ26957 T2039020 BZ HJS582 NOT XBM, SKIP. @OZ26957 T2039040 CALL HCBGM GET DUMMY JCT BUFFER. @OZ26957 T2039060 BNZ HJS830 ERROR IF NO STORAGE. @OZ26957 T2039080 * PREPARE DUMMY JCT TO REPRESENT XBM * @OZ26957 T2039100 DROP R7 DROP PREVIOUS JCT BASE @OZ26957 T2039105 USING JCTDSECT,R1 MAKE NEW JCT ADDRESSABLE @OZ26957 T2039110 MVC JCTJMRST(L'JCTJMR),JCTJMRST-JCTDSECT(R7) @OZ26957 T2039120 MVC JCTJMRJN(8),SJBXBJNM SUBSTITUTE XBM JOBNAME. @OZ26957 T2039140 LR R7,R1 PRESERVE DUMMY JCT ADDR. @OZ26957 T2039160 DROP R1 DROP CURRENT JCT BASE @OZ26957 T2039165 USING JCTDSECT,R7 USE PREV. BASE FOR NEW JCT @OZ26957 T2039170 $TIME GET CURRENT TIME AND DATE. @OZ26957 T2039180 STM R0,R1,JCTRDRON XBM TIME ON READER @OZ26957 T2039200 STM R0,R1,JCTRDROF IS VERY BRIEF. @OZ26957 T2039220 LA R1,JCTJMR SET XBM JMR POINTER @OZ26957 T2039240 ST R1,SSJSJMR IN SSOB EXT. @OZ26957 T2039260 HJS582 DS 0H @OZ26957 T2039280 L R1,4(,R13) POINT R1 T2039500 L R1,24(,R1) TO USER'S SSOB. T2040000 SPACE 1 T2040500 LINK EP=IEFIB600 LINK TO IEFIB600. T2041000 SPACE 1 T2041500 ST R15,SSJSSERR SAVE IEFIB600 RETURN CODE. T2042000 TM SJBFLG1,SJB1XBM TEST FOR XBM. @OZ26957 T2042020 BZ HJS587 SKIP IF NOT. @OZ26957 T2042040 LR R1,R7 RESTORE DUMMY JCT ADDR. @OZ26957 T2042060 L R7,SJBJCT RESTORE USER'S JCT ADDR. @OZ26957 T2042070 CALL HCBFM FREE DUMMY JCT BUFFER. @OZ26957 T2042080 HJS587 DS 0H @OZ26957 T2042090 BAL R14,HJSMSG1 WTO 'HASP373 STARTED'. T2042100 LA R1,SJBLRPL POINT TO RPL @OZ44947 T2042130 ENDREQ RPL=(1) WRITE JOB LOG TO SPOOL @OZ44947 T2042160 L R15,SSJSSERR GET IEFIB600 RETURN CODE. T2042200 LTR R15,R15 IF CODE IS ZERO, T2042500 BZ HJS590 CONTINUE. T2043000 TM SJBFLG1,SJB1SJID IF NON-ZERO CODE, T2043500 BO HJS830 END INITIATOR IF SELECT-ID. T2044000 B HJS840 IN ANY CASE TERMINATE JOB. T2044500 HJS590 DS 0H T2045000 * T2045500 * T2046000 * PROCESS OPERATOR CANCEL AND SET SJBCSCB T2046500 * T2047000 * T2047500 L R1,SSJSLCT POINT TO LINKAGE CONTROL TABLE. T2048000 USING LCTDSECT,R1 SET LCT ADDRESSABILITY. T2048500 L R1,LCTQDRTY POINT TO CSCB FROM LCT. T2049000 USING CSCDSECT,R1 SET CSCB ADDRESSABILITY. T2049500 ST R1,SJBCSCB SAVE CSCB POINTER IN SJB. T2050000 TM SJBFLG2,SJB2CNCL IF NOT OPERATOR CANCEL, T2050500 BZ HJS595 PROCEED. T2051000 OI CHACT,CHCLD SHOW CANCEL OF WHOLE JOB. T2051500 MVC CHCECB,=X'40000222' POST CANCEL ECB. T2052000 DROP R1 DROP CSCB BASE. T2052500 HJS595 DS 0H T2053000 * T2053500 * T2054000 * IF JOURNAL WAS OPEN FOR INPUT, CHANGE IT TO OUTPUT T2054500 * T2055000 * T2055500 L RSDB,SSJSJACB POINT TO JOURNAL ACB. T2056000 LTR RSDB,RSDB IF NO JOURNAL, T2056500 BZ HJS900 JUST RETURN TO INITIATOR. T2057000 USING IFGACB,RSDB SET ACB ADDRESSABILITY. T2057500 L RSDB,ACBDEB-1 POINT FROM ACB TO DEB. T2058000 USING DEBBASIC,RSDB SET DEB ADDRESSABILITY. T2058500 L RSDB,DEBIRBAD POINT FROM DEB TO SDB. T2059000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T2059500 TM SDBFLG1,SDB1GET IF JOURNAL NOW OUTPUT, T2060000 BZ HJS900 JUST RETURN TO INITIATOR. T2060500 * CHANGE JOURNAL DATA SET FROM INPUT TO OUTPUT, T2061000 * LEAVING UNPROTECTED BUFFER INTACT (SINCE LAST OPERATION T2061500 * DONE TO JOURNAL WAS A POINT). T2062000 $FREEBUF TYPE=PROT,A=SDBPBF FREE PROTECTED BUFFER. T2062500 L R7,SJBJCT RESTORE JCT BASE @OZ40702 T2062700 SLR R0,R0 ZERO PROTECTED-BUFFER T2063000 ST R0,SDBPBF POINTER IN SDB. T2063500 XI SDBFLG1,SDB1GET+SDB1PUT FLAG SDB FOR OUTPUT. T2064000 MVI SDBCCW4,X'05' SET WRITE-DATA CCW. T2064500 B HJS900 NOW RETURN TO INITIATOR. T2065000 HJS600 DS 0H T2065500 * T2066000 * T2066500 * EXECUTION BATCH MONITOR CONTINUATION - T2067000 * RE-OPEN ALL SUBSYSTEM DATA SETS T2067500 * T2068000 * T2068500 LA RSDB,SJBSDB POINT TO SDB CHAIN. T2069000 SL RSDB,=A(SDBSDB-SDBDSECT) SET UP TO CHAIN. T2069500 HJS620 DS 0H T2070000 L RSDB,SDBSDB POINT TO THE NEXT SDB. T2070500 LTR RSDB,RSDB IF NO MORE, T2071000 BZ HJS660 END OF XBMC FAKE OPEN. T2071500 CLI SDBDKEY+1,PDBINTXT IF INTERNAL TEXT DATA SET, T2072000 BE HJS620 CONTINUE WITH NEXT SDB. T2072500 NI SDBFLG2,SDB2XBIN+SDB2MCLS OF FLAG2 BUT XBIN, MCLS. T2073000 L R2,SDBPDDB ESTABLISH PDDB T2073500 USING PDBDSECT,R2 ADDRESSABILITY. T2074000 TM SDBFLG2,SDB2XBIN IS THIS BATCH INPUT UNIT... T2074500 BNZ HJS640 BRANCH IF BATCH INPUT UNIT. T2075000 TM SDBFLG1,SDB1FOPN IF INTERNAL DATA SET @OZ29148 T2075100 BO HJS621 BYPASS NEXT TEST @OZ29148 T2075125 TM SDBFLG2,SDB2MCLS IF ORIGINAL OUTPUT CLASS @OZ29148 T2075150 BZ HJS622 WAS NOT $ OR *, SKIP THIS @OZ29148 T2075175 HJS621 DS 0H @OZ29148 T2075200 MVC PDBCLASS,JCTMCLAS SET CLASS FROM JCT @OZ29148 T2075220 NI PDBFLAG1,255-PDB1NSOT-PDB1HOLD RESET FLAG BITS @OZ29148 T2075240 NI PDBFLAG2,255-PDB2TCEL RESET TRACKCELL @OZ29148 T2075260 SLR R3,R3 ZERO R3 FOR IC @OZ29148 T2075280 IC R3,JCTMCLAS GET MESSAGE CLASS @OZ29148 T2075300 LA R1,$SVSCAT(R3) POINT TO ITS SCAT ENTRY @OZ29148 T2075320 TM PDBFLAG2,PDB2HLDS IF HOLD=YES ON DD CARD @OZ29148 T2075340 BO *+12 DONT CHECK SCATHOLD @OZ29148 T2075360 TM SCATFLAG-SCADSECT(R1),SCATHOLD HOLD CLASS... @OZ29148 T2075380 BZ *+8 BRANCH IF NOT @OZ29148 T2075400 OI PDBFLAG1,PDB1HOLD SHOW HELD DATA SET @OZ29148 T2075425 TM SCATFLAG-SCADSECT(R1),SCATDUMM DUMMY CLASS... @OZ29148 T2075450 BZ *+8 BRANCH IF NOT @OZ29148 T2075475 OI PDBFLAG1,PDB1NSOT MARK AS DUMMY @OZ29148 T2075500 TM SCATFLAG-SCADSECT(R1),SCATTCEL IF CLASS NOT @OZ29148 T2075525 BZ HJS622 TRACKCELLED, THEN BRANCH @OZ29148 T2075550 OI PDBFLAG2,PDB2TCEL SHOW TRACKCELLED DATA SET @OZ29148 T2075575 HJS622 DS 0H @OZ29148 T2075600 TM PDBFLAG2,PDB2JFMS IF ORIGINAL FORMS @OZ29148 T2075625 BZ *+10 WAS SET FROM JCT @OZ29148 T2075650 MVC PDBFORMS,JCTFORMS THEN SET NEW JCTFORMS @OZ29148 T2075675 NI PDBFLAG1,255-PDB1NULL RESET NULL @OZ29148 T2075700 TM PDBFLAG3,PDB3BRST IF XBM PROC HAS BURST PARM @OZ55601 T2075712 BO SKIP15 DON'T USE JOBPARM VALUE. @OZ55601 T2075714 NI PDBFLAG2,255-PDB2BRST ELSE ASSUME NO BURST. @OZ55601 T2075716 TM JCTFLAG1,JCTBURST BUT IF JOB'S DEFAULT IS @OZ55601 T2075718 BZ SKIP15 BURST=Y, THEN SET NEW @OZ55601 T2075720 OI PDBFLAG2,PDB2BRST JCTBURST. @OZ55601 T2075722 SKIP15 DS 0H @OZ55601 T2075724 TM JCTJOBFL,JCTNOUPT TEST 'NO OUTPUT' OPTION @OZ29148 T2075725 BO SKIP20 BR TO SET NSOT @OZ29148 T2075750 TM PDBFLAG1,PDB1LOG TEST FOR JES2 JOB LOG @OZ29148 T2075775 BZ HJS625 BRANCH IF NO @OZ29148 T2075800 TM JCTJBOPT,JCTNOLOG TEST 'NOLOG' OPTION @OZ29148 T2075825 BZ HJS625 BRANCH IF NOT SET @OZ29148 T2075850 SKIP20 OI PDBFLAG1,PDB1NSOT MAKE NON PRINTABLE @OZ29148 T2075875 HJS625 DS 0H R4 T2075900 XC SDBTAB(SDBAIOT-SDBTAB),SDBTAB CLEAR THE TAB @OZ18630 T2075910 OI SDBTAB+(TABFLAG-TABDSECT),TABMINOR SHOW MINOR @OZ18630 T2075920 TM PDBFLAG2,PDB2TCEL IS DATA SET TRACKCELLED @OZ18630 T2075930 BZ HJS627 BRANCH IF NOT @OZ18630 T2075940 OI SDBTAB+(TABFLAG-TABDSECT),TABMAJOR SHOW MAJOR @OZ18630 T2075950 HJS627 DS 0H @OZ18630 T2075960 SLR R0,R0 ZERO THE SDB'S @OZ29019 T2075992 ST R0,SDBRECCT OUTPUT RECORD COUNT @OZ29019 T2075994 BCTR R0,0 SET OUTPUT LIMIT @OZ29019 T2075996 ST R0,SDBOUTLM TO MAXIMUM @OZ29019 T2075998 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T2076000 LTR RBUF,RBUF IF BUFFER PRESENT, DATASET WAS OPEN T2076500 BNZ HJS630 AT LAST XBM JOB TERMINATE (RE-OPEN). T2077000 OI PDBFLAG1,PDB1NULL ELSE, SHOW UNOPENED DATASET - BATCH T2077500 ST RBUF,PDBMTTR MONITOR WILL OPEN WHEN NECESSARY. T2078000 B HJS620 CONTINUE WITH NEXT SDB. T2078500 SPACE 1 T2079000 * RE-OPEN OUTPUT DATA SET T2079500 HJS630 DS 0H T2080000 * THIS LINE DELETED BY APAR NUMBER @OZ18630 T2080500 LA R1,SDBTAB POINT TO TRACK ALLOC BLOCK @OZ18630 T2080600 CALL $STRAK GET A TRACK FOR DATA SET. T2081500 ST R1,PDBMTTR STORE TRACK IN PDDB. T2082000 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2082500 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2083000 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2083500 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2083600 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2083700 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2083800 LR R0,R1 CONVERT T2084000 LA R1,X'100' TRACK ADDRESS T2084500 SRDL R0,8 TO RBA. T2085000 STM R0,R1,SDBTRKF SET STARTING TRACK. T2085500 STM R0,R1,SDBTRK SET CURRENT TRACK. T2086000 STM R0,R1,BFRBA SET RBA IN BUFFER. T2086500 * THIS LINE DELETED BY APAR NUMBER @OZ29019 T2087000 * THIS LINE DELETED BY APAR NUMBER @OZ29019 T2087500 * THIS LINE DELETED BY APAR NUMBER @OZ29019 T2088000 * THIS LINE DELETED BY APAR NUMBER @OZ29019 T2088500 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2089000 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2089500 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2090000 CLI SDBDKEY+1,PDBOUHJL IF NOT JES2 JOB LOG, T2090500 BNE HJS620 CONTINUE WITH NEXT SDB. T2091000 * THIS LINE DELETED BY APAR NUMBER @OZ29148 T2091500 * RE-TITLE THE JES2 JOB LOG T2092000 L R0,=A(HASPAM) GET HAM ADDRESS. T2092500 ST R0,SJBLACB+ACBINRTN-IFGACB DE-NULLIFY JOB LOG. T2093000 LM R2,R3,=A(HJLHDR,HJLHDL) POINT TO TITLE, LENGTH. T2093500 MVC BFDAT(HJLHDL),0(R2) MOVE TITLE INTO BUFFER. T2094000 L R0,BFLEN REDUCE T2094500 SLR R0,R3 REMAINING LENGTH T2095000 ST R0,BFLEN BY TITLE LENGTH. T2095500 AL R3,BFLOC INCREASE BUFFER OFFSET T2096000 ST R3,BFLOC BY TITLE LENGTH. T2096500 BAL R14,HJSMSG1 WTO 'HASP373 STARTED'. T2097000 LA R1,SJBLRPL POINT TO RPL @OZ44947 T2097100 ENDREQ RPL=(1) WRITE JOB LOG TO SPOOL @OZ44947 T2097300 B HJS620 CONTINUE WITH NEXT SJB. T2097500 * RE-OPEN THE BATCH INPUT DATA SET T2098000 HJS640 DS 0H T2098500 MVC SDBMTTR,PDBMTTR MOVE TRK ADR FOR CONVERSION. T2099000 CALL HCNVFDAD CONVERT TRACK ADDRESS. T2099500 EXCP SDBIOB READ FIRST RECORD. T2100000 WAIT 1,ECB=SDBECB WAIT TILL IT'S READ. T2100500 B HJS620 CONTINUE WITH NEXT SDB. T2101000 HJS660 DS 0H T2101500 * T2102000 * T2102500 * RETURN TO HAMGET TO CONTINUE T2103000 * EXECUTION BATCH MONITOR OPERATION T2103500 * T2104000 * T2104500 CALL HCBCK CHECKPOINT CONTROL BLOCKS. T2105000 SL R12,=A(HJSBASE-SVCHBASE) ADJUST BASE TO SVCHAM. T2105500 USING SVCHBASE,R12 TELL THE ASSEMBLER. T2106000 B SX100 RETURN TO SVCXBM. T2106500 USING HJSBASE,R12 RESTORE LOCAL ADDRESSABILITY. T2107000 EJECT T2110200 * T2110300 * T2110400 * ERROR EXITS FROM JOB SELECT T2110500 * T2110600 * T2110700 HJS800 DS 0H T2110800 * T2111000 * T2111500 * UNABLE TO ACQUIRE COMMON STORAGE FOR T2112000 * SUBSYSTEM JOB BLOCK, OR NORMAL INITIATOR STOP, T2112500 * OR CONVERTER/INTERPRETER ERROR IF SELECT- T2113000 * BY-JOB-ID T2113500 * T2114000 * T2114500 $MID 350 SET HASP MESSAGE ID. T2115000 WTO '&MID.INIT STOPPED',ROUTCDE=2,DESC=4 WRITE MSG. T2115500 HJS805 DS 0H T2116000 LA R10,SSJSISTP ASSUME NORMAL STOP CODE. T2116500 LTR R12,R12 IF NO SJB COULD BE GOT, T2117000 BNM HJS820 RETURN NORMAL STOP CODE. T2117500 TM SJBFLG1,SJB1SJID IF NOT SELECT-JOB-BY-ID, T2118000 BZ HJS810 FREE SJB AND RETURN NORMAL. T2118500 L R0,SSJSSERR IF NOT ERROR FROM CONVERTER T2119000 LTR R0,R0 OR INTERPRETER, RETURN T2119500 BZ HJS810 NORMAL STOP CODE. T2120000 LA R10,SSJSYSER ELSE RETURN SYSTEM ERROR. T2120500 HJS810 DS 0H T2121000 CALL $SJBFREE FREE THE SJB. T2121500 HJS820 DS 0H T2122000 LR R15,R10 SET RETURN CODE IN R15 T2122500 B HJS950 AND RETURN TO INITIATOR. T2123000 SPACE 3 T2123500 HJS830 DS 0H T2124000 * T2124500 * T2125000 * INSUFFICIENT COMMON STORAGE OR PRIVATE STORAGE TO T2125500 * INITIATE A JOB. CAUSE INITIATOR TO TERMINATE T2126000 * AND JOB (UNLESS SELECTED BY ID) TO RERUN. T2126500 * T2127000 * T2127500 OI SJBFLG2,SJB2PNIT CAUSE NEXT SELECT TO END INIT. T2128000 TM SJBFLG1,SJB1SJID IF SELECT-JOB-BY-ID, T2128500 BO HJS840 DON'T RE-RUN JOB. T2129000 OI SJBFLG1,SJB1EJOB ELSE CAUSE JOB TO RERUN. T2129500 HJS840 DS 0H T2130000 * T2130500 * T2131000 * TERMINATE JOB BY CALLING HOSTERM T2131500 * T2132000 * T2132500 SL R12,=A(HJSBASE-HJEBASE) ADJUST BASE TO HOSTERM. T2133000 USING HJEBASE,R12 TELL THE ASSEMBLER. T2133500 B HJEJBSL TERMINATE THE SELECTED JOB. T2134000 USING HJSBASE,R12 RESTORE LOCAL ADDRESSABILITY. T2134500 HJS850 DS 0H T2135000 * T2135500 * T2136000 * JOB NOT FOUND BUT SELECTED BY ID T2136500 * T2137000 * T2137500 $MID 361 SET HASP MESSAGE ID. T2138000 WTO '&MID.JOB NOT FOUND',ROUTCDE=10,DESC=6 T2138500 CALL $SJBFREE FREE THE SJB. T2139000 LA R15,SSJSPERR SET PROGRAM ERROR CODE. T2139500 B HJS950 RETURN TO THE INITIATOR. T2140000 SPACE 3 T2140500 HJS870 DS 0H T2141000 * T2141500 * T2142000 * JOB JOURNAL ABSENT BUT REQUIRED T2142500 * T2143000 * T2143500 $MID 374 SET MESSAGE ID. T2144000 WTO '&MID. - JOB HAS NO JOURNAL',ROUTCDE=11,DESC=6 T2144500 B HJS840 GO TERMINATE THE JOB. T2145000 EJECT T2145500 HJS900 DS 0H T2146000 * T2146500 * T2147000 * NORMAL RETURN FROM JOB SELECTION TO INITIATOR T2147500 * T2148000 * T2148500 OI JCTFLAG1,JCT1CKPT FLAG JCT FOR CKPT @OZ31931 T2148750 CALL HCBCK CHECKPOINT JOB CONTROL BLOCKS. T2149000 SLR R15,R15 RETURN ZERO CODE - JOB SELECT T2149500 * WORKED OKAY. T2150000 SPACE 3 T2150500 HJS950 DS 0H T2151000 $EPILOG , RETURN TO INITIATOR. T2151500 * T2152000 * SUBROUTINE TO WRITE MESSAGE HASP373 T2152500 * T2153000 $MID 373 SET MESSAGE ID. T2153500 HJSMSG1 DS 0H T2154000 TM SJBFLG1,SJB1SJID IF SELECT-BY-CLASS, T2154500 BZ HJSMSG11 BRANCH. T2155000 WTO '&MID.STARTED',ROUTCDE=2,DESC=6 T2155500 BR R14 WRITE SHORT MSG, RETURN. T2156000 HJSMSG11 DS 0H T2156500 L R7,SJBJCT POINT R7 TO JCT. T2157000 MVC HJSMSG1Z,HJSMSG1A MOVE MESSAGE. T2157500 MVC HJSMSG1Y,SJBPATID MOVE INITIATOR ID. T2158000 MVC HJSMSG1X,SJBJCLAS MOVE CLASS ID. T2158500 MVC HJSMSG1W,JCTCPUID MOVE SYSTEM ID. T2158800 WTO MF=(E,JCTWORK) WRITE MESSAGE. T2159000 DROP R7 DROP JCT BASE. T2159500 BR R14 RETURN. T2160000 HJSMSG1A WTO '&MID.STARTED - INIT XX - CLASS Y - SYS ZZZZ', CT2160500 ROUTCDE=2,DESC=6,MF=L T2161000 HJSMSG1B EQU * T2161500 HJSMSG1Z EQU JCTWORK,HJSMSG1B-HJSMSG1A MESSAGE T2162000 HJSMSG1Y EQU JCTWORK+4+9+15,2 INITIATOR ID R4 T2162500 HJSMSG1X EQU JCTWORK+4+9+26,1 CLASS ID R4 T2163000 HJSMSG1W EQU JCTWORK+4+9+34,4 SYSTEM ID R4 T2163300 EJECT R41 T2163500 USING JCTDSECT,R7 PROVIDE JCT ADDRESSABILITY R41 T2163600 DROP RBUF RE-ESTABLISH R41 T2163700 USING BFDSECT,WA BUFFER ADDRESSABILITY R41 T2163800 SPACE 1 R41 T2163900 HJSREOPN TM JCTJSFLG,SSJSWARM TEST FOR WARM START R41 T2164000 BO *+10 BR IF YES TO REPOSITION R41 T2164100 TM JCTJBOPT,JCTRERUN TEST FOR JOB RE-RUN R41 T2164200 BZR WE RETURN IF NO WITH VALID CC R41 T2164300 SPACE 1 R41 T2164400 CALL HOOLDINP OPEN DATA SET FOR INPUT R41 T2164500 BNZ HJS830 BR IF INSUFFICIENT STORAGE R41 T2164600 ST WA,SDBMTTR SET CONTINUATION TRACK ADDR R41 T2164700 CALL HCNVFDAD SET TRACK ADDRESS IN IOB R41 T2164800 L WA,SDBUBF POINT TO UNPROTECTED BUFFER R41 T2164900 SPACE 1 R41 T2165000 HJSIO DS 0H @OZ41000 T2165100 EXCP SDBIOB START I/O OPERATION R41 T2165200 WAIT 1,ECB=SDBECB WAIT FOR I/O COMPLETION R41 T2165300 TM SDBFLG2,SDB2IOE+SDB2EOD TEST I/O STATUS R41 T2165400 BNZ HJSBFLST BR IF ERROR OR EOD R41 T2165500 OI BFFL1,BF1EOB ALLOW UBF REFILL R41 T2165600 B HJSIO BR TO READ NEXT BUFFER R41 T2165700 SPACE 1 R41 T2165800 HJSBFLST L R0,SDBMTTR GET R41 T2165900 TM SDBFLG2,SDB2IOE CONTINUATION R41 T2166000 BO HJSRBTAB TRACK R41 T2166100 ICM R0,15,SDBTRK+1 ADDRESS R41 T2166200 SPACE 1 R41 T2166300 HJSRBTAB CALL HJSRETAB RE-BUILD TRACK ALLOC. BLOCK R41 T2166400 XI SDBFLG1,SDB1GET+SDB1PUT RESET FOR OUTPUT R41 T2166500 MVI SDBCCW4,5 SET CCW FOR DATA WRITES R41 T2166600 MVI SDBCHEND,SDBCEPUT SET CHANNEL-END OPTION R41 T2166700 TM SDBFLG2,SDB2IOE TEST I/O STATUS R41 T2166800 BO HJSIOE BR IF ERROR (RAN OFF END) R41 T2166900 MVC SDBMTTR,SDBTRK+1 RESET TRACK ADDRESS R41 T2167000 CLI BFDAT,LRCBFEND TEST FOR LOGICALLY EMPTY BFR R41 T2167100 BE HJSIOE BR IF SO TO RE-USE BUFFER R41 T2167200 L R1,=A(HFCMSG) POINT TO 'JOB DELETED' TEXT R41 T2167300 CLC BFDAT(HFCMSGL),0(R1) TEST FOR SAME R41 T2167400 BE HJSIOE BR IF SO TO RE-USE BUFFER R41 T2167500 CALL HCNVFDAD SET TRACK ADDRESS IN IOB R41 T2167600 LA R1,SDBTAB POINT TO TRACK ALLOC. BLOCK R41 T2167700 CALL $STRAK GET TRACK FOR NEXT BUFFER R41 T2167800 L WA,SDBPBF POINT TO PROTECTED BUFFER R41 T2167900 ST R1,BFNXT SET CHAIN TRACK ADDRESS R41 T2168000 LR WA,R1 SAVE NEW TRACK ADDRESS R41 T2168100 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T2168200 EXCP SDBIOB START I/O OPERATION R41 T2168300 WAIT 1,ECB=SDBECB WAIT FOR I/O COMPLETION R41 T2168400 ST WA,SDBMTTR SET NEW TRACK ADDRESS R41 T2168500 B HJSNXTBF BR TO CONTINUE R41 T2168600 SPACE 1 R41 T2168700 HJSIOE $FREEBUF TYPE=PROT,A=SDBPBF FREE PROTECTED BUFFER R41 T2168800 L R7,SJBJCT RESTORE JCT ADDRESS IN R7 R41 T2168900 SLR R1,R1 CLEAR R41 T2169000 ST R1,SDBPBF BUFFER ADDRESS R41 T2169100 SPACE 1 R41 T2169200 HJSNXTBF L R0,SDBMTTR GET TRACK ADDRESS R41 T2169300 LA R1,X'100' CONVERT TO R41 T2169400 SRDL R0,8 RBA FORMAT R41 T2169500 L WA,SDBUBF POINT TO UNPROTECTED BUFFER R41 T2169600 STM R0,R1,SDBTRK SET RBA IN SDB R41 T2169700 STM R0,R1,BFRBA AND IN BUFFER R41 T2169800 LH R0,$SVBFSIZ GET BUFFER SIZE R41 T2169900 SL R0,=A(BFDAT+1-BFIO) SET LENGTH R41 T2170000 ST R0,BFLEN OF DATA AREA R41 T2170100 LA R1,BFDAT SET POINTER IN UBF @OZ25160 T2170130 ST R1,BFLOC FOR FIRST LOGICAL RECORD @OZ25160 T2170160 SLR R1,R1 CLEAR R41 T2170200 ST R1,BFTRK TRACK ADDRESS R41 T2170300 ST R1,BFNXT AND CHAIN ADDRESS R41 T2170400 MVC BFKEY,SDBJKEY ENSURE VALID DATA SET KEY R41 T2170500 NI SDBFLG2,255-SDB2EOD-SDB2IOE RESET FLAGS R41 T2170600 SLR R15,R15 SET NON-ZERO CONDITION CODE R41 T2170700 BR WE RETURN TO CALLER R41 T2170800 EJECT R41 T2170900 *********************************************************************** T2171000 * * T2171100 * HJSRETAB -- SUBROUTINE TO REBUILD SDB TRK ALLOC'N BLK * T2171200 * * T2171300 * INPUT R0 - RESUME MTTR, VALID ON EXIT * T2171400 * R10 - SDB ADDRESS * T2171500 * R13 - SAVE AREA ADDRESS * T2171600 * R14 - RETURN ADDRESS * T2171700 * R15 - ENTRY POINT ADDRESS * T2171800 * * T2171900 *********************************************************************** T2172000 SPACE 1 R41 T2172100 USING TABDSECT,R14 PROVIDE TAB ADDRESSABILITY R41 T2172200 USING HJSRETAB,R15 PROVIDE LOCAL ADDRESSABILITY R41 T2172300 SPACE 1 R41 T2172400 HJSRETAB STM R14,R2,12(R13) SAVE REGISTERS R41 T2172500 LA R14,SDBTAB ADDRESS TAB IN SDB R41 T2172600 LR R2,R0 COMPUTE R41 T2172700 SRL R2,24 TRACK-EXTENT-DATA R41 T2172800 MH R2,=Y(TEDSIZ) BLOCK R41 T2172900 AL R2,$SVTFRST ADDRESS R41 T2173000 LH R2,TNRT-TEDDSECT(,R2) SET MAX RECORD R41 T2173100 STC R2,TABMAXR NUMBER IN TAB R41 T2173200 ST R0,TABMTTR SET MTTR IN TAB R41 T2173300 MVI TABSPN,1 INIT SUB-PERM VALUE IN TAB R41 T2173400 IC R2,$SVRINCR R2 = &RECINCR R41 T2173500 IC R0,=X'01' MTT1 -- 1ST RECORD ON TRACK R41 T2173600 SLR R1,R1 CLEAR BUFFER COUNT R41 T2173700 SPACE 1 R41 T2173800 HRETAB10 IC R1,$SVTKCEL SET FOR MAX TRACK-CELL R41 T2173900 SPACE 1 R41 T2174000 HRETAB20 CLM R0,1,TABMTTR+3 SEARCH FOR RECORD R41 T2174100 BE HRETAB40 BR IF FOUND R41 T2174200 ALR R0,R2 INCR MTTR BY &RECINCR R41 T2174300 CLM R0,1,TABMAXR TOO HIGH FOR TRACK... R41 T2174400 BNH HRETAB30 BR IF NO R41 T2174500 IC R0,TABSPN ELSE INCR SUB-PERM R41 T2174600 AL R0,=F'1' VALUE AND RESET R41 T2174700 STC R0,TABSPN TRACK ADDRESS (MTTP) R41 T2174800 SPACE 1 R41 T2174900 HRETAB30 BCT R1,HRETAB20 DECR BUFFER COUNT R41 T2175000 B HRETAB10 NEW TRACK CELL IF ZERO R41 T2175100 EJECT R41 T2175200 HRETAB40 MVC 12(1,R13),TABSPN SAVE SUB-PERM VALUE R41 T2175300 STC R1,TABUFCNT SAVE BUFFER COUNT, SO FAR R41 T2175400 SPACE 1 R41 T2175500 HRETAB50 BCT R1,HRETAB60 DECR BUFFER COUNT R41 T2175600 B HRETAB70 BR IF LAST RECORD IN CELL R41 T2175700 SPACE 1 R41 T2175800 HRETAB60 ALR R0,R2 INCR MTTR BY &RECINCR R41 T2175900 CLM R0,1,TABMAXR TOO HIGH FOR TRACK... R41 T2176000 BNH HRETAB50 LOOP IF NOT R41 T2176100 CLM R2,1,12(R13) ENTIRE TRACK DEPLETED... R41 T2176200 BNH HRETAB70 RETURN IF YES -- SHORT CELL R41 T2176300 IC R0,12(,R13) ELSE INCR SUB-PERM R41 T2176400 AL R0,=F'1' VALUE AND RESET R41 T2176500 STC R0,12(,R13) TRACK ADDRESS (MTTP) R41 T2176600 B HRETAB50 BR TO CONTINUE R41 T2176700 SPACE 1 R41 T2176800 HRETAB70 IC R2,TABUFCNT SET REMAINING R41 T2176900 SLR R2,R1 BUFFER COUNT R41 T2177000 BCTR R2,0 IN R41 T2177100 STC R2,TABUFCNT TAB R41 T2177200 LM R14,R2,12(R13) RESTORE REGISTERS R41 T2177300 BR R14 RETURN TO CALLER R41 T2177400 SPACE 1 R41 T2177500 DROP R15 KILL LOCAL ADDRESSABILITY R41 T2177600 EJECT R41 T2177700 * R41 T2177800 * R41 T2177900 * JOB SELECT SUBROUTINE TO READ IOTS T2178000 * T2178100 * T2178200 HJSRDIOT DS 0H T2178300 SL R2,=A(IOTIOTTR-IOTDSECT) CHAIN TRACK ADDRESS. T2178400 SL R3,=A(IOTIOT-IOTDSECT) CHAIN STORAGE ADDRESS. T2178500 * R1 POINTS TO NEW IOT T2178600 * R2 POINTS TO PREVIOUS IOT OR TO JCT, FOR TRACK ADDRESS T2178700 * R3 POINTS TO PREVIOUS IOT OR TO SJB, FOR STORAGE ADDRESS T2178800 HJSRI10 DS 0H T2178900 L R0,IOTIOTTR-IOTDSECT(,R2) GET NEXT IOT TRACK. T2179000 LTR R0,R0 IF ZERO, IOT CHAIN T2179100 BZR R4 IS COMPLETE - RETURN. T2179200 CALL HCBGM GET STORAGE FOR ANOTHER IOT. T2179300 BNZ HJS830 BRANCH IF NO STORAGE AVAILABLE. T2179400 CALL HCBRD READ IN THE IOT. T2179500 BNZ HJSRI20 BRANCH IF READ ERROR. T2179600 ST R15,IOTIOT-IOTDSECT(,R1) ZERO IOT CHAIN POINTER. T2179700 ST R1,IOTIOT-IOTDSECT(,R3) CHAIN PREV IOT TO THIS. T2179800 LR R2,R1 POINT TRACK CHAIN REG AND T2179900 LR R3,R1 STOR CHAIN REG TO THIS IOT. T2180000 B HJSRI10 TRY FOR ANOTHER IOT. T2180100 * ERROR RETURNED FROM READ - FREE LAST IOT AND RETURN T2180200 HJSRI20 DS 0H T2180300 CALL HCBFM FREE IOT STORAGE. T2180400 B HJS840 CAUSE JOB TO TERMINATE. T2180500 DROP , DROP ALL BASES. T2180600 EJECT R41 T2180700 LTORG R41 T2180800 TITLE 'HOSTERM - SUBSYSTEM JOB TERMINATION FUNCTION' T2180900 * T2181000 * T2181100 * HOSTERM - SUBSYSTEM JOB TERMINATION FUNCTION T2181200 * T2181300 * T2181400 HOSTERM $PROLOG SSOBTERM,SSJTSIZE,LOCK=REQ T2181500 HJEBASE DS 0H T2182000 * T2182500 * T2183000 * ENTRY POINT HOSTERM --- T2183500 * TERMINATE REGULAR JOB T2184000 * TERMINATE EXECUTION BATCH MONITOR, WITH OR WITHOUT T2184500 * USER JOB T2185000 * TERMINATE STARTED TASK T2185500 * T2186000 * T2186500 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T2187000 USING SSJTBGN,RSOX SET SSOB EXT ADDRESSABILITY. T2187500 USING SSIB,RSIB SET SSIB ADDRESSABILITY. T2188000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T2188500 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T2189000 * SET INITIAL TERMINATION CONTROL FLAGS T2189500 MVI SJBFLG3,SJB3CLS+SJB3FSDB+SJB3FIOT+SJB3CKPT+SJB3FJCT T2190000 MVI SJBFLG4,0 ZERO 2D TERMINATION FLAGS. T2190500 L R7,SJBJCT LOAD JCT BASE REGISTER. T2191000 * IF EXECUTION BATCH MONITOR WITHOUT USER JOB AVOID CLOSE, CKPT T2191500 TM SJBFLG1,SJB1XBM IF NOT BATCH MONITOR ENDING, T2192000 BZ HJET10 GO CHECK STARTED TASK. T2192500 OI SJBFLG1,SJB1XBMR CAUSE XBM FLAG TO RESET LATER. T2193000 TM SJBFLG1,SJB1XBMC+SJB1XBWT IF MONITOR ENDING WITH T2193500 BZ HJET20 JOB, TREAT AS ORDINARY. T2194000 NI SJBFLG3,255-SJB3CLS-SJB3CKPT ELSE NO CLOSE, CKPT. T2194500 B HJE000 ENTER TERMINATION. T2195000 HJET10 DS 0H T2195500 * IF STARTED TASK IS TERMINATING, FREE SJB, NULLIFY JCL PDDB, T2196000 * WRITE 'ENDED' T2196500 TM SJBFLG1,SJB1SJID IF NOT STARTED TASK, T2197000 BZ HJET20 GO CHECK RE-EXECUTE FLAG. T2197500 OI SJBFLG3,SJB3TERM SHOW JOB READY TO TERMINATE. T2198000 OI SJBFLG4,SJB4MEND+SJB4FSJB CAUSE SJB TO FREE. T2198500 B HJET80 GO MOVE JMR. T2199000 HJET20 DS 0H T2199500 * IF JOB IS TO RESTART (HASP COMMAND $EJOB), PARTIALLY PURGE T2200000 * OUTPUT TRACK GROUPS, WRITE 'QUEUED FOR RE-EXECUTION' T2200500 TM SJBFLG1,SJB1EJOB RE-RUN REQUESTED... R41 T2200600 BO HJERERUN BR IF YES TO FORCE RE-QUEUE R41 T2200700 TM JCTJOBFL,JCTRSTRT IS JOB RESTARTABLE... R41 T2200800 BZ HJET30 BR IF NO (TERMINATE JOB) R41 T2200900 TM JCTJSFLG,SSJSWARM HAD JOB WARM STARTED... R41 T2201000 BZ HJET30 BR IF NO (TERMINATE JOB) R41 T2201100 TM JCTJBOPT,JCTRERUN HAS JOB RE-RUN ALREADY... R41 T2201200 BO HJET30 BR IF YES (TERMINATE JOB) R41 T2201300 SPACE 1 R41 T2201400 HJERERUN OI SJBFLG1,SJB1EJOB FORCE JOB TO RE-RUN R41 T2201500 OI JCTJBOPT,JCTRERUN INDICATE RE-RUN REQUEST R41 T2201600 SLR R0,R0 GET ZEROS IN REGISTER T2201700 STH R0,JCTJSSTP KILL RESTART STEP IN JCT T2201800 STC R0,JCTJSFLG KILL RESTART FLAGS IN JCT T2201900 OI SJBFLG3,SJB3PPOU ELSE PURGE PARTIAL OUTPUT T2203500 OI SJBFLG4,SJB4MREX AND WRITE 'QUEUED FOR RE-EXEC'. T2204500 ICM R1,7,SSJTJMR+1 POINT TO JMR-IF NO JMR, @OZ27662 T2204600 BZ HJE000 ENTER TERMINATION. @OZ27662 T2204800 MVC JCTUSEID,JCTUSEID-JCTJMR(R1) XFER USER INFO @OZ27662 T2204900 MVC JCTUCOM,JCTUCOM-JCTJMR(R1) FROM SWA JMR. @OZ27662 T2204950 B HJE000 ENTER TERMINATION. T2205000 HJET30 DS 0H T2205500 * REGULAR JOB END, OR XBM WITH USER JOB - NULLIFY JCL PDDB, T2206000 * WRITE 'ENDED' T2206500 OI SJBFLG3,SJB3TERM SHOW JOB READY TO TERMINATE. T2207000 OI SJBFLG4,SJB4MEND WRITE 'ENDED'. T2207500 B HJET80 GO MOVE JMR. T2208000 HJET80 DS 0H T2208500 * MOVE JMR BACK INTO HASP JOB CONTROL TABLE T2209000 TM SJBFLG1,SJB1XBM IF BATCH MONITOR ENDING, @OZ26957 T2209200 BO HJE000 ENTER TERMINATION. @OZ26957 T2209400 L R1,SSJTJMR POINT TO JMR TO MOVE. T2209500 LTR R7,R7 IF NO JCT, T2210000 BZ HJE000 ENTER TERMINATION. T2210500 LTR R1,R1 IF JMR DOESN'T EXIST, T2211000 BZ HJE000 ENTER TERMINATION. T2211500 MVC JCTJMR,0(R1) MOVE JMR INTO HASP JCT. T2212000 B HJE000 ENTER TERMINATION. T2212500 SPACE 3 T2213000 * T2213500 * T2214000 * ENTRY POINT HJERENQ --- T2214500 * RE-ENQUEUE JOB FOR OS RESTART T2215000 * T2215500 * T2216000 HJERENQ DS 0H T2216500 NI SJBFLG1,255-SJB1EJOB RESET POSSIBLE RESTART-JOB. T2217000 MVI SJBFLG3,SJB3CLS+SJB3FSDB+SJB3FIOT+SJB3CKPT+SJB3FJCT T2217500 MVI SJBFLG4,SJB4MREQ WRITE 'RE-ENQUEUED'. T2218000 L R7,SJBJCT POINT TO THE JOB'S JCT. T2218500 LTR R7,R7 IF JCT DOESN'T EXIST, T2219000 BZ HJE000 ENTER TERMINATION. T2219500 MVC JCTJSSTP,SSRQSTEP SAVE RESTART STEP IN JCT. T2220000 MVC JCTJSFLG,SSRQFLG1 SAVE RESTART FLAGS IN JCT. T2220500 OI JCTJBOPT,JCTRERUN INDICATE RE-RUN REQUEST R41 T2220600 TM JCTJSFLG,SSRQHOLD IS JOB TO BE HELD... T2221000 BZ SKIP60 SKIP IF NOT R4 T2221100 OI SJBFLG2,SJB2HOLD INDICATE HOLD IN SJB R4 T2221200 XI SJBFLG4,SJB4MREQ+SJB4MRQH RESET MREQ, SET MRQH. T2222000 * UPDATE SMF INFORMATION BEFORE EXITING @OZ41529 T2222100 SKIP60 L R1,PSATOLD-PSA FIND CURRENT TCB @OZ41529 T2222200 ICM R1,7,TCBTCTB-TCB(R1) GET 24-BIT TCT ADDRESS @OZ41529 T2222300 BZ HJE000 BR IF NO SMF @OZ41529 T2222400 L R1,TCTJMR-SMFTCT(,R1) GET JMR ADDRESS @OZ41529 T2222500 MVC JCTUSEID,JCTUSEID-JCTJMR(R1) XFER USER INFO @OZ41529 T2222600 MVC JCTUCOM,JCTUCOM-JCTJMR(R1) FROM SWA JMR @OZ41529 T2222700 B HJE000 ENTER TERMINATION @OZ41529 T2222800 SPACE 3 T2223000 * T2223500 * T2224000 * ENTRY POINT HJEJBSL --- T2224500 * TERMINATE SELECTED REGULAR JOB, USER JOB (XBM), T2225000 * STARTED TASK, OR CREATED-ID JOB T2225500 * RERUN SELECTED REGULAR OR USER JOB T2226000 * T2226500 * T2227000 HJEJBSL DS 0H T2227500 * RESTORE RSIB AND RSOX TO THEIR CORRECT VALUES T2228000 L R1,4(,R13) POINT TO CALLER'S SAVE AREA. T2228500 L R1,24(,R1) GET ENTRY REGISTER 1. T2229000 USING SSOBEGIN,R1 SET SSOB ADDRESSABILITY. T2229500 L RSIB,SSOBSSIB SET SSIB BASE. T2230000 L RSOX,SSOBINDV SET SSOB EXT BASE. T2230500 DROP R1 DROP REGISTER 1 AS SSOB BASE. T2231000 * SET INITIAL TERMINATION FUNCTION FLAGS T2231500 MVI SJBFLG3,SJB3CLS+SJB3CKPT CAUSE CLOSE & CKPT. T2232000 MVI SJBFLG4,0 ZERO 2D TERMINATION FLAG. T2232500 L R7,SJBJCT LOAD JCT BASE REGISTER. T2233000 * IF XBM CONTINUATION FLAG OFF, NO NEED TO PRESERVE SDB, IOTS, T2233500 * JCT T2234000 TM SJBFLG1,SJB1XBMC IF EXECUTION BATCH MON CONT, T2234500 BO HJES30 GO PROCESS IT. T2235000 OI SJBFLG3,SJB3FSDB+SJB3FIOT+SJB3FJCT CAUSE FREEING. T2235500 OI SJBFLG1,SJB1XBMR CAUSE RESET OF SJB1XBM. T2236000 * IF STARTED TASK, FREE SJB, NULLIFY JCL PDDB, WRITE 'TERMINATED' T2236500 TM SJBFLG1,SJB1SJID IF NOT STARTED TASK, T2237000 BZ HJES10 CHECK FOR RE-EXECUTION. T2237500 OI SJBFLG3,SJB3TERM SHOW JOB READY TO TERMINATE. T2238000 OI SJBFLG4,SJB4MTRM+SJB4FSJB WRITE 'TERMINATED'. T2238500 B HJE000 ENTER TERMINATION. T2239000 HJES10 DS 0H T2239500 * IF JOB IS TO RESTART ($EJOB), PURGE PARTIAL OUTPUT, T2240000 * WRITE 'QUEUED FOR RE-EXECUTION'. T2240500 TM SJBFLG1,SJB1EJOB IF NO RE-EXECUTION, T2241000 BZ HJES20 SET UP NORMAL SELECT FAILURE. T2241500 SLR R0,R0 GET ZEROS IN REGISTER T2241600 STH R0,JCTJSSTP KILL RESTART STEP IN JCT T2241700 STC R0,JCTJSFLG KILL RESTART FLAGS IN JCT T2241800 OI SJBFLG3,SJB3PPOU ELSE PURGE PARTIAL OUTPUT, T2243500 OI SJBFLG4,SJB4MREX WRITE 'QUEUED FOR RE-EXEC'. T2244500 B HJE000 ENTER TERMINATION. T2245000 * OTHERWISE NULLIFY JCL PDDB, WRITE 'TERMINATED' T2245500 HJES20 DS 0H T2246000 OI SJBFLG3,SJB3TERM SHOW JOB READY TO TERMINATE. T2246500 OI SJBFLG4,SJB4MTRM WRITE 'TERMINATED'. T2247000 B HJE000 ENTER TERMINATION. T2247500 * XBM CONTINUATION - ONLY WRITE MESSAGE T2248000 HJES30 DS 0H T2248500 MVI SJBFLG3,0 DO NOTHING. T2249000 MVI SJBFLG4,SJB4MTRM WRITE 'TERMINATED'. T2249500 TM SJBFLG1,SJB1EJOB IF THAT'S CORRECT, T2250000 BZ HJE000 ENTER TERMINATION. T2250500 MVI SJBFLG4,SJB4MREX WRITE 'QUEUED FOR RE-EXEC'. T2251000 B HJE000 ENTER TERMINATION. T2251500 SPACE 3 T2252000 * T2252500 * T2253000 * ENTRY POINT HJERTRN --- T2253500 * TERMINATE CREATED-ID JOB (E.G., SYSTEM LOG) T2254000 * T2254500 * T2255000 HJERTRN DS 0H T2255500 MVI SJBFLG3,SJB3CLS+SJB3FSDB+SJB3FIOT+SJB3CKPT+SJB3FJCT T2256000 MVI SJBFLG4,SJB4FSJB CAUSE SJB TO FREE, NO MSG. T2256500 L R7,SJBJCT LOAD JCT BASE REGISTER. T2257000 B HJE000 ENTER TERMINATION. T2257500 SPACE 3 T2258000 * T2258500 * T2259000 * ENTRY POINT HJEXBM --- T2259500 * TERMINATE USER JOB THAT RAN UNDER AN EXECUTION T2260000 * BATCH MONITOR. LEAVE ENVIRONMENT SUITABLE FOR T2260500 * RUNNING ANOTHER USER JOB. T2261000 * T2261500 * T2262000 HJEXBM DS 0H T2262500 MVI SJBFLG3,SJB3CLS+SJB3CKPT+SJB3TERM SET FLAGS. T2263000 MVI SJBFLG4,SJB4MEND SET MESSAGE FLAG. T2263500 L R7,SJBJCT POINT TO JOB'S JCT. T2264000 B HJE000 ENTER TERMINATION. T2264500 EJECT T2265000 * T2265500 * T2266000 * COMMON ENTRY POINT AND MESSAGE WRITER T2266500 * T2267000 * T2267500 HJE000 DS 0H T2268000 LTR R7,R7 IF NO JCT EXISTS, T2268500 BZ HJE100 SKIP MESSAGE WRITING. T2269000 CLI JCTTSUAF,0 WAS NOTIFY REGUESTED T2269100 BE HJE005 IF NOT SKIP NOTIFY T2269200 CLI SJBXQFN1+1,SSOBJBSL WAS ENTRY FROM JOB SELECT T2269300 BNE *+8 IF NOT BRANCH T2269400 OI JCTJTFLG,SSJTJFAL SET JCL ERROR FLAG T2269500 CLI SJBXQFN1+1,SSOBTERM WAS ENTRY FROM JOB TERM T2269600 BNE HJE005 IF NOT SKIP NOTIFY T2269700 CLC $SVRELNO,=C'02' TEST OS/VS2 RELEASE NUMBER R4 T2269800 BE HJE005 IGNORE RETURN CODE IF RELEASE 2 R4 T2269900 **************************************************************** * INSERTED BY GP **************************************************************** COPY SYZYGY1A SYZYGY1 T2269950 **************************************************************** * INSERTED BY GP **************************************************************** TM SSJTFLG1,SSJTJFAL+SSJTCFAL JOB FAILED CC T2270000 BNO HJE002 IF NOT SET FLAGS T2270100 L R1,SSJTPCOD LOAD POINTER TO CC T2270200 MVC JCTJTCC(2),0(R1) MOVE CC TO JCT T2270300 L R1,SSJTPSN1 LOAD POINTER TO STEPNAME1 T2270400 MVC JCTPSN1(8),0(R1) MOVE STEPNAME1 TO JCT T2270500 L R1,SSJTPSN2 LOAD POINTER TO STEPNAME2 T2270600 MVC JCTPSN2(8),0(R1) MOVE STEPNAME2 TO JCT T2270700 HJE002 MVC JCTJTFLG(1),SSJTFLG1 SET JCT JOB TERM FLAGS T2270800 * SELECT MESSAGE TO WRITE AND MOVE IT TO JCTWORK T2270900 HJE005 LA R1,HJEM1 SET UP 'ENDED' MESSAGE. T2271000 TM SJBFLG4,SJB4MEND IF CORRECT, T2271100 BO HJE010 WRITE MESSAGE. T2271200 LA R1,HJEM2 SET UP 'TERMINATED'. T2271500 TM SJBFLG4,SJB4MTRM IF CORRECT, T2272000 BO HJE010 WRITE MESSAGE. T2272500 LA R1,HJEM3 SET UP 'RE-ENQUEUED'. T2273000 TM SJBFLG4,SJB4MREQ IF CORRECT, T2273500 BO HJE010 WRITE MESSAGE. T2274000 LA R1,HJEM35 SET UP 'RE-ENQUEUED & HELD'. T2274500 TM SJBFLG4,SJB4MRQH IF CORRECT, T2275000 BO HJE010 WRITE MESSAGE. T2275500 LA R1,HJEM4 'QUEUED FOR RE-EXECUTION'. T2276000 TM SJBFLG4,SJB4MREX IF CORRECT, T2276500 BO HJE010 WRITE MESSAGE. T2277000 B HJE100 NO MESSAGE. T2277500 * WRITE THE SELECTED MESSAGE T2278000 HJE010 DS 0H T2278500 WTO MF=(E,(1)) WRITE TERMINATION MESSAGE. T2279000 * CONTINUE TO MORE COMMON CODE T2279500 B HJE100 BRANCH TO START TERMINATION. T2280000 SPACE 3 T2280500 * MESSAGES --- T2281000 $MID 395 HASP MESSAGE ID T2281500 HJEM1 WTO '&MID.ENDED',ROUTCDE=2,DESC=6,MF=L T2282000 SPACE 1 T2282500 $MID 396 HASP MESSAGE ID T2283000 HJEM2 WTO '&MID.TERMINATED',ROUTCDE=2,DESC=6,MF=L T2283500 SPACE 1 T2284000 $MID 397 HASP MESSAGE ID T2284500 HJEM3 WTO '&MID.RE-ENQUEUED',ROUTCDE=2,DESC=6,MF=L T2285000 SPACE 1 R4 T2285100 $MID 303 HASP MESSAGE ID R4 T2285200 HJEM35 WTO '&MID.RE-ENQUEUED AND HELD',ROUTCDE=2,DESC=6,MF=L T2285500 SPACE 1 T2286000 $MID 398 HASP MESSAGE ID T2286500 HJEM4 WTO '&MID.QUEUED FOR RE-EXECUTION',ROUTCDE=2,DESC=6, CT2287000 MF=L T2287500 EJECT T2288000 * T2288500 * T2289000 * JOB TERMINATION CONTINUES HERE T2289500 * T2290000 * T2290500 HJE100 DS 0H T2291000 * T2291500 * ZERO CSCB POINTER IN SJB T2292000 * T2292500 TM SJBFLG1,SJB1XBMC IF XBM CONTINUING... @OZ35973 T2292600 BO HJE110 SKIP THIS @OZ35973 T2292700 SLR R0,R0 ZERO OUT T2293000 ST R0,SJBCSCB CSCB POINTER. T2293500 SPACE 3 T2294000 * T2294500 * PURGE PSO IF PRESENT T2295000 * T2295500 HJE110 DS 0H @OZ35973 T2295750 L R6,SJBPSOP POINT TO PSO. T2296000 LTR R6,R6 TEST FOR PRESENT. T2296500 BZ HJENPSO SKIP PURGE IF NO PSO. T2297000 OI PSOFLG2-PSODSECT(R6),SSSOCTRL SET TO TERMINATE PSO. T2297500 STM R14,R12,SJBDSECT+12 SAVE REGISTERS T2298000 ICM R12,7,=AL3(HOSEOTB) POINT TO PSO PURGE BASE T2298500 LR R8,R13 COPY SJB POINTER T2299000 BAL R14,HETSOUT-HOSEOTB(,R12) ENTER PSO PURGER T2299500 USING *,R14 T2300000 ICM R12,7,=AL3(PSOBASE) POINT TO PSO QUEUEING ROUTINE BASE T2300500 DROP R14 T2301000 LR R13,R8 RESTORE SJB POINTER T2301500 BAL R8,PSOQUEUE-PSOBASE(,R12) ENTER PSO TERMINATOR T2302000 LM R14,R12,SJBDSECT+12 RESTORE NORMAL REGISTERS T2302500 SLR R0,R0 ZERO T2303000 ST R0,SJBFLOW FLOW INDICATORS. T2303500 HJENPSO DS 0H T2304000 LTR R7,R7 IF NO JCT, T2304500 BZ HJEA00 DON'T DO ENDING TIME. T2305000 TIME BIN GET TIME AND DATE AND T2305500 STM R0,R1,JCTXEQOF SAVE THEM IN JCT. T2306000 SPACE 3 T2307100 HJEA00 DS 0H T2307200 * T2307500 * T2308000 * CLOSE ALL SUBSYSTEM DATA SETS T2308500 * T2309000 * T2309500 TM SJBFLG3,SJB3CLS ARE WE TO CLOSE DATA SETS... T2310000 BZ HJEA90 IF NOT, SKIP THIS CODE. T2310500 * NULLIFY FAKE-OPENED ACBS T2311000 L R0,=A(HAMNULL) GET NULL ADDRESS. T2311500 ST R0,SJBLACB+ACBINRTN-IFGACB NULLIFY JOB LOG. T2312000 LTR R7,R7 IS THERE A JCT... T2312500 BZ HJEA90 IF NOT, SKIP CLOSING. T2313000 LA RSDB,SJBSDB POINT TO FIRST SDB ADDRESS. T2313500 SL RSDB,=A(SDBSDB-SDBDSECT) SET UP TO CHAIN. T2314000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T2314500 HJEA10 DS 0H T2315000 L RSDB,SDBSDB POINT TO NEXT SDB. T2315500 LTR RSDB,RSDB IF NO MORE, T2316000 BZ HJEA80 SET UP RSOX AND CONTINUE. T2316500 CALL HFCLSUB CLOSE THE DATA SET. T2317000 B HJEA10 THEN CONTINUE WITH NEXT SDB. T2317500 HJEA80 DS 0H T2318000 TM SJBFLG1,SJB1EJOB WILL JOB RE-EXECUTE..... @OZ46680 T2318100 BO HJEA90 YES, DO NOT HOLD DATA. @OZ46680 T2318200 DROP RSDB DROP SDB ADDRESSABILITY. T2318500 CALL HJEAHOLD HOLD DATA SETS IF REQUIRED. T2319000 HJEA90 DS 0H T2321500 SPACE 3 T2322000 HJEB00 DS 0H T2322500 * T2323000 * T2323500 * FREE ALL SUBSYSTEM DATASET BLOCKS T2324000 * T2324500 * T2325000 TM SJBFLG3,SJB3FSDB IF NO SDB FREE WANTED, T2325500 BZ HJEB90 SKIP THIS CODE. T2326000 HJEB10 DS 0H T2326500 L RSDB,SJBSDB POINT TO FIRST SDB. T2327000 LTR RSDB,RSDB IF NO MORE SDBS, T2327500 BZ HJEB80 SET UP RSOX AND CONTINUE. T2328000 CALL $SDBFREE ELSE FREE & DECHAIN SDB. T2328500 B HJEB10 CONTINUE FREEING SDBS. T2329000 HJEB80 DS 0H T2329500 L RSOX,4(,R13) POINT TO ORIGINAL SAVE AREA. T2330000 L RSOX,24(,RSOX) POINT TO SSOB. T2330500 L RSOX,SSOBINDV-SSOB(,RSOX) POINT TO SSOB EXTEN. T2331000 USING SSJTBGN,RSOX SET SSOB EXT ADDRESSABILITY. T2331300 HJEB90 DS 0H T2331500 SPACE 3 T2332000 HJEC00 DS 0H T2332500 * T2333000 * T2333500 * SHOW JOB READY TO TERMINATE T2334000 * T2334500 * T2335000 L RIOT,SJBIOT IF NO T2335500 LTR RIOT,RIOT REGULAR IOT(S), T2336000 BZ HJEC90 SKIP PURGE. T2336500 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T2337000 LTR R7,R7 DOES JCT EXIST... @OZ19451 T2337025 BZ HJEC86 BRANCH IF NOT @OZ19451 T2337050 TM SJBFLG1,SJB1EJOB IS JOB TO BE RERUN... @OZ19451 T2337075 BZ HJEC86 NO, DONT COUNT LINES @OZ19451 T2337100 * SET JCTLINES/JCTXOUT TO SUM OF RECORD COUNTS FOR @OZ19451 T2337125 * JCL IMAGE, SYSTEM MESSAGE, AND JOB LOG FILES @OZ19451 T2337150 XR R0,R0 ZERO ACCUMULATOR @OZ19451 T2337175 L R15,$SVPDDB1 GET OFFSET TO FIRST PDDB @OZ19451 T2337200 LA R15,IOTPDBOL(,R15) ADD JOB LOG LINES @OZ19451 T2337225 AL R0,PDBRECCT-PDBDSECT(R15,RIOT) TO ACCUMULATOR @OZ19451 T2337250 LA R15,IOTPDBOI-IOTPDBOL(,R15) ADD JCL IMAGE LNS @OZ19451 T2337275 AL R0,PDBRECCT-PDBDSECT(R15,RIOT) TO ACCUMULATOR @OZ19451 T2337300 LA R15,IOTPDBOM-IOTPDBOI(,R15) ADD SYS MSG LINES @OZ19451 T2337325 AL R0,PDBRECCT-PDBDSECT(R15,RIOT) TO ACCUMULATOR @OZ19451 T2337350 ST R0,JCTLINES SET PRINT OUTPUT AND @OZ19451 T2337375 ST R0,JCTXOUT TOTAL OUTPUT COUNTS @OZ19451 T2337400 HJEC86 DS 0H @OZ19451 T2337425 TM SJBFLG3,SJB3TERM IF JOB NOT TERMINATING, T2337500 BZ HJEC90 SKIP THIS CODE. T2338000 AL RIOT,$SVPDDB1 ELSE POINT TO JCL PDDB R4 T2338500 OI IOTPDBOJ+PDBFLAG1-PDBDSECT(RIOT),PDB1NULL R4 T2338800 HJEC90 DS 0H T2339000 SPACE 3 T2339500 HJED00 DS 0H T2340000 * T2340500 * T2341000 * PERFORM PARTIAL PURGE OF OUTPUT IOT TRACK GROUPS T2341500 * T2342000 * T2342500 L RIOT,SJBIOT IF JOB HAS T2343000 LTR RIOT,RIOT NO IOT(S), T2343500 BZ HJED90 SKIP PURGE. T2344000 OI IOTFLAG1,IOT1CKPT FLAG 1ST IOT FOR CHECKPOINT. T2344500 TM SJBFLG3,SJB3PPOU IS PARTIAL OUTPUT PURGE NEEDED T2345000 BZ HJED90 IF NOT, SKIP THIS CODE. T2345500 LTR R7,R7 IF NO JCT, T2346000 BZ HJED90 SKIP THE FUNCTION. T2346500 * NEXT, NULLIFY ALL PDDBS ALLOCATED DURING EXECUTION T2347000 LH R0,JCTPDDBO GET DD NUMBER OF 1ST OUTPUT PDDB. T2347500 SPACE 1 T2348000 HJED20 L R1,$SVPDDB1 GET OFFSET OF 1ST PDDB IN IOT R4 T2348500 USING PDBDSECT,R1 PROVIDE PDDB ADDRESSABILITY. T2349000 SPACE 1 T2349500 HJED40 CL R1,IOTPDDBP IF HAVE LOOKED AT ALL PDDBS T2350000 BNL HJED60 IN THIS IOT, BR TO TRY NEXT. T2350500 CH R0,PDBDSKEY-PDBDSECT(R1,RIOT) IS IT THE ONE... T2351000 BL HJED50 BR IF ALREADY 1ST SYSOUT R41 T2351100 LA R1,PDBLENG(,R1) BUMP IN ANY CASE. T2351500 BH HJED40 BR IF NOT LAST DD * / DATA R41 T2352000 HJED50 DS 0H R41 T2352100 ST R1,IOTPDDBP RESET OFFSET IN IOT. T2352500 XC IOTIOTTR,IOTIOTTR TRUNCATE THE IOT CHAIN. T2353000 OI IOTFLAG1,IOT1CKPT FLAG THE IOT FOR CHECKPOINT. T2353500 B HJED90 THEN CONTINUE. T2354000 SPACE 1 T2354500 HJED60 ICM RIOT,15,IOTIOT IF ANOTHER IOT, T2355000 BNZ HJED20 BR TO SCAN IT. T2355500 HJED90 DS 0H T2356000 SPACE 3 T2356500 HJEF00 DS 0H T2357000 * T2357500 * T2358000 * CHECKPOINT CONTROL BLOCKS AS REQUIRED T2358500 * T2359000 * T2359500 TM SJBFLG3,SJB3CKPT IS CHECKPOINTING CALLED FOR... T2360000 BZ HJEF90 SKIP THIS CODE IF NOT. T2360500 L RIOT,SJBIOT POINT TO THE 1ST IOT. T2361000 HJEF10 DS 0H T2361500 LTR R1,RIOT IF NO MORE IOTS, T2362000 BZ HJEF90 BR TO FREE STORAGE. T2362500 TM IOTFLAG1,IOT1CKPT IF NO CHECKPOINT REQUIRED, T2363000 BZ HJEF20 GO TO NEXT IOT. T2363500 NI IOTFLAG1,255-IOT1CKPT RESET CHECKPOINT FLAG. T2364000 L R0,IOTTRACK GET IOT'S TRACK ADDRESS. T2364500 CALL HCBWR WRITE THE IOT. T2365000 HJEF20 DS 0H T2365500 L RIOT,IOTIOT POINT TO NEXT IOT. T2366000 B HJEF10 LOOP THROUGH ALL IOTS. T2366500 HJEF90 DS 0H T2367000 SPACE 1 @OZ29966 T2367025 TM SJBFLG1,SJB1XBMC IF XBM NOT CONTINUING @OZ29966 T2367050 BZ HJEG00 DON'T NULLIFY PDDB'S @OZ29966 T2367075 ICM RIOT,15,SJBIOT PT TO 1ST IOT @OZ29966 T2367100 BZ HJEG00 SKIP IF NO IOT'S @OZ29966 T2367150 L R4,$SVPDDB1 PREPARE TO RESET XBM @OZ29966 T2367200 LA R4,IOTPDBOD-PDBLENG(RIOT,R4) SYSOUT DATASETS @OZ29966 T2367250 HJEF95 LA R4,PDBLENG(,R4) PT TO NEXT PDDB (IF ANY) @OZ29966 T2367300 L R1,IOTPDDBP IF NOT END @OZ29966 T2367350 LA R1,IOTDSECT(R1) OF PDDB'S @OZ29966 T2367400 CLR R4,R1 IN CURRENT IOT @OZ29966 T2367450 BL HJEF97 GO CHANGE NULL STATUS @OZ29966 T2367500 ICM RIOT,15,IOTIOT IF NO MORE IOT'S @OZ29966 T2367550 BZ HJEG00 GET OUT OF LOOP @OZ29966 T2367600 L R4,$SVPDDB1 ELSE @OZ29966 T2367650 ALR R4,RIOT PREPARE @OZ29966 T2367700 SL R4,=A(PDBLENG) TO SCAN @OZ29966 T2367750 B HJEF95 NEXT IOT @OZ29966 T2367800 USING PDBDSECT,R4 @OZ29966 T2367820 HJEF97 OI PDBFLAG1,PDB1NULL NULLIFY PDDB AGAINST REUSE @OZ29966 T2367850 B HJEF95 GO TEST NEXT PDDB @OZ29966 T2367900 DROP R4 @OZ29966 T2367950 HJEG00 DS 0H T2368000 * T2368500 * T2369000 * FREE STORAGE OCCUPIED BY ALL IOTS T2369500 * T2370000 * T2370500 TM SJBFLG3,SJB3FIOT ARE WE TO FREE IOTS... T2371000 BZ HJEG90 IF NOT, SKIP THIS CODE. T2371500 HJEG10 DS 0H T2372000 L RIOT,SJBIOT POINT TO THE 1ST IOT. T2372500 LTR R1,RIOT IF NONE, T2373000 BZ HJEG90 END OF THIS SEGMENT. T2373500 MVC SJBIOT,IOTIOT DECHAIN THE IOT. T2374000 CALL HCBFM FREE IT. T2374500 B HJEG10 GO DO ANOTHER IOT. T2375000 HJEG90 DS 0H T2375500 * T2376000 * T2376500 * UNCONDITIONALLY FREE THE OUTPUT CONTROL TABLES T2377000 * T2377500 * T2378000 HJEG100 DS 0H T2378500 L R1,SJBOCT POINT TO THE OCT. T2379000 LTR R1,R1 IS THERE ONE... T2379500 BZ HJEG110 IF NOT, END OF SECTION. T2380000 USING OCTDSECT,R1 SET OCT ADDRESSABILITY. T2380500 MVC SJBOCT,OCTOCT DECHAIN OCT. T2381000 CALL HCBFM FREE IT. T2381500 B HJEG100 GO LOOK FOR ANOTHER. T2382000 HJEG110 DS 0H T2382500 DROP R1 DROP OCT ADDRESSABILITY. T2383000 * T2383500 * T2384000 * SET INITIAL OUTPUT PRIORITY R41 T2384500 * T2385000 * T2385500 TM SJBFLG3,SJB3CKPT IF JCT NOT TO BE WRITTEN, T2386000 BZ HJEH00 SKIP OUTPUT PRIORITY. T2386500 LTR R7,R7 IF NO JCT EXISTS, T2387000 BZ HJEH00 SKIP. T2387500 TM SJBFLG1,SJB1EJOB IF JOB NOT TO RERUN, T2388000 BZ HJEG115 CONTINUE OUTPUT PROPRITY. T2388500 SLR R0,R0 ZERO REGISTER ZERO. T2389000 * THIS LINE DELETED BY APAR NUMBER @OZ19451 T2389500 * THIS LINE DELETED BY APAR NUMBER @OZ19451 T2390000 ST R0,JCTPUNCH PUNCH OUTPUT. T2390500 B HJEG140 GO WRITE THE JCT. T2391000 HJEG115 DS 0H T2391500 LA R0,1*16 STARTING PRIORITY = 1 R41 T2392000 TM JCTJBOPT,JCTPRICD IF NOT /*PRIORITY OR 'PRTY=' @OZ36378 T2392500 BNO HJEG130 THEN USE '1' @OZ36378 T2393000 CLI SJBPRIO,13*16 CHECK FOR 'HIGH' PRIORITY R41 T2393500 BL HJEG130 USE '1' IF NOT R41 T2394000 LA R0,15*16 RESET PRIO TO MAX R41 T2394500 SPACE 1 T2398000 HJEG130 DS 0H T2398500 STC R0,JCTIOPRI STORE INIT OUTPUT PRTY IN JCT. T2399000 STC R0,SJBPRIO PUT INITIAL OUTPUT PRTY IN SJB. T2399500 HJEG140 DS 0H T2400000 LR R1,R7 POINT R1 TO JCT. T2400500 L R0,SJBJCTRK GET ITS TRACK IN R0. T2401000 CALL HCBWR WRITE IT. T2401500 SPACE 3 T2402000 HJEH00 DS 0H T2402500 * T2403000 * T2403500 * INVOKE HASPXEQ TO TERMINATE/RE-ENQUEUE THE JOB OR T2404000 * TO CLEAN UP EXECUTION BATCH MONITOR T2404500 * T2405000 * T2405500 * ACQUIRE HASP CROSS-MEMORY-SERVICES LOCK T2406000 CALL $SVJLOK GET HASP CMS LOCK. T2406500 * ACQUIRE OS LOCAL MEMORY LOCK T2407000 HJEHLL SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,REGS=USE, CT2407500 RELATED=(HASPSSSM,(HJEHUL)) T2408000 * ACQUIRE OS CROSS-MEMORY-SERVICES LOCK T2408500 HJEHLC SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,REGS=USE, CT2409000 RELATED=(HASPSSSM,(HJEHUC)) T2409500 * SET AND RESET MISCELLANEOUS FLAGS ONLY UNDER LOCK T2410000 TM SJBFLG1,SJB1XBMR IF XBM RESET NOT REQUIRED, T2410500 BZ *+8 SKIP. T2411000 NI SJBFLG1,255-SJB1XBM-SJB1XBMR RESET XBM, XBMR. T2411500 TM SJBFLG1,SJB1XBM+SJB1XBMC IF NOT XBM CONTINUE, T2412000 BNO *+8 SKIP. T2412500 OI SJBFLG1,SJB1XBWT SHOW XBM WAITING FOR JOB. T2413000 * FREE ANY EXTRANEOUS STORAGE CELLS T2413500 LR R0,R13 SET CELL PURGE T2414000 SLR R1,R1 PARAMETERS. T2414500 ST R1,SJBLOGQ ZERO OUT LOG Q. T2415000 LR R6,R7 SAVE JCT POINTER T2415500 L R15,$SVFCELA POINT TO CELL PURGE. T2416000 BALR R14,R15 PURGE CELLS. T2416500 LR R7,R6 RESTORE JCT POINTER T2417000 * INCREMENT $SVPIDLE IF NEITHER SJB1XBM NOR SJB1SJID T2417500 TM SJBFLG1,SJB1XBM+SJB1SJID IF XBM OR SYSTEM TASK, T2418000 BNZ HJEH50 SKIP $SVPIDLE INCREMENT. T2418500 L R1,$SVPIDLE GET CURRENT PIDLE IN R1, T2419000 LA R0,1(,R1) INCREMENT PIDLE IN R0. T2419500 CS R1,R0,$SVPIDLE SWITCH THEM. T2420000 BNE *-8 IF INTERFERENCE, REPEAT. T2420500 HJEH50 DS 0H T2421000 * QUEUE SJB ON $SVJTERM OR $SVJRENQ FOR HASPXEQ T2421500 LA R1,$SVJTERM ASSUME JOB SHOULD TERMINATE. T2422000 CLI SJBXQFN1+1,SSOBRENQ IF JOB SHOULD TERMINATE, T2422500 BNE *+8 SKIP. T2423000 LA R1,$SVJRENQ ELSE SET RE-ENQUEUE QUEUE. T2423500 SLR R0,R0 ZERO THE T2424000 ST R0,SJBECB ECB. T2424500 * SET ASCB POINTER IN SJB FOR XMPOST (MIGHT BE EOM) T2425000 MVC SJBASCBP,PSAAOLD-PSA RE-SET ASCB POINTER. T2425500 CALL $SJBRQ RE-QUEUE THE SJB. T2426000 * RELEASE OS CROSS-MEMORY-SERVICES LOCK T2426500 HJEHUC SETLOCK RELEASE,TYPE=CMS,REGS=USE, CT2427000 RELATED=(HASPSSSM,(HJEHLC)) T2427500 * RELEASE OS LOCAL MEMORY LOCK T2428000 HJEHUL SETLOCK RELEASE,TYPE=LOCAL,REGS=USE, CT2428500 RELATED=(HASPSSSM,(HJEHLL)) T2429000 * RELEASE HASP CROSS-MEMORY-SERVICES LOCK T2429500 CALL $SVJUNLK RELEASE HASP CMS LOCK. T2430000 * POST HASPXEQ FOR JOB AND WAIT TILL IT POSTS US BACK T2430500 $$POST ELMT=$SVJOB POST HASP. T2431000 WAIT 1,ECB=SJBECB SHORT WAIT FOR REGULAR. T2431500 HJEH70 DS 0H T2432000 * SET & RESET MISCELLANEOUS FLAGS T2432500 NI SJBFLG1,255-SJB1EJOB RESET RE-EXECUTE FLAG. T2433000 SPACE 3 T2433500 HJEI00 DS 0H T2434000 * T2434500 * T2435000 * FREE THE HASP JOB CONTROL TABLE T2435500 * T2436000 * T2436500 TM SJBFLG3,SJB3FJCT SHOULD WE FREE THE JCT... T2437000 BZ HJEI90 IF NOT, SKIP THIS CODE. T2437500 LTR R1,R7 IS THERE A JCT TO FREE... T2438000 BZ HJEI90 BRANCH IF NOT. T2438500 SLR R7,R7 OTHERWISE T2439000 ST R7,SJBJCT ZERO SJB POINTER TO JCT T2439500 CALL HCBFM AND FREE THE JCT SPACE. T2440000 HJEI90 DS 0H T2440500 SPACE 3 T2441000 HJEJ00 DS 0H T2441500 * T2442000 * T2442500 * IF EXECUTION BATCH MONITOR, EXIT HERE T2443000 * T2443500 * T2444000 TM SJBFLG1,SJB1XBM IF NOT BATCH MONITOR, T2444500 BZ HJEJ90 SKIP THIS CODE. T2445000 TM SJBFLG1,SJB1XBWT IF NO JOB SELECTED, T2445500 BO HJEJ10 RETURN TO SVCXBM. T2446000 * RETURN TO HOSJBSL TO SET UP NEW USER JOB T2446500 SL R12,=A(HJEBASE-HJSBASE) SET UP JOB SELECT BASE. T2449000 USING HJSBASE,R12 SET JBSL ADDRESSABILITY. T2449500 B HJS200 ENTER JBSL TO START USER JOB. T2450000 USING HJEBASE,R12 RESTORE JBTM ADDRESSABILITY. T2450500 HJEJ10 DS 0H T2451000 * RETURN TO SVCXBM TO TERMINATE EXECUTION BATCH MONITOR T2451500 SL R12,=A(HJEBASE-SVCHBASE) SET SVCXBM BASE T2452000 USING SVCHBASE,R12 AND ADDRESSABILITY. T2452500 B SX100 RETURN TO SVCXBM. T2453000 USING HJEBASE,R12 RESTORE JBTM ADDRESSABILITY. T2453500 HJEJ90 DS 0H T2454000 SPACE 3 T2454500 HJEK00 DS 0H T2455000 * T2455500 * T2456000 * IF JOB SELECTED BY ID (STARTED TASK), EXIT HERE T2456500 * T2457000 * T2457500 TM SJBFLG1,SJB1SJID IF NOT STARTED TASK, T2458000 BZ HJEK90 SKIP THIS CODE. T2458500 * IF SUBSYSTEM FUNCTION IS JOB TERMINATE, EXIT NORMALLY. T2459000 SLR R15,R15 ASSUME NORMAL END. T2459500 CLI SJBXQFN1+1,SSOBJBSL IF IN JOB SELECT, @OZ37780 T2460000 BE HJEK05 SET FOR ERROR @OZ37780 T2460500 CLI SJBXQFN1+1,SSOBRQST IF NOT REQUEST JOBID @OZ37780 T2460600 BNE HJEK10 RETURN NORMALLY @OZ37780 T2460700 * IF FUNCTION IS JOB SELECT OR REQUEST JOB ID, SHOW ERROR @OZ37780 T2461000 HJEK05 DS 0H @OZ37780 T2461100 LA R15,SSJSPERR ELSE ASSUME PROG ERROR. T2461500 * BUT IF SSJSSERR IS NONZERO, SHOW SYSTEM ERROR T2462000 L R0,SSJSSERR GET CONV/INTRP CODE. T2462500 LTR R0,R0 IF ZERO, T2463000 BZ HJEK10 MUST BE PROGRAM ERROR. T2463500 LA R15,SSJSYSER ELSE SHOW SYSTEM ERROR. T2464000 * SAVE RETURN CODE IN ORIGINAL SAVE AREA, R0 SLOT T2464500 HJEK10 DS 0H T2465000 L R1,4(,R13) SAVE RETURN CODE T2465500 ST R15,20(,R1) WHILE FREEING SJB. T2466000 L R1,24(,R1) GET SSOB ADDRESS R41 T2466100 USING SSOBEGIN,R1 SET SSOB ADDRESSABILITY R41 T2466200 L RSIB,SSOBSSIB GET SSIB ADDRESS R41 T2466300 XC SSIBSUSE,SSIBSUSE CLEAR PTR TO SJB R41 T2466400 * FREE THE SUBSYSTEM JOB BLOCK T2466500 CALL $SJBFREE FREE THE SJB. T2467000 * RESTORE RETURN CODE TO R15 AND GO TO $EPILOG T2467500 L R15,20(,R13) RESTORE RETURN CODE TO R15. T2468000 $EPILOG , RETURN FROM FUNCTION. T2468500 HJEK90 DS 0H T2469000 SPACE 3 T2469500 HJEL00 DS 0H T2470000 * T2470500 * T2471000 * IF JOB WAS SET FOR OS RESTART OR TERMINATE, T2471500 * EXIT HERE T2472000 * T2472500 * T2473000 CLI SJBXQFN1+1,SSOBJBSL WAS ENTRY FROM JOB SELECT... T2473500 BNE HJEL10 BRANCH IF NOT. T2474000 SL R12,=A(HJEBASE-HJSBASE) SET JBSL BASE. T2474500 USING HJSBASE,R12 SET JBSL ADDRESSABILITY. T2475000 L R1,4(,RSJB) POINT TO CALLER'S SAVEAREA. T2475500 L R1,24(,R1) GET CALLER'S R1. T2476000 USING SSOBEGIN,R1 SET SSOB ADDRESSABILITY. T2476500 L RSIB,SSOBSSIB POINT RSIB TO SSIB. T2477000 L RSOX,SSOBINDV POINT RSOX TO EXTENSION. T2477500 DROP R1 DROP SSOB BASE. T2478000 B HJSBASE RETURN TO JOB SELECT. T2478500 USING HJEBASE,R12 SET JBTM ADDRESSABILITY. T2479000 HJEL10 DS 0H T2479500 SLR R15,R15 T2480000 $EPILOG , RETURN WITH NORMAL CODE. T2480500 DROP R7,RSOX,RIOT,RSIB DROP BASES. T2481000 TITLE 'LITERAL POOL FOR HOSREQID - HOSTERM' T2485000 LTORG T2485500 TITLE 'HASP CONTROL BLOCK (JCT, IOT, OCT) SUBROUTINES' T2486000 * T2486500 * T2487000 * GET MAIN STORAGE FOR A HASP CONTROL BLOCK T2487500 * T2488000 * T2488500 HCBGM DS 0H T2489000 USING *,R12 SET LOCAL ADDRESSABILITY. T2489500 STM R14,R12,12(R13) SAVE REGISTERS. T2490000 LR R12,R15 SET LOCAL BASE. T2490500 LH R1,$SVBFSIZ GET R4 T2490800 LA R0,IOTSTART-IOTDSECT(,R1) BUFFER R4 T2491000 $GETMAIN RC,LV=(R0),SP=230,KEY=5 STORAGE R4 T2491100 ST R15,16(,R13) STORE R15 IN SAVE AREA. T2491500 ST R1,24(,R13) STORE R1 IN SAVE AREA. T2492000 BZ HCBGM9 IF STORAGE GOT, SKIP MESSAGE. T2492500 $MID 359 WRITE OUT-OF-SP-231 MESSAGE. T2493000 WTO '&MID.HCBGM - NO STORAGE AVAILABLE IN SP 230', R4CT2493100 ROUTCDE=10,DESC=6 T2494000 HCBGM9 DS 0H T2494500 LM R14,R12,12(R13) RESTORE REGISTERS. T2495000 LTR R15,R15 SET CONDITION CODE. T2495500 BR R14 RETURN TO CALLER. T2496000 EJECT T2496500 * T2497000 * T2497500 * FREE MAIN STORAGE FOR A HASP CONTROL BLOCK T2498000 * T2498500 * T2499000 * REGISTER 1 POINTS TO SPACE TO FREE T2499500 HCBFM DS 0H T2500000 USING *,R12 SET LOCAL ADDRESSABILITY. T2500500 LTR R1,R1 IF NO STORAGE TO FREE, T2501000 BZR R14 RETURN CONDITION CODE ZERO. T2501500 STM R14,R12,12(R13) SAVE REGISTERS. T2502000 LR R12,R15 SET LOCAL BASE. T2502500 LH R3,$SVBFSIZ CLEAR AND FREE @OZ41680 T2502600 LA R0,IOTSTART-IOTDSECT(,R3) BUFFER STORAGE @OZ41680 T2502700 SR R5,R5 SET TO ZERO FOR CLEAR @OZ41680 T2502710 LA R2,IOTSTART-IOTDSECT(R1) SET CLEAR ADDRESS @OZ41680 T2502720 MVCL R2,R4 CLEAR REST OF BUFFER @OZ41680 T2502730 $FREMAIN RC,LV=(R0),SP=230,KEY=5,A=(R1),TCB=YES STORAGE R4 T2502800 BZ HCBFM9 SKIP MESSAGE IF OKAY. T2503500 $MID 371 ELSE WRITE FREEMAIN FAILED. T2504000 WTO '&MID.HCBFM - FREEMAIN FAILED FOR SP 230', R4CT2504100 ROUTCDE=10,DESC=4 T2505000 HCBFM9 DS 0H T2505500 LM R14,R12,12(R13) RESTORE REGISTERS. T2506000 SR R15,R15 ZERO R15 AND CONDITION CODE. T2506500 BR R14 RETURN TO CALLER. T2507000 DROP R12 DROP LOCAL BASE. T2507500 EJECT T2508000 * T2508500 * T2509000 * CHECKPOINT ALL HASP CONTROL BLOCKS T2509500 * POINTED TO BY AN SJB T2510000 * T2510500 * T2511000 HCBCK DS 0H T2511500 USING *,R7 SET LOCAL ADDRESSABILITY. T2512000 LR R7,R15 SET LOCAL BASE. T2512500 LR R6,R14 SAVE RETURN ADDRESS. T2513000 * CHECKPOINT REGULAR IOT(S) T2513500 LA R5,SJBIOT SET ARGUMENT. T2514000 BAL R4,HCBCKIOT CALL IOT CHAIN CHECKPOINTER. T2514500 * CHECKPOINT SPIN IOTS T2515000 LA R5,SJBSPIOT SET ARGUMENT. T2515500 BAL R4,HCBCKIOT CALL IOT CHAIN CHECKPOINTER. T2516000 * CHECKPOINT JCT T2516500 L R5,SJBJCT POINT TO THE HASP JCT. T2517000 LTR R1,R5 IF NO JCT, T2517500 BZR R6 JUST RETURN TO CALLER. T2518000 USING JCTDSECT,R5 SET JCT ADDRESSABILITY. T2518500 TM JCTFLAG1,JCT1CKPT IF JCT CHECKPOINT NOT REQD, T2519000 BZR R6 JUST RETURN TO CALLER. T2519500 NI JCTFLAG1,255-JCT1CKPT ELSE RESET CHECKPOINT FLAG. T2520000 L R0,SJBJCTRK GET JCT TRACK ADDRESS. T2520500 CALL HCBWR WRITE THE JCT. T2521000 BR R6 RETURN TO CALLER. T2521500 SPACE 3 T2522000 * T2522500 * IOT CHECKPOINT SUBROUTINE T2523000 * T2523500 HCBCKIOT DS 0H T2524000 SL R5,=A(IOTIOT-IOTDSECT) ADJUST ARGUMENT. T2524500 USING IOTDSECT,R5 SET IOT ADDRESSABILITY. T2525000 HCBCKI1 DS 0H T2525500 L R5,IOTIOT POINT TO NEXT IOT. T2526000 LTR R1,R5 IF END OF CHAIN, T2526500 BZR R4 RETURN TO CALLER. T2527000 TM IOTFLAG1,IOT1CKPT IF IOT CHECKPOINT NOT REQ'D, T2527500 BZ HCBCKI1 GO ON TO NEXT IOT. T2528000 NI IOTFLAG1,255-IOT1CKPT ELSE RESET CHECKPOINT FLAG. T2528500 L R0,IOTTRACK GET IOT TRACK ADDRESS. T2529000 CALL HCBWR WRITE OUT THE IOT. T2529500 B HCBCKI1 THEN GO ON TO NEXT IOT. T2530000 DROP R5 DROP IOT BASE. T2530500 DROP R7 DROP LOCAL BASE. T2531000 EJECT T2531500 * T2532000 * T2532500 * READ/WRITE A HASP CONTROL BLOCK T2533000 * T2533500 * T2534000 HCBRD DS 0H READ A CONTROL BLOCK --- T2534500 USING *,R12 SET LOCAL ADDRESSABILITY. T2535000 STM R14,R12,12(R13) SAVE REGISTERS. T2535500 LR R12,R15 SET LOCAL BASE. T2536000 ICM R1,8,=X'06' ADD READ COMMAND TO DATA ADR. T2536500 LA R12,HCBIO SET COMMON BASE T2537000 BR R12 AND BRANCH TO COMMON. T2537500 SPACE 3 T2538000 HCBWR DS 0H WRITE A CONTROL BLOCK --- T2538500 USING *,R12 SET LOCAL ADDRESSABILITY. T2539000 STM R14,R12,12(R13) SAVE REGISTERS. T2539500 LR R12,R15 SET LOCAL BASE. T2540000 ICM R1,8,=X'05' ADD WRITE COMMAND TO DATA ADR. T2540500 LA R12,HCBIO SET COMMON BASE. T2541000 SPACE 3 T2541500 HCBIO DS 0H T2542000 USING *,R12 COMMON ROUTINE FOR READ/WRITE-- T2542500 TM SJBFLG1,SJB1XBWT IF XBM HAS NO JOB, T2542600 BO HCBIO900 PROHIBIT ALL I/O HERE. T2542700 CLM R1,7,=F'0' IF ZERO BUFFER POINTER, @OZ19486 T2543000 BZ HCBIO800 EXIT IMMEDIATELY. T2543500 AL R1,=A(BUFSTART-BUFDSECT) COMPUTE READ/WRITE ADR. T2544000 ST R1,SJBCCW4 SET COMMAND, DATA ADDRESS. T2544500 * CONVERT MTTR TO FULL DISK ADDRESS, MBBCCHHR T2545000 CLM R0,8,$SVNUMDA IF INCORRECT EXTENT, R4 T2545500 BNL HCBIO100 BRANCH TO ERROR MESSAGE R4 T2546000 LR R3,R0 COPY MTTR TO R3. T2546500 LA R0,0(,R3) MAKE R0 0TTR. T2547000 XR R3,R0 MAKE R3 M000. T2547500 ST R3,SJBIFDAD SET EXTENT, ZEROES IN IOB. T2548000 STC R0,SJBIFDAD+7 SET RECORD NUMBER IN IOB. T2548500 SRL R3,24 FROM EXTENT NUMBER, T2549000 MH R3,=AL2(TEDSIZ) CALCULATE ADDRESS OF T2549500 L R4,$SVTED TRACK EXTENT R4 T2550000 ALR R4,R3 DATA. R4 T2550300 USING TEDDSECT,R4 SET TED ADDRESSABILITY. T2550500 LR R2,R0 COPY 0TTR TO R2. T2551500 SRDL R2,40 SET TT IN R2, R3 FOR DIVIDE. T2552000 L R0,TNTC GET NUMBER OF TRACKS/CYL. T2552500 LTR R0,R0 IF ZERO, SPOOL VOLUME ABSENT - T2553000 BZ HCBIO100 WRITE ERROR MESSAGE. T2553500 DR R2,R0 ELSE COMPUTE CYL & HEAD. T2554000 $ALGN STH,R3,SJBIFDAD+3 SET CYLINDER IN IOB. T2554500 $ALGN STH,R2,SJBIFDAD+5 SET HEAD IN IOB. T2555000 * SET ROTATIONAL POSITION SENSING T2555500 MVI SJBCCW1,X'03' ASSUME NO RPS. T2556000 L R2,TRPS POINT TO EXTENT'S RPS TABLE. T2556500 LTR R2,R2 IF ZERO POINTER, T2557000 BZ HCBIO10 DEVICE HAS NO RPS. T2557500 SLR R3,R3 ELSE ZERO R3 FOR IC. T2558000 IC R3,SJBIFDAD+7 GET RECORD NUMBER FRON IOB. T2558500 IC R3,0(R3,R2) GET CORRESPONDING SECTOR NUMB. T2559000 STC R3,SJBCCW1+5 SET SET-SECTOR DATA T2559500 MVI SJBCCW1,X'23' AND SET-SECTOR COMMAND. T2560000 * EXECUTE CHANNEL PROGRAM T2560500 HCBIO10 EXCP SJBIOB START THE CHANNEL PROGRAM. T2561000 * ADD ONE TO INPUT/OUTPUT SERVICE MEASURE T2561500 L R1,PSAAOLD-PSA POINT TO CURRENT ASCB. T2562000 USING ASCB,R1 SET ASCB ADDRESSABILITY. T2562500 L R2,ASCBIOSM GET CURRENT IOSM - BYTES 0,1. T2563000 HCBIO15 DS 0H T2563500 LR R3,R2 MOVE IT TO UPDATE REGISTER. T2564000 AL R3,=FS16'1' ADD 1 TO SERVICE MEASURE. T2564500 CS R2,R3,ASCBIOSM STORE NEW MEASURE. T2565000 BNE HCBIO15 REPEAT IF INTERFERENCE. T2565500 DROP R1 DROP ASCB ADDRESSABILITY. T2566000 * AWAIT COMPLETION T2566500 WAIT 1,ECB=SJBECB WAIT TILL IT ENDS. T2567000 * VERIFY THE I/O OPERATION T2567500 TM SJBECB,X'20' IF NOT-PERM-ERROR FLAG IS OFF, T2568000 BZ HCBIO120 GO WRITE ERROR MESSAGE. T2568500 * VALIDITY-CHECK THE CONTROL BLOCK IF READ T2569000 CLI SJBCCW4,6 IF NOT A CONTROL BLOCK READ, T2569500 BNE HCBIO900 PERFORM NO VALIDITY CHECK. T2570000 L R5,24(,R13) POINT AGAIN TO THE BUFFER. T2570500 USING JCTDSECT,R5 SET JCT ADDRESSABILITY. T2571000 CLC =CL4'JCT',JCTID IF CONTROL BLOCK IS JCT, T2571500 BE HCBIO20 GO CHECK IT. T2572000 CLC =CL4'IOT',JCTID IF CONTROL BLOCK IS IOT, T2572500 BE HCBIO30 GO CHECK IT. T2573000 CLC =CL4'OCT',JCTID IF CONTROL BLOCK IS OCT, T2573500 BE HCBIO40 GO CHECK IT. T2574000 B HCBIO110 ELSE UNKNOWN CONTROL BLOCK. T2574500 * JCT VALIDITY CHECK T2575000 HCBIO20 CLC SJBJQOFF+1(3),JCTJQE+1 IF JQE OFFSET IN JCT @OZ45359 T2575500 BNE HCBIO110 IS INCORRECT, ERROR. T2576000 MVC SJBJKEY,JCTJBKEY ELSE SET JOB KEY IN SJB T2576500 B HCBIO900 AND RETURN. T2577000 * IOT VALIDITY CHECK T2577500 USING IOTDSECT,R5 SET IOT ADDRESSABILITY. T2578000 HCBIO30 CLC SJBJKEY,IOTJBKEY IF JOB KEY IN IOT IS WRONG, T2578500 BNE HCBIO110 IOT IS INVALID. T2579000 B HCBIO900 ELSE RETURN. T2579500 * OCT VALIDITY CHECK T2580000 USING OCTDSECT,R5 SET OCT ADDRESSABILITY. T2580500 HCBIO40 CLC SJBJKEY,OCTJBKEY IF JOB KEY IN OCT IS WRONG, T2581000 BNE HCBIO110 OCT IS INVALID. T2581500 B HCBIO900 ELSE RETURN. T2582000 SPACE 3 T2582500 * T2583000 * WRITE ERROR MESSAGE - INVALID TRACK ADDRESS T2583500 * T2584000 HCBIO100 DS 0H T2584500 $MID 363 SET HASP MESSAGE ID. T2585000 WTO '&MID.HCBIO - INVALID TRACK ADDRESS',ROUTCDE=10, CT2585500 DESC=6 T2586000 B HCBIO800 T2586500 SPACE 3 T2587000 * T2587500 * ERROR MESSAGE - INVALID CONTROL BLOCK T2588000 * T2588500 $MID 364 SET HASP MESSAGE ID. T2589000 HCBIOVMS WTO '&MID.HCBIO - INVALID CONTROL BLOCK - ***', CT2589500 ROUTCDE=10,DESC=6,MF=L T2590000 HCBIOM1 EQU HCBIOVMS,*-HCBIOVMS T2590500 HCBIOM2 EQU 4+9+32,3 CONTROL BLOCK ID R4 T2591000 * T2591500 * WRITE INVALID CONTROL BLOCK MESSAGE T2592000 * T2592500 HCBIO110 DS 0H T2593000 GETMAIN R,LV=L'HCBIOM1 GET STORAGE FOR MESSAGE. T2593500 MVC 0(L'HCBIOM1,R1),HCBIOM1 MOVE MESSAGE. T2594000 MVC HCBIOM2(,R1),JCTID-JCTDSECT(R5) ADD CTL BLK ID @OZ57072 T2594500 LR R2,R1 SAVE STORAGE ADDRESS. T2595000 WTO MF=(E,(1)) WRITE MESSAGE. T2595500 FREEMAIN R,LV=L'HCBIOM1,A=(R2) FREE STORAGE. T2596000 B HCBIO800 RETURN ERROR CODE. T2596500 SPACE 3 T2597000 * T2597500 * I/O ERROR READING/WRITING CONTROL BLOCK T2598000 * T2598500 $MID 370 SET HASP MESSAGE ID. T2599000 HCBIOERR WTO '&MID.HCBIO - I/O ERROR ****ING CONTROL BLOCK - ***',MF=CT2599500 L,ROUTCDE=10,DESC=6 T2600000 HCBIOM3 EQU HCBIOERR,*-HCBIOERR MESSAGE LENGTH T2600500 HCBIOM4 EQU 4+9+18,4 READ/WRIT OFFSET, LENGTH R4 T2601000 HCBIOM5 EQU 4+9+42,3 CB TYPE OFFSET, LENGTH R4 T2601500 * T2602000 * WRITE I/O ERROR MESSAGE T2602500 * T2603000 HCBIO120 DS 0H T2603500 GETMAIN R,LV=L'HCBIOM3 GET STORAGE FOR MESSAGE. T2604000 MVC 0(L'HCBIOM3,R1),HCBIOM3 MOVE MESSAGE. T2604500 MVC HCBIOM4(,R1),=C'READ' ASSUME 'READ'ING. T2605000 CLI SJBCCW4,6 IF READ, T2605500 BE *+10 SKIP. T2606000 MVC HCBIOM4(,R1),=C'WRIT' ELSE SET 'WRIT'ING. T2606500 L R5,SJBCCW4 GET POINTER TO ID. T2607000 MVC HCBIOM5(,R1),0(R5) MOVE CB ID TO MESSAGE. T2607500 LR R2,R1 SAVE STORAGE ADDRESS. T2608000 WTO MF=(E,(1)) WRITE MESSAGE. T2608500 FREEMAIN R,LV=L'HCBIOM3,A=(R2) FREE STORAGE. T2609000 B HCBIO800 RETURN ERROR CODE. T2609500 SPACE 3 T2610000 * T2610500 * ERROR RETURN T2611000 * T2611500 HCBIO800 DS 0H T2612000 LA R15,4 SET R15 TO 4 T2612500 B HCBIO950 AND RETURN. T2613000 SPACE 3 T2613500 * T2614000 * NORMAL RETURN T2614500 * T2615000 HCBIO900 DS 0H T2615500 SLR R15,R15 ZERO REGISTER 15.9 T2616000 HCBIO950 DS 0H T2616500 ST R15,16(,R13) SAVE RETURN CODE IN SAVE AREA. T2617000 LM R14,R12,12(R13) RESTORE REGISTERS. T2617500 LTR R15,R15 SET CONDITION CODE. T2618000 BR R14 RETURN TO CALLER. T2618500 DROP , DROP ALL BASES. T2619000 TITLE 'HASP JOB RE-ENQUEUE SUBSYSTEM FUNCTION' T2619500 * T2620000 * T2620500 * HASP JOB RE-ENQUEUE SUBSYSTEM FUNCTION T2621000 * T2621500 * T2622000 HOSRENQ $PROLOG SSOBRENQ,SSRQSIZE,LOCK=REQ T2622500 SL R12,=A(*-HJEBASE) JOB RE-ENQUEUE IS HANDLED T2623000 USING HJEBASE,R12 SET JBTM ADDRESSABILITY. T2623500 B HJERENQ RE-ENQUEUE THE JOB. T2624000 TITLE 'HOSEOT -- END-OF-TASK RECOVERY ROUTINE' T2624500 HOSEOT $PROLOG SSOBEOT,SSETSIZE,LOCK=REQ T2625000 HOSEOTB DS 0H END-OF-TASK BASE T2625500 * T2626000 * T2626500 * ATTEMPT TO SET FLAG SJBTFFGP TO CAUSE $EPILOG T2627000 * TO FREE A POSSIBLE PSO CONTROL BLOCK T2627500 * T2628000 * T2628500 USING SSETBGN,RSOX SET SSOX ADDRESSABILITY. T2629000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T2629500 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T2630000 HET100 DS 0H T2630500 L R15,SJBPSOP IF NO PSO T2631000 LTR R15,R15 CONTROL BLOCK EXISTS, T2631500 BZ HET200 SKIP. T2632000 USING PSODSECT,R15 SET PSO ADDRESSABILITY. T2632500 CLC PSOTCB,SSETCBA IF PSO FOR DIFFERENT TASK, T2633000 BNE HET200 SKIP. T2633500 OI SJBTFFG,SJBTFFGP ELSE SET FLAG FOR $EPILOG. T2634000 DROP R15 DROP PSO BASE. T2634500 * T2635000 * T2635500 * CALL SUBROUTINE $SVFCELA TO FREE CELLS ASSOCIATED T2636000 * WITH THIS SJB AND TCB T2636500 * T2637000 * T2637500 HET200 DS 0H T2638000 LR R0,RSJB SET ARGUMENTS - T2638500 L R1,SSETCBA R0=SJB, R1=TCB. T2639000 L R15,$SVFCELA FREE ALL T2639500 BALR R14,R15 ASSOCIATED CELLS. T2640000 * T2640100 * T2640200 * COMPLETE PURGED I/O REQUESTS FOR THIS TASK T2640300 * T2640400 * T2640500 HET300 DS 0H T2640600 * STOP ALL OTHER TASKS FROM EXECUTING T2640700 ICM R2,7,SJBTCBP+1 POINT TO INIT OR STC TCB @OZ57048 T2640730 BZ HET900 BR IF ZERO, MUST BE SYSLOG @OZ57048 T2640740 ICM R2,7,TCBLTC+1-TCBDSECT(R2) GET FIRST DAUGHTER @OZ57048 T2640750 BZ HET900 BR IF NONE @OZ57048 T2640760 STATUS SET,ND,(2),(4) SET TCBHNDSP @OZ53355 T2640800 SLR R0,R0 CLEAR REGS @OZ38510 T2640803 LR R1,R0 FOR WORK @OZ38510 T2640806 LM R14,R15,$SVTGASC GET TGB WAITING ASCB,ECB @OZ38510 T2640809 CLM R14,7,PSAAOLD-PSA+1 ADDR SP WAITING TGKGRP... @OZ38510 T2640812 BNE HET316 NO,CONTINUE @OZ38510 T2640815 ICM R0,7,$SVTGECB+1 GET WAITING RB ADDR @OZ38510 T2640818 ICM R1,7,PSATOLD-PSA+1 GET OUR TCB @OZ38510 T2640821 USING TCB,R1 @OZ38510 T2640824 ICM R1,7,TCBRBP+1 GET FIRST RB @OZ38510 T2640827 HET304 DS 0H @OZ38510 T2640830 CR R0,R1 IS THIS THE RB... @OZ38510 T2640833 BE HET308 YES, GO POST ECB @OZ38510 T2640836 USING RBBASIC,R1 @OZ38510 T2640839 ICM R1,7,RBLINKB ELSE GET NEXT RB @OZ38510 T2640842 CLM R1,7,PSATOLD-PSA+1 WAS THIS THE LAST RB... @OZ38510 T2640845 BE HET316 YES, CONTINUE @OZ38510 T2640848 B HET304 NO, CHECK NEXT RB @OZ38510 T2640851 HET308 DS 0H @OZ38510 T2640854 LR R0,R14 GET ASCB POINTER @OZ38510 T2640857 HET311 LR R1,R15 GET ECB TO CHANGE @OZ38510 T2640860 N R1,=XL4'7FFFFFFF' RESET WAIT BIT IN REG @OZ38510 T2640863 HET312 CDS R14,R0,$SVTGASC RESET WAIT BIT IN ECB @OZ38510 T2640866 BZ HET316 SWAP COMPLETE, CONTINUE @OZ38510 T2640869 CLM R14,7,PSAAOLD-PSA+1 DID ASCB CHANGE... @OZ38510 T2640872 BE HET311 NO, ECB WAS POSTED, REPEAT @OZ38510 T2640875 HET316 DS 0H @OZ38510 T2640878 * RUN THE CHAIN OF SUBSYSTEM DATASET BLOCKS T2640900 L R8,SJBSDB POINT TO THE FIRST SDB. T2641000 HET320 DS 0H T2641100 LTR R8,R8 IF NO MORE SDBS, T2641200 BZ HET420 END OF SECTION. T2641300 USING SDBDSECT,R8 SET SDB ADDRESSABILITY. T2641400 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641408 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641416 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641424 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641432 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641440 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641448 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641456 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641464 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641472 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641480 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641488 * THIS LINE DELETED BY APAR NUMBER @OZ53355 T2641496 * DETERMINE TEST TO BE MADE ON THIS SDB T2641500 TM SDBFLG2,SDB2IOA IF IOA FLAG OFF, T2641600 BZ HET340 BRANCH. T2641700 * SDB2IOA ON --- IF PURGED WITH HIO, RESTART T2641800 CLI SDBICMP,X'48' IF NOT PURGE/HALT-I/O, T2641900 BNE HET380 DO NEXT SDB. T2642000 B HET360 ELSE GO COMPLETE I/O. T2642100 * SDB2IOA OFF -- IF OUTPUT AND PURGE-QUIESCE, RESTART T2642200 HET340 DS 0H T2642300 CLI SDBCHEND,SDBCEPUT IF CE APDG NOT HCEPUT, T2642400 BNE HET380 DO NEXT SDB. T2642500 L R0,SDBPBF ELSE IF SDBPBF T2642600 LTR R0,R0 IS ZERO, T2642700 BZ HET380 GO DO NEXT SDB. T2642800 * SAVE CURRENT CONTENTS OF ECB T2642900 HET360 DS 0H T2643000 L R2,SDBECB SAVE CURRENT ECB. T2643100 MVI SDBECB,0 ZERO THE ECB. T2643200 * ISSUE EXCP TO RESUME CHANNEL OPERATIONS T2643300 EXCP SDBIOB START CHANNEL PROGRAM. T2643400 * WAIT FOR COMPLETION OF ALL I/O T2643500 WAIT 1,ECB=SDBECB WAIT FOR COMPLETION. T2643600 * IF SAVED ECB WAS WAITING, RESTORE AND POST IT T2643700 LTR R2,R2 IF SAVED ECB'S WAIT BIT T2643800 BNM HET400 IS OFF, BRANCH. T2643900 ST R2,SDBECB RESTORE SAVED ECB. T2644000 IC R0,SDBICMP GET POST CODE. T2644100 SLL R0,24 LEFT-JUSTIFY. T2644200 POST SDBECB,(0) POST THE SAVED ECB. T2644300 B HET400 GO LOOK AT NEXT SDB. T2644400 * DO A FINAL CHECK ON THIS SDB T2644500 HET380 DS 0H T2644600 * THIS LINE DELETED BY APAR NUMBER @OZ29959 T2644700 * THIS LINE DELETED BY APAR NUMBER @OZ29959 T2644800 TM SDBFLG2,SDB2IOA IF I/O INACTIVE, T2644900 BZ HET400 DO NEXT SDB. T2645000 TM SDBECB,X'C0' IF WAITING OR POSTED, T2645100 BNZ HET400 DO NEXT SDB. T2645200 WAIT 1,ECB=SDBECB WAIT FOR I/O COMPLETION. T2645300 * CONTINUE WITH NEXT SDB T2645400 SPACE 1 R4 T2645500 *********************************************************************** T2645600 * * T2645700 * IF SDB WAS GETMAINED UNDER TASK BEING TERMINATED, IT MUST * T2645800 * NOW BE DE-CHAINED, SINCE ITS SUBPOOL WILL SOON BE FREED. * T2645900 * * T2646000 *********************************************************************** T2646100 SPACE 1 R4 T2646200 HET400 CLC SSETCBA,SDBTCBM TEST SDB TCB R4 T2646300 BNE HET415 BR IF NOT CURRENT TCB R4 T2646400 LA R1,SJBSDB PREPARE TO LOCATE R4 T2646500 SL R1,=A(SDBSDB-SDBDSECT) PRECEEDING SDB R4 T2646600 SPACE 1 R4 T2646700 HET405 C R8,SDBSDB-SDBDSECT(,R1) IS NEXT SDB CURRENT SDB R4 T2646800 BE HET410 BR IF YES R4 T2646900 L R1,SDBSDB-SDBDSECT(,R1) POINT TO NEXT SDB R4 T2647000 B HET405 BR TO TEST IT R4 T2647100 SPACE 1 R4 T2647200 HET410 MVC SDBSDB-SDBDSECT(,R1),SDBSDB DECHAIN CURRENT SDB R4 T2647300 SPACE 1 R4 T2647400 HET415 L R8,SDBSDB POINT TO NEXT SDB R4 T2647500 B HET320 AND PROCESS IT. T2647600 * END OF SECTION T2647700 HET420 DS 0H T2647800 L R2,SJBTCBP POINT TO INIT OR STC TCB @OZ53355 T2647830 L R2,TCBLTC-TCBDSECT(R2) POINT TO JSTCB @OZ57048 T2647860 STATUS RESET,ND,(2),(4) SET TCBHNDSP @OZ53355 T2647900 DROP R8 DROP SDB BASE. T2648000 * T2648100 * T2648200 * RETURN FROM END-OF-TASK T2648300 * T2648400 * T2648500 HET900 DS 0H T2648600 SLR R15,R15 SHOW NORMAL RETURN. T2648700 $EPILOG , RETURN. T2648800 EJECT T2648900 * T2649000 * T2649100 * TABLE OF HFRR ROUTINE OFFSETS, IN ORDER T2649200 * OF SUBSYSTEM FUNCTION ID. FIRST ENTRY IS ZERO. T2649300 * T2649400 HETTAB DS 0H T2649500 DC AL2(HETEND-HOSEOTB) ..0 NULL FUNCTION PURGER T2649600 DC AL2(HETSOUT-HOSEOTB) .1 PROCESS SYSOUT PURGER T2649700 DC AL2(HETCANC-HOSEOTB) .2 TSO CANCEL PURGER T2649800 DC AL2(HETSTAT-HOSEOTB) .3 TSO STATUS PURGER T2649900 DC 28AL2(HETEND-HOSEOTB) T2650000 * T2650500 EJECT T2651000 DROP RSJB DROP NORMAL SJB BASE. T2651500 USING SJBDSECT,R8 SET R8 AS SJB BASE. T2652000 *********************************************************************** T2652500 * * T2653000 * END OF TASK WHILE SJB LOCKED FOR PROCESS SYSOUT FUNCTION * T2653500 * * T2654000 *********************************************************************** T2654500 HETSOUT DS 0H T2655000 OI SJBTFFG,SJBTFFGP SET PURGE REQUESTED FOR EPILOG T2655500 B HETSTATA SKIP FIRST INSTRUCTION OF C/S T2656000 *********************************************************************** T2656500 * * T2657000 * END OF TASK WHILE SJB LOCKED FOR CANCEL/STATUS FUNCTION * T2657500 * * T2658000 *********************************************************************** T2658500 HETCANC DS 0H T2659000 HETSTAT DS 0H T2659500 OI SJBTFFG,SJBTFFGC SET CANCEL/STATUS PURGING FLAG T2660000 HETSTATA DS 0H T2660500 TM SJBTFFG,SJBTFFGM IS ECB MEANINGFULL T2661000 BZR R14 EXIT IF NOTHING TO DO T2661500 LR R3,R11 SAVE SSVT POINTER T2662000 LR R4,R12 SAVE BASE T2662500 LR R5,R13 AND T2663000 LR R6,R14 SOME T2663500 L R15,=A(TSETLOCK) POINT TO SET LOCK T2664000 BALR R2,R15 SET LOCK T2664500 LR R11,R3 RESTORE SSVT POINTER T2665000 LR R12,R4 PUT BASE BACK T2665500 SLR R3,R3 ZERO REGISTER T2666000 L R4,SJBECB PICK UP ECB T2666500 HETCSCS CLM R4,8,=X'40' HAS ECB BEEN POSTED T2667000 BE HETCSP X'40' - POSTED - HASP FINISHED T2667500 CS R4,R3,SJBECB TAKE OVER ECB T2668000 BNZ HETCSCS LOOP IF NOT ALTERED T2668500 LA R4,$SVTSCS POINT TO CANCEL/STATUS QUEUE T2669000 TM SJBTFFG,SJBTFFGC IS THIS CANCEL/STATUS T2669500 BO *+8 SKIP NSI IF YES T2670000 LA R4,$SVPSOQ POINT TO PSO QUEUE T2670500 LR R13,R8 USE STANDARD SJB POINTER T2671000 L R15,=A(TSUABQS) POINT TO QUEUE SCANNER T2671500 BALR R14,R15 SCAN QUEUE T2672000 BZ HETCSCKW IF NOT ON TEST FOR EVER ON T2672500 * SJB FOUND ON CANCEL/STATUS QUEUE T2673000 ICM R1,15,$SVHASP PICK UP HASP STATUS T2673500 BZ HETCSULW IF STILL UP UNLOCK AND WAIT T2674000 L R15,=A(TSHABDQ) POINT TO DEQUEUE ROUTINE T2674500 BALR R14,R15 ENTER IT, R4=QUEUE HEAD ADDRESS T2675000 HETCSP LR R3,R11 SAVE SSVT POINTER T2675500 LR R4,R12 SAVE BASE T2676000 L R15,=A(TSFRELOK) POINT TO FREE LOCK T2676500 BALR R2,R15 ENTER IT T2677000 LR R11,R3 RESTORE SSVT POINTER T2677500 LR R12,R4 RESTORE BASE T2678000 HETCSXIT LR R13,R5 RESTORE USER SAVE POINTER T2678500 LR R14,R6 RESTORE RETURN T2679000 BR R14 RETURN T2679500 HETCSCKW LR R4,R12 SAVE BASE T2680000 LR R3,R11 SAVE SSVT POINTER T2680500 L R15,=A(TSFRELOK) POINT TO FREE LOCK ROUTINE T2681000 BALR R2,R15 ENTER IT T2681500 LR R11,R3 RESTORE SSVT POINTER T2682000 LR R12,R4 RESTORE BASE T2682500 CLI SJBTFLOW,X'0' WAS IT EVER ON THE QUEUE T2683000 BZ HETCSXIT EXIT IF NO T2683500 HETCSWAT LA R1,$SVJOB POINT TO XEQ POST ELEMENT T2684000 TM SJBTFFG,SJBTFFGC IS THIS CANCEL/STATUS T2684500 BO *+8 SKIP PSO SETTING IF YES T2685000 LA R1,$SVPSO POINT TO PSO POST ELEMENT T2685500 $$POST ELMT=(R1) POST PROBABLE WAITING PROCESSOR T2686000 WAIT ECB=SJBECB WAIT FOR POST T2686500 B HETCSXIT EXIT T2687000 HETCSULW LR R4,R12 SAVE BASE T2687500 LR R3,R11 SAVE SSVT POINTER T2688000 L R15,=A(TSFRELOK) POINT TO FREE LOCK ROUTINE T2688500 BALR R2,R15 ENTER IT T2689000 LR R11,R3 RESTORE SSVT POINTER T2689500 LR R12,R4 RESTORE BASE T2690000 B HETCSWAT WAIT T2690500 HETEND DS 0H T2691000 BR R14 NULL HFRR. T2691500 DROP , DROP ALL BASES. T2692000 TITLE 'HOSEOM -- SUBSYSTEM END-OF-MEMORY FUNCTION' T2692500 * T2693000 * T2693500 * HOSEOM - END-OF-MEMORY SUBSYSTEM INTERFACE T2694000 * T2694500 * T2695000 HOSEOM $PROLOG SSOBEOM,SSENSIZE,LOCK=NO T2695500 HOSEOMB DS 0H T2696000 USING SSENBGN,RSOX SET SSEN ADDRESSABILITY. T2696500 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T2697000 * T2697500 * T2698000 * IF JES2 MEMORY, SET INDICATORS T2698500 * T2699000 * T2699500 HEN010 DS 0H T2700000 CLC SSENASCB,$SVPOSTE+4 TEST FOR JES2 MEMORY R4 T2700500 BNE HEN020 BR IF NO R4 T2701000 TM $SVSTUS,$SVSTUST DID JES2 TERMINATE SELF R4 T2701500 BO HEN015 BR IF YES @OZ35278 T2702000 OI $SVSTUS,$SVSTUST SHOW JES2 TERMINATION COMPLETE. T2702500 MVC $SVHASP,=F'-1' SHOW JES2 ABENDED. T2703000 PRINT OFF - SECTION DELETED @OZ35278 T2703100 * THIS CARD DELETED BY APAR @OZ35278 T2703200 * THIS CARD DELETED BY APAR @OZ35278 T2703300 * THIS CARD DELETED BY APAR @OZ35278 T2703400 * THIS CARD DELETED BY APAR @OZ35278 T2703500 * THIS CARD DELETED BY APAR @OZ35278 T2703600 * THIS CARD DELETED BY APAR @OZ35278 T2703700 * THIS CARD DELETED BY APAR @OZ35278 T2703800 * THIS CARD DELETED BY APAR @OZ35278 T2703900 * THIS CARD DELETED BY APAR @OZ35278 T2704000 * THIS CARD DELETED BY APAR @OZ35278 T2704100 * THIS CARD DELETED BY APAR @OZ35278 T2704200 * THIS CARD DELETED BY APAR @OZ35278 T2704300 * THIS CARD DELETED BY APAR @OZ35278 T2704400 * THIS CARD DELETED BY APAR @OZ35278 T2704500 * THIS CARD DELETED BY APAR @OZ35278 T2704600 * THIS CARD DELETED BY APAR @OZ35278 T2704700 * THIS CARD DELETED BY APAR @OZ35278 T2704800 * THIS CARD DELETED BY APAR @OZ35278 T2704900 * THIS CARD DELETED BY APAR @OZ35278 T2705000 * THIS CARD DELETED BY APAR @OZ35278 T2705100 * THIS CARD DELETED BY APAR @OZ35278 T2705200 * THIS CARD DELETED BY APAR @OZ35278 T2705300 * THIS CARD DELETED BY APAR @OZ35278 T2705400 * THIS CARD DELETED BY APAR @OZ35278 T2705500 * THIS CARD DELETED BY APAR @OZ35278 T2705600 PRINT ON -- SECTION DELETED @OZ35278 T2705700 SPACE 1 @OZ35278 T2705800 HEN015 DS 0H @OZ35278 T2705900 L R1,$SVHECBA ADDR OF ECB AND $$POST WORK FLAG R4 T2706000 MVI $SVPOSTW(R1),X'FF' INHIBIT JES2 XMPOSTING R4 T2706100 HEN020 DS 0H T2706200 * T2706300 * T2706400 * IF ENDING MEMORY HOLDS JCQ LOCK, RELEASE IT. T2706500 * T2706600 * T2706700 HEN100 DS 0H T2707000 L R1,$SVJLOCK GET LOCK-HOLDING ASCB ADDRESS. T2707500 LTR R1,R1 IF JCQ LOCK IS FREE, T2708000 BZ HEN190 CONTINUE. T2708500 CL R1,SSENASCB IF ASCB NOT SAME AS T2709000 BNE HEN190 ENDING MEMORY'S, CONTINUE. T2709500 CALL $SVJUNLK ELSE RELEASE THE JCQ LOCK. T2710000 B HEN100 THEN CHECK AGAIN. T2710500 HEN190 DS 0H T2711000 * T2711500 * T2712000 * PURGE INTERNAL READERS T2712500 * T2713000 * T2713500 HEN200 DS 0H T2714000 L R8,$SVIRDRS POINT TO FIRST INTRDR DCT. T2714500 USING DCTDSECT,R8 SET DCT ADDRESSABILITY. T2715000 SPACE 1 @OZ35996 T2715500 LH R3,$SVNINRS GET INTERNAL READER COUNT @OZ35996 T2716000 SLR R7,R7 ZERO R7 FOR ZEROING. T2716500 SLR R6,R6 ZERO R6 FOR COUNTING. T2717000 L R5,SSENASCB POINT R5 TO ENDING ASCB. T2717500 HEN210 DS 0H T2718000 CL R5,RIDASCBP IF INTRDR NOT ENDING MEMORY'S, T2718500 BNE HEN220 GO CHECK NEXT INTRDR. T2719000 MVI RIDEOME,0 ZERO ECB POST CODE FOR EOM @OZ48724 T2719200 OI RIDFLAGS,RIDEOM INDICATE ADDR SPACE TERM. @OZ37382 T2719500 OI DCTSTAT,DCTHOLD SHOW DEVICE HELD @OZ37382 T2719520 MVC RIDEOMA,PSAAOLD-PSA SET ASCB TO POST @OZ37382 T2719550 ST R7,RIDUBF BUFFER POINTERS ZERO. T2720000 NI RIDFLAGS,255-RIDBUSY SHOW SSSM GIVES UP CONTROL @OZ29612 T2720080 OI RIDFLAGS,RIDEND+RIDPOST SET END AND POST BITS @OZ29612 T2720160 OI DCTFLAGS,DCTDELET DELETE JOB ON INTRDR @OZ29612 T2720240 NI DCTFLAGS,255-DCTSTOP CLEAR POSSIBLE STOP @OZ29612 T2720320 $$POST ELMT=$SVIRDR POST HASPDISP FOR INTRDR @OZ29612 T2720400 WAIT 1,ECB=RIDEOME WAIT FOR HASP TO PURGE @OZ37382 T2720420 ST R7,RIDASCBP THEN CLEAR ASCB POINTER @OZ37382 T2720440 ST R7,RIDEOMA FOR EOM AND NORMAL WAIT @OZ37382 T2720460 ST R7,RIDEOME ...AND ECB FOR NEXT USER @OZ37382 T2720480 ST R7,RIDECB FOR EOM AND NORMAL @OZ37382 T2720490 NI RIDFLAGS,255-RIDALLOC SHOW NOT ALLOCATED. T2720500 BCTR R6,0 COUNT ONE. T2721000 HEN220 DS 0H T2721500 L R8,DCTCHAIN POINT TO NEXT INTRDR. T2722000 BCT R3,HEN210 BRANCH TO PROCESS IT @OZ35996 T2722500 HEN230 DS 0H T2723000 LTR R6,R6 IF WE DIDN'T UNALLOCATE, T2723500 BZ HEN290 DON'T POST WAIT ELEMENTS. T2724000 L R6,$SVIRWT GET POINTER TO FIRST T2724500 CS R6,R7,$SVIRWT WAIT ELEMENT, AND CLEAR T2725000 BNE *-4 THE POINTER. T2725500 LTR R6,R6 IF NO WAIT ELEMENTS, T2726000 BZ HEN290 END OF INTRDR PURGE. T2726500 L R5,CVTPTR POINT TO T2727000 USING CVT,R5 THE ASVT T2727500 L R5,CVTASVT FROM THE T2728000 USING ASVT,R5 CVT. T2728500 HEN240 DS 0H T2729000 L R4,12(,R6) GET WAIT ELM'S ASCB POINTER. T2729500 USING ASCB,R4 SET ASCB ADDRESSABILITY. T2730000 LH R3,ASCBASID GET ASID FROM ASCB. T2730500 ALR R3,R3 MULTIPLY T2731000 ALR R3,R3 BY FOUR. T2731500 CL R4,ASVTFRST(R3) IF ASCB ADDRESS DOESN'T T2732000 BNE HEN250 MATCH ASVT, BRANCH. T2732500 TM ASCBFLG1,ASCBTERM+ASCBABNT IF ASCB TERMINATING, T2733000 BNZ HEN250 BRANCH. T2733500 POST MF=(E,8(,R6)) POST WAIT ELEMENT. T2734000 L R6,0(,R6) POINT TO NEXT WAIT ELEMENT. T2734500 B HEN260 CHECK POINTER. T2735000 HEN250 DS 0H T2735500 LR R1,R6 INSTEAD OF POST, FREE W. E. T2736000 L R6,0(,R6) AFTER POINTING TO NEXT. T2736500 $FREMAIN RC,A=(R1),LV=32,SP=231,KEY=1 FREE W. E. T2737000 HEN260 DS 0H T2737500 LTR R6,R6 IF ANOTHER WAIT ELEMENT, T2738000 BNZ HEN240 GO CHECK IT. T2738500 DROP R8,R5,R4 DROP LOCAL BASES. T2739000 HEN290 DS 0H T2739500 * T2740000 * T2740500 * FIND A SUBSYSTEM JOB BLOCK TO TERMINATE T2741000 * T2741500 * T2742000 HEN300 DS 0H T2742500 LH R1,SSENASID GET TERMINATING MEMORY'S ID. T2743000 ALR R1,R1 MULTIPLY IT T2743500 ALR R1,R1 BY FOUR. T2744000 AL R1,$SVHAVT ADD HAVT ORIGIN. T2744500 L R1,0(,R1) POINT TO FIRST SJB THIS MEMORY. T2745000 LTR R1,R1 IF NO SJBS, T2745500 BZ HEN900 NO WORK TO DO. T2746000 HEN320 DS 0H T2746500 USING SJBDSECT,R1 SET R1 AS SJB BASE. T2747000 L R2,SJBSJB FIND THE T2747500 LTR R2,R2 LAST SUBSYSTEM T2748000 BZ HEN340 JOB BLOCK T2748500 LR R1,R2 ON THE CHAIN T2749000 B HEN320 FOR THIS MEMORY. T2749500 * T2750000 * T2750500 * CHAIN SJB SAVE AREA TO CALLER'S SAVE AREA T2751000 * T2751500 * T2752000 HEN340 DS 0H T2752500 ST R1,8(,R13) POINT CALLER'S SAVE AREA TO SJB T2753000 ST R13,4(,R1) POINT SJB TO CALLER'S AREA. T2753500 LR R13,R1 CHANGE SJB T2754000 DROP R1 ADDRESSABILITY FROM T2754500 USING SJBDSECT,RSJB R1 TO R13 (RSJB). T2755000 * T2755500 * T2756000 * GET JOB COMMUNICATION QUEUES LOCK. T2756500 * SET END-OF-MEMORY FLAG IN SJB. T2757000 * SET UP FOR XMPOST TO CURRENT MEMORY. T2757500 * T2758000 * T2758500 CALL $SVJLOK ACQUIRE JCQ LOCK. T2759000 OI SJBFLG2,SJB2EOM+SJB2PNIT FLAG SJB FOR EOM. T2759500 SLR R0,R0 ZERO THE T2760000 ST R0,SJBECB SJB'S ECB. T2760500 MVC SJBASCBP,PSAAOLD-PSA SET NEW POSTING ASCB. T2761000 * @OZ44608 T2761020 * PURGE PSO IF PRESENT @OZ44608 T2761040 * @OZ44608 T2761060 L R6,SJBPSOP POINT TO PSO. @OZ44608 T2761080 LTR R6,R6 TEST FOR PRESENT. @OZ44608 T2761100 BZ HEN350 SKIP PURGE IF NO PSO. @OZ44608 T2761120 CALL $SVJUNLK RELEASE THE JCQ LOCK. @OZ44608 T2761140 STM R14,R12,SJBSAVE+12 SAVE REGISTERS @OZ44608 T2761160 ICM R12,7,=AL3(HOSEOTB) POINT TO PSO PURGE BASE @OZ44608 T2761180 LR R8,R13 COPY SJB POINTER @OZ44608 T2761200 OI PSOFLG2-PSODSECT(R6),SSSOCTRL SET TO TERM. PSO. @OZ44608 T2761220 BAL R14,HETSOUT-HOSEOTB(,R12) ENTER PSO PURGER @OZ44608 T2761240 USING *,R14 @OZ44608 T2761260 ICM R12,7,=AL3(PSOBASE) POINT TO PSO QUE. ROUT. BS. @OZ44608 T2761280 DROP R14 @OZ44608 T2761300 LR R13,R8 RESTORE SJB POINTER @OZ44608 T2761320 BAL R8,PSOQUEUE-PSOBASE(,R12) ENTER PSO TERMINATOR @OZ44608 T2761340 LM R14,R12,SJBSAVE+12 RESTORE NORMAL REGISTERS @OZ44608 T2761360 SLR R0,R0 ZERO @OZ44608 T2761380 ST R0,SJBFLOW FLOW INDICATORS. @OZ44608 T2761400 CALL $SVJLOK ACQUIRE JCQ LOCK @OZ44608 T2761450 * T2761500 * T2762000 * BRANCH ACCORDING TO VALUE OF SJBQUEUE T2762500 * T2763000 * T2763500 HEN350 DS 0H @OZ44608 T2763700 L R1,SJBQUEUE GET HEADER ADDRESS T2764000 LTR R1,R1 OF CURRENT SJB QUEUE. T2764500 BZ HEN500 IF NOT ON QUEUE, BRANCH. T2765000 LA R0,$SVJPCLS GET 1ST Q HEADER ADDRESS. T2765500 SR R1,R0 COMPUTE CURRENT Q DISPLACEMENT. T2766000 BM HEN520 BRANCH IF INVALID. T2766500 LA R0,3 CHECK T2767000 NR R0,R1 FULLWORD BOUNDARY. T2767500 BNZ HEN520 BRANCH IF INVALID. T2768000 LA R0,$SVJRENQ-$SVJPCLS CHECK T2768500 CLR R0,R1 MAXIMUM VALUE. T2769000 BH HEN520 BRANCH IF INVALID. T2769500 * THE FOLLOWING CODE IS DEPENDENT ON THE ORDER OF DEFINITION T2770000 * OF THE JOB COMMUNICATION QUEUES IN THE SSVT T2770500 B *+4(R1) BRANCH TO VECTOR. T2771000 B HEN580 PCLS - PENDING BY CLASS T2771500 B HEN520 PXBM - PENDING FOR XBM T2772000 B HEN480 PNUM - PENDING BY NUMBER T2772500 B HEN400 XCLS - EXECUTING BY CLASS T2773000 B HEN400 XNUM - EXECUTING BY NUMBER T2773500 B HEN560 TERM - TERMINATING T2774000 B HEN560 RENQ - RE-ENQUEUEING T2774500 * T2775000 * T2775500 * PROCESSING IF TERMINATION REQUIRED T2776000 * T2776500 * T2777000 HEN400 DS 0H T2777500 LA R1,$SVJTERM ASSUME TERMINATION QUEUE. T2791500 TM SJBFLG2,SJB2JNL TEST FOR JOURNALLED JOB R4 T2791600 BZ HEN460 BR IF NO R4 T2791700 LA R1,$SVJRENQ SET RE-ENQUEUE QUEUE T2793000 HEN460 DS 0H T2793500 CALL $SJBRQ PUT SJB ON APPROPRIATE QUEUE. T2794000 * RELEASE THE JOB COMMUNICATION QUEUES LOCK T2794500 HEN480 DS 0H T2795000 ICM R15,7,SJBJQOFF+1 SEE IF JQE EXISTS... @OZ40028 T2795100 BZ HEN490 BRANCH IF NO @OZ28534 T2795200 MVI SJBECB,0 SHOW ECB UNPOSTED. T2795500 CALL $SVJUNLK RELEASE JCQ LOCK. T2796000 * POST HASPEXEC SHOWING JOB READY T2796500 $$POST ELMT=$SVJOB FIRE UP HASP. T2797000 * WAIT TILL HASP POSTS US BACK T2797500 WAIT 1,ECB=SJBECB WAIT FOR HASP. T2798000 CALL $SJBFREE FREE THE SJB R4 T2798100 B HEN300 GO DO NEXT SJB. T2799500 HEN490 SLR R1,R1 ZERO R1, TELL SJBRQ TO @OZ28534 T2799600 CALL $SJBRQ DEQUEUE SJB @OZ28534 T2799700 * HEN500 - SJB NOT ON ANY QUEUE. UNLOCK, FREE, & DO NEXT SJB. T2800000 HEN500 DS 0H T2800500 * FIRST SEE IF A PIT HAS BEEN VERIFIED BY HASPEXEC @OZ35293 T2800550 TM SJBFLG1,SJB1SJID WAS SJB FOR STARTED TASK.. @OZ35293 T2800600 BO HEN510 STC- NO PIT ASSOCIATED @OZ35293 T2800650 TM SJBLKFG,SJBFIRST JOB- WAS PIT VERIFIED... @OZ35293 T2800700 BO HEN510 NO, $P CAN KILL IT. @OZ35293 T2800750 TM SJBFLG2,SJB2CONV 'FAKE' SJB FOR CONVERTER.. @OZ39304 T2800760 BO HEN510 YES, JUST GET RID OF IT @OZ39304 T2800770 LA R1,$SVJPCLS ELSE HASP MUST KILL PIT @OZ35293 T2800800 B HEN580B GO TO TELL HASP ABOUT IT @OZ35293 T2800850 HEN510 DS 0H @OZ35293 T2800900 CALL $SVJUNLK RELEASE THE JCQ LOCK. T2801000 CALL $SJBFREE FREE THE SJB R4 T2801100 * GO DO THE NEXT SJB T2802000 B HEN300 GO DO NEXT SJB. T2802500 HEN520 DS 0H T2805000 LA R1,$SVJTERM SET TERMINATION QUEUE. T2808000 B HEN460 GO REQUEUE THE SJB. T2808500 * T2809000 * IF ALREADY ON TERM OR RENQ, RESET SJB2EOM T2809500 * T2810000 HEN560 DS 0H T2810500 NI SJBFLG2,255-SJB2EOM RESET SJB2EOM AND CONTINUE T2811000 B HEN480 BY $$POSTING AND WAITING. T2811500 * T2812000 * PENDING-BY-CLASS - RELEASE JCQ LOCK, T2812500 * START ANOTHER INITIATOR, AND FREE EVERYTHING T2813000 * T2813500 HEN580 DS 0H T2814000 TM SJBLKFG,SJBFIRST TEST FOR FIRST JOB REQUEST @OZ35293 T2814010 BO HEN580C 1ST TIME, A PIT IS WAITING @OZ35293 T2814020 HEN580B CALL $SJBRQ ELSE WE MUST KILL A PIT @OZ35293 T2814030 MVI SJBECB,0 SHOW ECB UNPOSTED @OZ35293 T2814040 CALL $SVJUNLK RELEASE THE JCQ LOCK @OZ35293 T2814050 * POST HASPEXEC SO AN INACTIVE PIT WILL BE TERMINATED @OZ35293 T2814060 $$POST ELMT=$SVJOB @OZ35293 T2814070 WAIT 1,ECB=SJBECB WAIT FOR HASP TO POST US @OZ35293 T2814080 B HEN580D @OZ35293 T2814090 HEN580C DS 0H @OZ35293 T2814095 SLR R1,R1 TELL $SJBRQ TO DEQUEUE R41 T2814100 CALL $SJBRQ CALL $SJBRQ R41 T2814200 CALL $SVJUNLK RELEASE THE JCQ LOCK. T2814500 LA R1,SJBID POINT TO COMMAND AREA. T2815000 MVC 0(22,R1),HEN580A MOVE COMMAND TEXT. T2815500 MVC 18(4,R1),$SVSSNM MOVE SUBSYSTEM ID. T2816000 SLR R0,R0 ZERO REGISTER 0. T2816500 SVC 34 ISSUE START-INIT COMMAND. T2817000 HEN580D DS 0H @OZ35293 T2817090 CALL $SJBFREE FREE THE SJB R4 T2817100 B HEN300 GO DO NEXT SJB R4 T2817200 HEN580A DC AL2(22,0),C'S INIT.INIT,,,****' COMMAND T2818500 * T2819000 * END OF END-OF-MEMORY T2819500 * T2820000 HEN900 DS 0H T2820500 SLR R15,R15 SHOW NORMAL RETURN. T2821000 $EPILOG , RETURN TO USER. T2821500 SPACE 2 T2856000 DROP , DROP ALL BASES. T2856500 TITLE 'LITERAL POOL FOR HCBXX, HOSRENQ - HOSEOM' T2857000 LTORG T2857500 TITLE 'HASP SUBSYSTEM SUPPORT ROUTINE -- ALLOCATE' T2858000 * T2858500 * T2859000 * HASP SUBSYSTEM SUPPORT ROUTINE -- ALLOCATE T2859500 * T2860000 * T2860500 HOSALLOC $PROLOG SSOBALOC,SSALSIZE,LOCK=REQ T2861000 USING SSALBGN,RSOX SET SSAL ADDRESSABILITY. T2861500 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T2862000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T2862500 L RJFC,SSALJFCB POINT TO DATA SET'S JFCB. T2863000 USING INFMJFCB,RJFC SET JFCB ADDRESSABILITY. T2863500 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T2864000 SPACE 2 R4 T2864500 * T2865000 * CREATE DSNAME IF REQUIRED T2865500 * T2866000 SPACE 1 T2866500 TM SSALFLG1,SSALASNM DOES DSNAME EXIST ALREADY... T2867000 BZ HAL020 IF SO, GO CHECK IT. T2867500 LA R14,HALO ELSE SET RETURN ADDRESS T2868000 B HALCRDSN AND CREATE DSNAME. T2868500 SPACE 2 R4 T2869000 * T2869500 * VALIDIFY DATA SET NAME T2870000 * T2870500 SPACE 1 R4 T2871000 HAL020 DS 0H T2871500 MVC DSNSSNM,$SVSSNM SET SUBSYS NAME IN DSN. T2872000 SPACE 1 R4 T2873000 * T2873500 * BRANCH TO PROPER ALLOCATION ROUTINE T2874000 * T2874500 SPACE 1 T2875000 LH R0,DSNDSTYP GET DATA SET TYPE. T2875500 CH R0,=C'SI' IF SYSIN, T2876000 BE HALI GO ALLOCATE. T2876500 CH R0,=C'SO' IF SYSOUT, T2877000 BE HALO GO ALLOCATE. T2877500 CH R0,=C'PS' IF PROCESS-SYSOUT, T2878000 BE HALP GO ALLOCATE. T2878500 B HAL800 ERROR - UNRECOGNIZED TYPE. T2879000 EJECT T2879500 * T2880000 * T2880500 * SYSIN DATA SET ALLOCATION T2881000 * T2881500 * T2882000 SPACE 1 T2882500 HALI DS 0H T2883000 LA RIOT,SJBIOT POINT TO THE 1ST IOT. T2883500 BAL R14,HALFINDP ATTEMPT TO FIND DATA SET. T2884000 BZ HAL800 ERROR - DATA SET NOT FOUND. T2884500 LR RSIB,RSOX SAVE SSAL ADDRESS IN RSIB. T2885000 CALL $SDBINIT CREATE AN SDB FOR DATA SET. T2885500 BNZ HAL800 ERROR - NO STORAGE. T2886000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T2886500 ST R4,SDBPDDB SET PDDB ADDRESS AND ITS T2887000 ST RIOT,SDBPIOT IOT ADDRESS IN THE SDB. T2887500 BAL R14,HALJMERG MERGE PDDB INTO JFCB. T2888000 SPACE 3 T2888500 * T2889000 * IF XBM BATCH INPUT UNIT, STORE SDB ADDRESS T2889500 * IN SJB AND FLAG THE SDB AS BATCH INPUT. T2890000 * T2890500 SPACE 1 T2891000 TM SJBFLG1,SJB1XBM IF NOT BATCH MONITOR INPUT, T2891500 BZ HAL950 RETURN. T2892000 ST RSDB,SJBXBSDB POINT SJB TO BATCH INPUT SDB. T2892500 OI SDBFLG2,SDB2XBIN SHOW SDB IS BATCH INPUT. T2893000 B HAL950 RETURN. T2893500 SPACE 1 T2894000 DROP RSDB DROP SDB BASE. T2894500 USING SSALBGN,RSOX RESET SSAL ADDRESSABILITY. T2895000 EJECT T2895500 * T2896000 * T2896500 * SYSOUT DATA SET ALLOCATION T2897000 * T2897500 * R4 T2897600 SPACE 1 R4 T2897700 HALO DS 0H R4 T2897800 L R5,PSATOLD-PSA FIND CURRENT TCB R4 T2897900 L R5,TCBTCT-TCB(,R5) GET TCT ADDRESS R4 T2898000 LA R5,0(,R5) CLEAR HI-ORDER BYTE R4 T2898100 LTR R5,R5 TEST FOR SMF R4 T2898200 BZ HALO10 BR IF NO R4 T2898300 L R5,TCTJMR-SMFTCT(,R5) GET JMR ADDRESS R4 T2898400 L R1,SJBJCT GET JCT ADDRESS R4 T2898500 USING JCTDSECT,R1 PROVIDE JCT ADDRESSABILITY R4 T2898600 CLC JCTUSEID,JCTUSEID-JCTJMR(R5) TEST USER SMF INFO R4 T2898700 BE SKIP80 BR IF UNCHANGED R4 T2898800 OI JCTFLAG1,JCT1CKPT CAUSE JCT CKPT R4 T2898900 SKIP80 CLC JCTUCOM,JCTUCOM-JCTJMR(R5) TEST USER SMF INFO R4 T2899000 BNE SKIP90 BR IF CHANGED R4 T2899100 TM JCTFLAG1,JCT1CKPT IS JCT CKPT REQUIRED... R4 T2899200 BZ HALO10 BR IF NO R4 T2899300 SPACE 1 R4 T2899400 * R4 T2899500 * USER FIELDS IN JMR MODIFIED -- TRANSFER TO JCT AND CKPT R4 T2899600 * R4 T2899700 SPACE 1 R4 T2899800 SKIP90 MVC JCTUSEID,JCTUSEID-JCTJMR(R5) XFER USER SMF INFO R4 T2899900 MVC JCTUCOM,JCTUCOM-JCTJMR(R5) XFER USER SMF INFO R4 T2900000 NI JCTFLAG1,255-JCT1CKPT RESET CKPT FLAG R4 T2900100 L R0,SJBJCTRK GET JCT TRACK ADDRESS R4 T2900200 CALL HCBWR WRITE THE JCT R4 T2900300 DROP R1 KILL JCT ADDRESSABILITY R4 T2900400 HALO10 DS 0H R4 T2900500 L R1,SSALPGMN POINT TO USER WRITER NAME R4 T2900600 CLC =CL8'INTRDR',0(R1) IF IT'S 'INTRDR', T2900700 BE HALR ALLOCATE INTERNAL READER. T2900800 EJECT @OZ39639 T2901000 ***************************************************************@OZ39639 T2901010 * @OZ39639 T2901020 * IF 'JESNEWS' DATA SET -- CONFIRM AUTHORIZATION @OZ39639 T2901030 * @OZ39639 T2901040 ***************************************************************@OZ39639 T2901050 SPACE 1 @OZ39639 T2901060 SLR R3,R3 ASSUME NOT JESNEWS DATA SET @OZ39639 T2901070 CLC =CL8'JESNEWS',0(R1) JESNEWS... @OZ39639 T2901080 BNE HALO15 BR IF NO @OZ39639 T2901090 SPACE 1 @OZ39639 T2901100 GETMAIN RC,LV=HALNEWSL GETMAIN A WORK AREA @OZ39639 T2901110 LTR R15,R15 STORAGE AVAILABLE... @OZ39639 T2901120 BNZ HAL800 PASS BACK ERROR IF NOT @OZ39639 T2901130 SPACE 1 @OZ39639 T2901140 USING HALNEWS,R6 WORK AREA ADDRESSABILITY @OZ39639 T2901150 SPACE 1 @OZ39639 T2901160 LR R6,R1 SET BASE @OZ39639 T2901170 MVC HALNEWSM,HALNEWSW MOVE LIST-FORM WTOR @OZ39639 T2901180 MVC HALNEWSJ+HALNEWSM,SJBJOBNM INSERT JOBNAME @OZ39639 T2901190 SPACE 1 @OZ39639 T2901200 HALO12 MVI HALNEWSE,0 RESET ECB @OZ39639 T2901210 WTOR ,HALNEWSR,1,HALNEWSE,MF=(E,HALNEWSM) ASK OPER @OZ39639 T2901220 WAIT ECB=HALNEWSE WAIT FOR RESPONSE @OZ39639 T2901230 OI HALNEWSR,X'40' FORCE UPPER-CASE @OZ39639 T2901240 CLI HALNEWSR,C'N' OPERATOR REPLY 'N'... @OZ39639 T2901250 BE HALO13 BR IF YES @OZ39639 T2901260 CLI HALNEWSR,C'Y' OPERATOR REPLY 'Y'... @OZ39639 T2901270 BNE HALO12 ASK AGAIN IF NOT @OZ39639 T2901280 LA R3,C'N' ELSE REMEMBER JESNEWS DS @OZ39639 T2901290 OI SSALFLG1,SSALTRKM AND FORCE SEPARATE TGM @OZ39639 T2901300 EJECT @OZ39639 T2901310 HALO13 FREEMAIN R,LV=HALNEWSL,A=(R6) FREE WORK AREA @OZ39639 T2901320 LTR R3,R3 OK TO ALLOCATE JESNEWS... @OZ39639 T2901330 BZ HAL800 PASS BACK ERROR IF NOT @OZ39639 T2901340 B HALO15 ELSE BR TO CONTINUE ALLOC @OZ39639 T2901350 SPACE 1 @OZ39639 T2901360 DROP R6 DROP WORK AREA @OZ39639 T2901370 SPACE 8 @OZ39639 T2901380 $MID 360 ------ 360 ------- @OZ39639 T2901390 SPACE 2 @OZ39639 T2901400 HALNEWSW WTOR '&MID.******** REQUESTS ACCESS TO JESNEWS (Y OR N)',MF=L T2901410 HALNEWSJ EQU *-44-HALNEWSW,8 JOBNAME INSERT @OZ39639 T2901420 HALNEWSN EQU *-HALNEWSW LIST-FORM WTOR LENGTH @OZ39639 T2901430 SPACE 4 @OZ39639 T2901440 HALNEWS DSECT , JESNEWS MESSAGE WORK AREA @OZ39639 T2901450 HALNEWSR DS F REPLY AREA @OZ39639 T2901460 HALNEWSE DS F ECB @OZ39639 T2901470 HALNEWSM DS CL(HALNEWSN) LIST-FORM WTOR @OZ39639 T2901480 HALNEWSL EQU *-HALNEWS WORK AREA LENGTH @OZ39639 T2901490 HASPSSSM CSECT , @OZ39639 T2901500 EJECT @OZ39639 T2901510 * @OZ39639 T2901520 * TEST FLAGS SSALHOLD, SSALTRKM T2902000 * T2902500 SPACE 1 T2903000 HALO15 TM SSALFLG1,SSALHOLD+SSALTRKM IF SPIN OR HOLD, @OZ39639 T2903500 BNZ HALO20 BUILD AN IOT. T2904000 CALL HALCLASS IF NOT SCATHOLD, T2904500 BZ HALO40 SKIP BUILDING IOT. T2905000 SPACE 3 T2905500 * T2906000 * GET STORAGE FOR, CREATE, AND CHAIN AN IOT T2906500 * T2907000 SPACE 1 T2907500 HALO20 DS 0H T2908000 TM SJBFLG1,SJB1XBM+SJB1XBMC IF NOT BATCH MONITOR, T2908500 BZ HALO30 CONTINUE. T2909000 TM SSALFLG1,SSALTRKM+SSALASNM TEST FOR DYNAMIC ALLOCATE T2909500 BZ HALO40 TREAT AS NON SPIN/HOLD @OZ20657 T2910000 B HAL800 BUT DISALLOW DYNAMIC ALLOCATE T2910500 SPACE 1 T2911000 HALO30 DS 0H T2911500 CALL HCBGM GET STORAGE FOR IOT. T2912000 BNZ HAL800 ERROR - NO STORAGE AVAILABLE. T2912500 SPACE 1 T2913000 LR RIOT,R1 SET IOT BASE REGISTER. T2913500 L R1,SJBIOT POINT TO ALLOCATION IOT. T2914000 LTR R1,R1 IF NO ALLOCATION IOT, T2914500 BZ HALO50 ERROR - CAN'T GET TRACK. T2915000 LA R1,IOTMSTAB-IOTDSECT(,R1) POINT TO MASTER TAB R4 T2915100 CALL $STRAK GET A TRACK FOR THE IOT. T2916000 L R15,SJBIOT GET ALLOCATION IOT ADDRESS @OZ17477 T2916100 OI IOTFLAG1-IOTDSECT(R15),IOT1CKPT FORCE IOT CHKPT @OZ17477 T2916200 SPACE 1 T2916500 CALL HALCRIOT FORMAT THE IOT. T2917000 LTR R3,R3 JESNEWS DATA SET... @OZ39639 T2917100 BZ *+8 BR IF NO @OZ39639 T2917200 OI IOTFLAG1,IOT1NEWS ELSE SET INDICATION @OZ39639 T2917300 SPACE 1 T2917500 CALL HALCHIOT CHAIN THE IOT. T2918000 SPACE 1 T2918500 B HALO80 CREATE A PDDB. T2919000 SPACE 3 T2919500 * T2920000 * IF SSALASNM, DON'T BOTHER SEARCHING PDDBS T2920500 * T2921000 SPACE 1 T2921500 HALO40 DS 0H T2922000 TM SSALFLG1,SSALASNM IF DSNAME ASSIGNED HERE, T2922500 BO HALO60 SKIP PDDB SEARCH. T2923000 SPACE 3 T2923500 * T2924000 * OTHERWISE SEARCH PDDBS FOR SAME DS KEY T2924500 * T2925000 SPACE 1 T2925500 LA RIOT,SJBIOT POINT TO THE 1ST IOT. T2926000 BAL R14,HALFINDP TEST FOR PREV-CREATED PDDB. T2926500 LR R6,R4 POINT R6 TO PDDB. T2927000 BC 13,HALO45 BRANCH IF PDDB NOT FOUND. T2927500 L R1,SSALSOUT POINT TO DATA SET STATUS. T2928000 TM 0(R1),1 IF OLD AND PDDB EXISTS, T2928500 BO HALO100 GO BUILD AN SDB. T2929000 USING PDBDSECT,R6 SET PDDB ADDRESSABILITY. T2929500 OI PDBFLAG1,PDB1NULL NEW. SHOW NEW PDDB. T2930000 OI IOTFLAG1,IOT1CKPT FLAG IOT FOR CHECKPOINT. T2930500 B HALO100 THEN GO BUILD AN SDB. T2931000 HALO45 L R1,SSALSOUT POINT TO SCTSBYT3. T2931500 TM 0(R1),1 SINCE PDDB NOT FOUND, T2932000 BO HAL800 ERROR IF DISP=OLD. T2932500 B HALO60 CONTINUE IF DISP=NEW. T2933000 SPACE 3 T2933500 * T2934000 * ERROR ROUTINE TO FREE IOT AND EXIT T2934500 * T2935000 SPACE 1 T2935500 HALO50 DS 0H T2936000 LR R1,RIOT POINT R1 TO THE IOT. T2936500 CALL HCBFM FREE IT. T2937000 B HAL800 GO TO ERROR EXIT. T2937500 SPACE 3 T2938000 * T2938500 * FIND THE LAST IOT ON SJBIOT R4 T2938600 * T2939500 SPACE 1 T2940000 HALO60 DS 0H T2940500 L R1,SJBIOT POINT TO THE 1ST IOT. T2941000 HALO70 DS 0H T2941500 LR RIOT,R1 SET IOT BASE. T2942000 L R1,IOTIOT POINT TO THE NEXT IOT. T2942500 LTR R1,R1 IF IT EXISTS, T2943000 BNZ HALO70 LOOP TILL LAST IS FOUND. T2943500 SPACE 3 T2944000 * T2944500 * CREATE A PERIPHERAL DATASET DEFINITION BLOCK T2945000 * T2945500 SPACE 1 T2946000 HALO80 DS 0H T2946500 PACK SJBDBLWK,DSNDSNR SET PACKED DS KEY. T2947500 CALL HALCRPDB CREATE A PDDB. T2948000 BC 2,HALO30 NO ROOM IN IOT,GET ANOTHER @OZ20657 T2948500 BC 4,HAL820 ERROR - INVALID DESTINATION. T2949000 SPACE 3 T2949500 * T2950000 * CREATE ADDITIONAL PDDBS FOR MULTIPLE DESTINATIONS T2950500 * T2951000 SPACE 1 T2951500 TM PDBFLAG1,PDB1MDES IF NOT MULTIPLE DESTINATIONS, T2952000 BZ HALO100 SKIP MULTIPLE PDDBS. T2952500 L R7,SJBJCT POINT TO THE HASP JCT. T2953000 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T2953500 STM R5,R6,JCTWORK+12 SAVE FIRST IOT & PDDB ADDRS. T2954000 CL RIOT,SJBIOT UNLESS THE PDDB'S IOT T2954500 BE *+8 IS THE MAIN ALLOCATION IOT, T2955000 NI IOTFLAG1,255-IOT1ALOC DON'T USE IT FOR ALLOC. T2955500 HALO84 DS 0H T2956000 MVC JCTWORK(8),JCTWORK+2 GET NEXT DESTINATION. T2956500 LH R2,JCTWORK GET IT INTO REGISTER 2. T2957000 LTR R2,R2 IF IT'S DEFAULT, R4 T2957500 BE HALO95 WE'RE AT THE END. T2958000 TM PDBFLAG1,PDB1PSO IF CURRENT PDDB IS PSO, T2958500 BO HALO87 GO BUILD A NEW IOT. T2959000 L R4,IOTPDDBP GET OFFSET FOR NEXT PDDB. T2959500 LA R15,PDBLENG(,R4) IF THIS IOT R4 T2960000 CH R15,IOTLENG HAS ROOM R4 T2960300 BNH HALO90 FOR ANOTHER PDDB, BRANCH. T2960500 HALO87 DS 0H T2961000 CALL HCBGM GET SPACE FOR AN IOT. T2961500 BNZ HAL800 ERROR - NO STORAGE AVAILABLE. T2962000 LR RIOT,R1 SET IOT BASE REGISTER. T2962500 L R1,SJBIOT POINT TO ALLOCATION IOT. T2963000 LA R1,IOTMSTAB-IOTDSECT(,R1) THENCE TO MASTER TAB R4 T2963100 CALL $STRAK GET A TRACK FOR NEW IOT. T2964000 L R15,SJBIOT GET ALLOCATION IOT ADDRESS @OZ17477 T2964100 OI IOTFLAG1-IOTDSECT(R15),IOT1CKPT FORCE IOT CHKPT @OZ17477 T2964200 CALL HALCRIOT FORMAT THE IOT. T2964500 NI IOTFLAG1,255-IOT1ALOC DON'T USE ITS TGM. T2965000 CALL HALCHIOT CHAIN THE IOT. T2965500 L R4,IOTPDDBP GET OFFSET TO FIRST PDDB. T2966000 HALO90 DS 0H T2966500 LA R1,0(R4,RIOT) GET ABSOLUTE PDDB ADDRESS. T2967000 MVC 0(PDBLENG,R1),0(R6) MOVE NEW PDDB. T2967500 STH R2,PDBDEST-PDBDSECT(,R1) SET NEW DESTINATION. T2968000 LA R0,PDBLENG(,R4) GET OFFSET TO NEXT PDDB T2968500 ST R0,IOTPDDBP AND STORE IT IN IOT. T2969000 B HALO84 TRY FOR ANOTHER PDDB. T2969500 HALO95 DS 0H T2970000 LR R6,R1 POINT R6 TO MOST-RECENT PDDB. T2970100 TM IOTFLAG1,IOT1SPIN IF SPIN, IOTS ARE CHAINED T2970200 BO *+8 LIFO - SDBPIOT AND SDBPDDB T2970300 * MUST POINT TO LAST-CREATED. T2970400 LM R5,R6,JCTWORK+12 RESTORE 1ST PDDB, IOT PTRS. T2970500 DROP R7 DROP JCT ADDRESSABILITY. T2971000 L RJFC,SSALJFCB POINT TO JFCB. T2971500 USING INFMJFCB,RJFC SET JFCB ADDRESSABILITY. T2972000 SPACE 3 T2972500 SPACE 3 T2973000 * T2973500 * FINALLY, CREATE A SUBSYSTEM DATASET BLOCK T2974000 * T2974500 SPACE 1 T2975000 HALO100 DS 0H T2975500 LR RSIB,RSOX POINT RSIB TO SSAL. T2976000 DROP RSOX CHANGE SSAL T2976500 USING SSALBGN,RSIB ADDRESSABILITY. T2977000 CALL $SDBINIT GET STORAGE, FORMAT SDB. T2977500 BNZ HAL800 ERROR - NO STORAGE AVAILABLE. T2978000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T2978500 TM PDBFLAG2,PDB2TCEL IS THIS A TRAKCELL'ED DATA SET R4 T2978600 BZ SKIP100 BR IF NO R4 T2978700 OI SDBTAB+(TABFLAG-TABDSECT),TABMAJOR SHOW MAJOR TAB R4 T2978800 SKIP100 L R1,SSALCLAS IF OUTPUT CLASS T2979000 CLI 0(R1),C'$' IS DOLLAR-SIGN T2979500 BE HALO110 OR ASTERISK, T2980000 CLI 0(R1),C' ' OR NULL R41 T2980100 BE HALO110 R41 T2980200 CLI 0(R1),C'*' SET FLAG SDB2MCLS. T2980500 BNE HALO120 THIS IS USED BY T2981000 HALO110 OI SDBFLG2,SDB2MCLS XBM CONTINUATION. T2981500 HALO120 DS 0H T2982000 ST R6,SDBPDDB POINT SDB TO THE PDDB T2982500 ST RIOT,SDBPIOT AND TO ITS IOT. T2983000 L R1,JFCOUTLI-1 GET OUTPUT LIMIT FROM JFCB. T2983500 LA R1,0(,R1) IT'S ONLY 3 BYTES LONG. T2984000 BCTR R1,0 REDUCE 0 TO -1. T2984500 ST R1,SDBOUTLM SET OUTPUT LIMIT IN SDB. T2985000 MVC SDBAIOT,SJBIOT SET ALLOCATION IOT DEFAULT. T2985500 TM IOTFLAG1,IOT1ALOC IF PDDB'S IOT SAYS ALLOCATE, T2986000 BZ *+8 HOWEVER, T2986500 ST RIOT,SDBAIOT USE PDDB'S IOT INSTEAD. T2987000 MVC SDBDKEY,PDBDSKEY SET DATA SET KEY IN SDB. T2987500 OI SDBFLG1,SDB1PUT+SDB1OUT SHOW PUT, SYSOUT. T2988000 * TEST FOR RESTART SITUATION T2988500 TM PDBFLAG1,PDB1NULL IF PDDB UNOPENED, T2989000 BO HALO200 SKIP. T2989500 L R1,SSALSOUT IF DATA SET SAYS IT'S T2990000 TM 0(R1),1 OLD, THIS IS RESTART. T2990500 BZ HALO200 SKIP IF NEW. T2991000 MVC SDBTRK+1(4),PDBMTTR SET UP SDBTRK T2991500 MVC SDBTRK+5(3),=X'FFFFFF' FOR POINT IN OPEN. T2992000 MVC SDBTRKF+1(4),PDBMTTR SET DATA SET'S T2992500 MVI SDBTRKF+7,1 STARTING RBA. T2993000 HALO200 DS 0H T2993500 B HAL900 RETURN. T2994000 DROP R6,RSIB,RSDB DROP PDDB, SSAL, SDB BASES. T2994500 USING SSALBGN,RSOX SET SSAL ADDRESSABILITY. T2995000 EJECT T2995500 * T2996000 * T2996500 * PROCESS-SYSOUT DATA SET ALLOCATION T2997000 * T2997500 * T2998000 SPACE 1 T2998500 HALP DS 0H T2999000 L R4,SJBPSOP POINT TO THE PSO BLOCK. T2999500 LTR R4,R4 IF IT DOESN'T EXIST, T3000000 BZ HAL800 ERROR - CAN'T ALLOCATE. T3000500 USING PSODSECT,R4 GET PSO ADDRESSABILITY. T3001000 SPACE 3 T3002500 * T3003000 * BUILD AN SDB FOR THE DATA SET T3003500 * T3004000 SPACE 1 T3004500 LR RSIB,RSOX POINT RSIB TO THE SSAL. T3005000 CALL $SDBINIT CREATE AN SDB. T3005500 BNZ HAL800 ERROR - NO STORAGE AVAILABLE. T3006000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T3006500 MVC SDBJKEY,PSOJBKEY SET JOB KEY IN SDB. T3007000 LA R4,PSOPDDB GET PSO PDDB ADDRESS T3007500 BAL R14,HALJMERG MERGE PDDB INTO JFCB. T3008000 ST R4,SDBPDDB POINT SDB TO PDDB. T3008500 OI SDBFLG1,SDB1PSO SHOW PSO TYPE. T3009000 B HAL950 RETURN SKIPPING CHECKPOINT. T3009500 DROP R4,RJFC,RSDB DROP PDDB, JFCB, SDB BASES. T3010000 EJECT T3010500 * T3011000 * INTERNAL READER DATA SET ALLOCATION T3011500 * T3012000 HALR DS 0H T3012500 LR RSIB,RSOX POINT RSIB TO THE SSAL. T3013000 USING SSALBGN,RSIB SET SSAL ADDRESSABILITY. T3013500 * T3014000 * CHECK AUTHORIZATION, IF NECESSARY T3014500 * T3015000 TM SSALFLG1,SSALASNM IS THIS DYNAMIC ALLOCATION... T3015500 BZ HALR10 IF NOT, GO ALLOCATE. T3016000 L R10,PSATOLD-PSA DYNAMIC. POINT TO TCB, T3016500 L R10,TCBJSCB-TCB(,R10) THENCE TO JSCB, T3017000 L R10,JSCBACT-IEZJSCB(,R10) THENCE TO ACTIVE JSCB. R41 T3017100 L R10,JSCBPSCB-IEZJSCB(,R10) THENCE TO PSCB. T3017500 LTR R10,R10 IS THERE A PSCB... T3018000 BZ HALR10 IF NOT, GO ALLOCATE. T3018500 TM PSCBATR1-PSCB(R10),PSCBJCL IF USER IS AUTHORIZED, T3019000 BO HALR10 GO ALLOCATE AN INTRDR. T3019500 LA R15,SSALNAUT SHOW ALLOCATION NOT AUTHORIZED T3020000 $EPILOG KEY=0 AND RETURN. T3020500 * T3021000 * IT IS OKAY TO ALLOCATE AN INTERNAL READER T3021500 * T3022000 HALR10 DS 0H T3022500 * T3023000 * ACQUIRE CROSS-MEMORY SERVICES LOCK T3023500 * T3024000 LR R1,R13 SAVE SAVEAREA POINTER T3024500 STM R11,R13,12(R1) SAVE REGISTERS 11 THROUGH 13. T3025000 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=(HALR40,HALR90,HCT3025500 ALR110) OBTAIN LOCAL LOCK. T3026000 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,RELATED=(HALR40,HALR90,HALCT3026500 R110) OBTAIN CMS LOCK. T3027000 LM R11,R13,12(R1) RESTORE REGISTERS 11 THROUGH 13. T3027500 * T3028000 * SEE IF JES2 WAS INITIALIZED WITH INTERNAL READERS R4 T3028100 * T3029000 HALR19 L R1,PSAAOLD-PSA POINT TO CURRENT ASCB. T3029500 L R10,$SVIRDRS POINT TO FIRST INTRDR DCT. T3030000 USING DCTDSECT,R10 USE DCT DSECT. T3030500 SPACE 1 @OZ35996 T3031000 LH R2,$SVNINRS GET INTERNAL READER COUNT @OZ35996 T3031500 BCTR R2,0 REDUCE BY 2 FOR T3032000 BCTR R2,0 STCINRDR, TSOINRDR. T3032500 L R10,DCTCHAIN BYPASS STCINRDR T3033000 L R10,DCTCHAIN BYPASS TSOINRDR. T3033500 LTR R2,R2 ARE THERE ANY INTRDRS AT ALL... T3034000 BZ HALR90 NO, CAN'T ALLOCATE R4 T3034100 SR R0,R0 ZERO COUNTER, USED TO SEE IF ALL T3035000 * ALLOCATED INTERNAL READERS BELONG T3035500 * TO THIS CALLER'S MEMORY. T3036000 * T3036500 * FIND AN UNALLOCATED INTERNAL READER T3037000 * T3037500 HALR20 DS 0H T3038000 TM RIDFLAGS,RIDALLOC IS THIS INTRDR ALLOCATED... T3038500 BZ HALR100 IF NOT, WE'LL TAKE IT. T3039000 CL R1,RIDASCBP YES. IS IT ALLOC'D TO SAME T3039500 BE *+6 MEMORY AS REQUESTOR... T3040000 BCTR R0,0 IF NOT, COUNT A CANDIDATE. T3040500 L R10,DCTCHAIN POINT TO NEXT INTRDR DCT. T3041000 BCT R2,HALR20 BRANCH TO EXAMINE IT. T3041500 * T3042000 * ALL INTERNAL READERS ARE ALLOCATED T3042500 * T3043000 HALR30 DS 0H T3043500 LTR R0,R0 ARE ALL ALLOCATED TO CALLER'S MEM... T3044000 BZ HALR90 IF SO, UNABLE TO ALLOCATE. T3044500 TM SSALFLG1,SSALWAIT IS CANCEL ECB VALID... T3045000 BZ HALR90 IF NOT, DO NOT WAIT. T3045500 * T3046000 * GET A WAIT ELEMENT T3046500 * T3047000 $GETMAIN RC,LV=32,SP=231,KEY=1 GET WAIT ELEMENT. T3047500 BNZ HALUNSC BRANCH IF ELEMENT NOT GOT. T3048000 * T3048500 * WAIT ELEMENT --- T3049000 * +0 - CHAIN (HEADER IS $SVIRWT) T3049500 * +4 - ECB FOR UNALLOCATE TO POST T3050000 * +8 - ECB POINTER FOR XMPOST T3050500 * +12 - ASCB POINTER FOR XMPOST T3051000 * +16 - ERRET POINTER FOR XMPOST T3051500 * +20 - ECBLIST 1 - POINTER TO CANCEL ECB T3052000 * +24 - ECBLIST 2 - POINTER TO ABOVE ECB T3052500 * T3053000 * T3053500 * FILL IN THE WAIT ELEMENT T3054000 * T3054500 MVI 4(R1),0 CLEAR UNALLOCATE ECB. T3055000 LA R2,4(,R1) POINT TO UNALLOCATE ECB. T3055500 ST R2,8(,R1) SET POINTER FOR XMPOST. T3056000 ST R2,24(,R1) SET POINTER FOR WAIT. T3056500 MVI 24(R1),X'80' TERMINATE ECBLIST. T3057000 L R2,CVTPTR POINT TO CVT, T3057500 L R3,PSAAOLD-PSA POINT TO CURRENT ASCB. T3058000 ST R3,12(,R1) SAVE ASCB POINTER FOR XMPOST. T3058500 LA R3,CVTBRET-CVT(,R2) POINT TO 'BR 14'. T3059000 ST R3,16(,R1) SET ERRET POINTER FOR XMPOST. T3059500 MVC 20(4,R1),SSALCNCL SET CANCEL ECB POINTER FOR WAIT. T3060000 L R0,$SVIRWT CHAIN NEW T3060500 ST R0,0(,R1) WAIT ELEMENT T3061000 CS R0,R1,$SVIRWT LAST-IN-FIRST-OUT T3061500 BNE *-8 ON HEADER $SVIRWT. T3062000 LR R3,R1 SAVE WAIT ELEMENT ADDRESS. T3062500 * T3063000 * RELEASE CMS LOCK T3063500 * T3064000 HALR40 DS 0H T3064500 LR R2,R13 SAVE SAVEAREA POINTER. T3065000 STM R11,R13,12(R2) SAVE REGISTERS 11 - 13. T3065500 SETLOCK RELEASE,TYPE=CMS,RELATED=HALR10 RELEASE CMS LOCK. T3066000 SETLOCK RELEASE,TYPE=LOCAL,RELATED=HALR10 CT3066500 RELEASE LOCAL LOCK. T3067000 LM R11,R13,12(R2) RESTORE REGISTERS 11 - 13. T3067500 * T3068000 * WAIT FOR CANCEL OR UNALLOCATION. T3068500 * T3069000 WAIT 1,ECBLIST=20(,R1) WAIT. T3069500 * T3070000 * WHEN POSTED, REESTABLISH CMS LOCK T3070500 * T3071000 HALR45 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=(HALR90,HALR110)CT3071500 AGAIN OBTAIN CMS LOCK. T3072000 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,RELATED=(HALR90,HALR110) CT3072500 AGAIN OBTAIN LOCAL LOCK. T3073000 LM R11,R13,12(R2) RESTORE REGISTERS 11 THROUGH 13. T3073500 * T3074000 * DECHAIN AND FREE WAIT ELEMENT. T3074500 * T3075000 LR R1,R3 POINT R1 TO SUBJECT WAIT ELEMENT. T3075500 LA R2,$SVIRWT POINT R2 TO HEADER. T3076000 HALR50 LR R3,R2 SAVE PREVIOUS POINTER. T3076500 L R2,0(,R2) GET NEXT POINTER. T3077000 LTR R2,R2 IF ZERO, CHAIN ENDS T3077500 BZ HALR60 - MERELY FREE SUBJECT ELEMENT. T3078000 CLR R1,R2 IF NEXT DOESN'T MATCH SUBJECT, T3078500 BNE HALR50 KEEP TRYING. T3079000 MVC 0(4,R3),0(R1) DECHAIN SUBJECT. T3079500 HALR60 $FREMAIN RU,A=(R1),LV=32,SP=231,KEY=1 FREE WAIT ELEMENT. T3080000 * T3080500 * NOW FIND WHY WE WERE POSTED T3081000 * T3081500 L R1,SSALCNCL POINT TO CANCEL ECB. T3082000 TM 0(R1),X'40' IS IT POSTED... T3082500 BZ HALR19 IF NOT, TRY AGAIN TO ALLOCATE. T3083000 LR R2,R13 CANCEL REQUESTED - T3083500 STM R11,R13,12(R2) SAVE REGISTERS 11 - 13 AND T3084000 SETLOCK RELEASE,TYPE=CMS,RELATED=HALR45 UNLOCK FROM CMS. T3084500 SETLOCK RELEASE,TYPE=LOCAL,RELATED=HALR45 CT3085000 RELEASE LOCAL LOCK. T3085500 LM R11,R13,12(R2) RESTORE REGISTERS 11 - 13. T3086000 LA R15,SSALCREQ SHOW CANCEL REQUEST. T3086500 $EPILOG KEY=0 RETURN TO CALLER. T3087000 SPACE 3 T3087500 * T3088000 * BRANCH TO HERE IF UNABLE TO ALLOCATE T3088500 * T3089000 HALR90 DS 0H T3089500 LR R2,R13 SAVE REGISTERS T3090000 STM R11,R13,12(R2) 11 THROUGH 13. T3090500 SETLOCK RELEASE,TYPE=CMS,RELATED=(HALR10,HALR45) UNLOCK CMS. T3091000 SETLOCK RELEASE,TYPE=LOCAL,RELATED=(HALR10,HALR45) CT3091500 RELEASE LOCAL LOCK. T3092000 LM R11,R13,12(R2) RESTORE REGISTERS 11 THROUGH 13. T3092500 LA R15,SSALWTFL SHOW UNABLE TO ALLOCATE. T3093000 $EPILOG KEY=0 RETURN TO CALLER. T3093500 EJECT T3094000 * T3094500 * WE FOUND AN INTERNAL READER. ALLOCATE IT. T3095000 * T3095500 HALR100 DS 0H T3096000 MVC RIDASCBP,PSAAOLD-PSA POINT DCT TO ASCB. T3096500 OI RIDFLAGS,RIDALLOC SHOW INTRDR ALLOCATED. T3097000 * THIS LINE DELETED BY APAR ===> @OZ41586 T3097500 * THIS LINE DELETED BY APAR ===> @OZ41586 T3098000 * T3098500 * RELEASE CMS LOCK T3099000 * T3099500 HALR110 DS 0H T3100000 LR R2,R13 SAVE REGISTERS T3100500 STM R11,R13,12(R2) 11 THROUGH 13. T3101000 SETLOCK RELEASE,TYPE=CMS,RELATED=(HALR10,HALR45) UNLOCK CMS. T3101500 SETLOCK RELEASE,TYPE=LOCAL,RELATED=(HALR10,HALR45) CT3102000 RELEASE LOCAL LOCK. T3102500 LM R11,R13,12(R2) RESTORE REGISTERS 11 THROUGH 13. T3103000 SPACE 2 T3103500 * T3104000 * SET DEFAULT OUTPUT CLASS IN INTRDR T3104500 * T3105000 L R7,SJBJCT POINT TO JCT R4 T3105100 L R1,SSALCLAS POINT TO OUTPUT CLASS. T3105500 LTR R1,R1 IS POINTER ZERO... T3106000 BZ HALR120 IF SO, SET CLASS A. T3106500 MVC DCTMCLAS,0(R1) ELSE SET SPECIFIED CLASS. T3107000 CLI DCTMCLAS,C'$' IF CLASS IS $ T3107500 BE HALR113 OR T3108000 CLI 0(R1),C' ' NULL R41 T3108100 BE HALR113 OR R41 T3108200 CLI DCTMCLAS,C'*' IF CLASS IS *, T3108500 BNE HALR116 T3109000 HALR113 DS 0H T3109500 USING JCTDSECT,R7 JOB'S MSGCLASS= T3110500 MVC DCTMCLAS,JCTMCLAS FOR T3111000 DROP R7 ALLOCATED CLASS. T3111500 HALR116 DS 0H T3112000 CLI DCTMCLAS,C'A' IS CLASS VALID... T3112500 BNL HALR130 BRANCH IF SO. T3113000 HALR120 DS 0H T3113500 MVI DCTMCLAS,C'A' SET CLASS A AS DEFAULT. T3114000 HALR130 DS 0H T3114500 SPACE 2 T3115000 * T3115500 * SET DEFAULT DESTINATION IN INTRDR T3116000 * T3116500 L R1,SSALDEST POINT TO ARG DESTINATION. T3117000 CLC =CL8' ',0(R1) IF NOT ALL BLANKS, T3117500 BNE HALR140 GO CONVERT IT. T3118000 L R1,4(,R13) ELSE POINT TO PREV SAVEAREA T3118500 L R1,24(,R1) & GET CALLER'S REG 1. T3119000 USING SSOB,R1 SET SSOB ADDRESSABILITY. T3119500 L R1,SSOBSSIB POINT TO SSIB. T3120000 USING SSIB,R1 SET SSIB ADDRESSABILITY. T3120500 LA R1,SSIBDEST POINT TO DEFAULT DESTINATION. T3121000 DROP R1 DROP SSIB ADDRESSABILITY. T3121500 HALR140 DS 0H T3122000 SLR R2,R2 CLEAR REGISTER R4 T3122100 IC R2,$SVTOSYS SET DEFAULT FIRST BYTE R4 T3122300 CALL USERDEST CONVERT DESTINATION. T3122800 B HALR190 +0 - INVALID DESTINATION T3123000 * +4 - R2 CONTAINS DESTINATION. T3123500 LTR R2,R2 ANY ROUTE SPECIFIED... R4 T3123600 BNZ HALR145 BR IF YES R4 T3123700 ICM R2,2,$SVTOSYS SET 'LOCAL ' R4 T3123900 SPACE 1 R4 T3124500 HALR145 DS 0H R4 T3124600 STH R2,DCTPRINT SET PRINT AND T3124700 STH R2,DCTPUNCH PUNCH DESTINATIONS T3125000 B HAL975 AND RETURN. T3126000 SPACE 2 T3126500 * INVALID DESTINATION T3127000 HALR190 DS 0H T3127500 NI RIDFLAGS,255-RIDALLOC UNALLOCATE INTRDR. T3128000 LA R15,SSALIDST SET INVALID DESTINATION @OZ20021 T3128500 $EPILOG RETURN @OZ20021 T3128750 DROP R10 DROP DCT BASE. T3129000 EJECT T3129500 * T3130000 * T3130500 * FAILURE IN ALLOCATION T3131000 * T3131500 * T3132000 HAL800 DS 0H T3132500 HALUNSC EQU HAL800 T3133000 LA R15,SSALUNAL SET UNABLE-TO-ALLOCATE. T3133500 B HAL890 RETURN. T3134000 HAL820 DS 0H T3134500 LA R15,SSALIDST SET INVALID DESTINATION. T3135000 SPACE 3 T3135500 HAL890 DS 0H T3136000 LR R2,R15 SAVE RETURN CODE IN R2. T3136500 CALL HCBCK CHECKPOINT MAY BE REQUIRED. T3137000 LR R15,R2 RESTORE RETURN CODE. T3137500 $EPILOG , RETURN. T3138000 SPACE 3 T3138500 * T3139000 * T3139500 * NORMAL EXIT FROM ALLOCATION T3140000 * T3140500 * T3141000 SPACE 1 T3141500 HAL900 DS 0H T3142000 CALL HCBCK CHECKPOINT MARKED BLOCKS. T3142500 SPACE 1 T3143000 HAL950 DS 0H T3143500 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T3144000 L R1,SSALDDNM SAVE DATA SET'S DDNAME T3144500 MVC SDBDDNM,0(R1) IN THE SDB. T3145000 HAL975 DS 0H T3145500 ST RSDB,SSALSSCM POINT SSALSSCM TO SDB/DCT. T3146000 L R1,SSALSSNM GET ADDRESS OF SUBSYSTEM NAME. T3146500 MVC 0(4,R1),$SVSSNM MOVE SUBSYSTEM NAME. T3147000 SLR R15,R15 SHOW NORMAL EXIT. T3147500 $EPILOG , RETURN. T3148000 DROP RIOT,RSIB,RSDB DROP IOT, SSAL, SDB BASES. T3148500 TITLE 'HALCRDSN -- SUBROUTINE TO CREATE DSNAME' T3149000 * T3149500 * ROUTINE NAME - HALCRDSN T3150000 * T3150500 * PURPOSE - TO CREATE AN APPROPRIATE DATA SET NAME FOR AN T3151000 * OUTPUT SUBSYSTEM DATA SET, INCLUDING DATA SET T3151500 * KEY ASSIGNMENT. T3152000 * T3152500 * FUNCTION/OPERATION - T3153000 * 1. MOVE 4-CHARACTER SUBSYSTEM NAME FROM SSVT TO T3153500 * USER AREA. FOLLOW IT WITH A PERIOD. T3154000 * 2. MOVE JOB TYPE (JOB, STC, TSU) FROM SJB TO T3154500 * USER AREA. T3155000 * 3. MOVE NUMERIC JOB ID FROM SJB TO USER AREA, T3155500 * FOLLOWED BY PERIOD, INSURING THAT LEADING T3156000 * BLANKS OF ID BECOME EBCDIC ZEROES. T3156500 * 4. MOVE 'SO' TO USER AREA TO SHOW SYSOUT DATA SET. T3157000 * 5. INCREMENT BY ONE THE JCT'S DATA SET KEY AND T3157500 * SUPPLY THE INCREMENTED VALUE IN EBCDIC TO T3158000 * USER AREA. T3158500 * 6. BLANK OUT THE REMAINING USER AREA AND RETURN. T3159000 * NOTE - THE USER AREA IS TYPICALLY A JFCB AS T3159500 * FURNISHED TO THE 'ALLOCATE' SUBSYSTEM T3160000 * INTERFACE. T3160500 * T3161000 * REGISTERS AT ENTRY - T3161500 * R7 = USER AREA, TYPICALLY A JFCB T3162000 * R11 = SUBSYSTEM VECTOR TABLE T3162500 * R13 = SUBSYSTEM JOB BLOCK T3163000 * R14 = RETURN ADDRESS T3163500 * T3164000 * REGISTER USAGE IN ADDITION TO THE ABOVE - T3164500 * R1 = HASP JCT T3165000 * R2 = WORK REGISTER T3165500 * NOTE - ADDRESSABILITY IS THE SAME AS HOSALLOC T3166000 * T3166500 * REGISTER DIFFERENCES AT EXIT - T3167000 * R1, R2 DESTROYED T3167500 * T3168000 * EXIT - NORMAL - T3168500 * ON R14 T3169000 * T3169500 HALCRDSN DS 0H T3170000 USING INFMJFCB,R7 SET JFCB ADDRESSABILITY. T3170500 MVC DSNSSNM,$SVSSNM SET SUBSYSTEM NAME. T3171000 MVI DSNSSNM+4,C'.' SET PERIOD. T3171500 MVC DSNJBID(3),SJBJOBID SET JOB TYPE. T3172000 PACK SJBDBLWK(3),SJBJOBID+3(5) PACK JOB NUMBER. T3172500 UNPK DSNJBNR,SJBDBLWK(3) UNPACK IT TO USER AREA. T3173000 MVI DSNJBID+8,C'.' SET PERIOD. T3173500 MVC DSNDSTYP,=C'SO' SET 'SO' FOR SYSOUT. T3174000 L R1,SJBJCT POINT TO THE JCT. T3174500 USING JCTDSECT,R1 SET JCT ADDRESSABILITY. T3175000 L R2,JCTPDDBK GET LAST-USED DS KEY. T3175500 AL R2,=FS16'1' ADD 1 TO IT. T3176000 ST R2,JCTPDDBK STORE IT BACK IN THE JCT. T3176500 OI JCTFLAG1,JCT1CKPT REQUIRE JCT CHECKPOINT. T3177000 SRL R2,16 RIGHT-JUSTIFY DS KEY. T3177500 CVD R2,SJBDBLWK CONVERT TO PACKED DECIMAL. T3178000 OI SJBDBLWK+7,X'0F' FORCE ZONE TO ALL ONES. T3178500 UNPK DSNDSNR,SJBDBLWK+5(3) SET DATA SET NUMBER. T3179000 MVI DSNBLANK,C' ' PAD DATA SET NAME T3179500 MVC DSNBLNK1,DSNBLANK WITH BLANKS. T3180000 DROP R1,R7 DROP JCT, JFCB BASES. T3180500 BR R14 RETURN TO CALLER. T3181000 TITLE 'HALFINDP -- SEARCH IOT CHAIN FOR PDDB' T3181500 * T3182000 * T3182500 * HALFINDP -- FIND PDDB IN IOT CHAIN BY DATASET KEY T3183000 * T3183500 * T3184000 * THIS SUBROUTINE OPERATES UNDER HOSALLOC ADDRESSABILITY T3184500 SPACE 1 T3185000 HALFINDP DS 0H T3185500 SL RIOT,=A(IOTIOT-IOTDSECT) SET UP FOR CHAINING. T3186000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3186500 USING SSALBGN,RSOX SET SSOB EXT ADDRESSABILITY. T3187000 L R7,SSALJFCB POINT TO THE DATA SET'S JFCB. T3187500 USING INFMJFCB,R7 SET JFCB ADDRESSABILITY. T3188000 PACK SJBDBLWK,DSNDSNR PACK DATA SET NUMBER. T3188500 CVB R0,SJBDBLWK CONVERT IT TO BINAR. T3189000 HALFP10 DS 0H T3189500 L RIOT,IOTIOT POINT TO THE NEXT IOT. T3190000 LTR RIOT,RIOT IF NO MORE IOTS, T3190500 BZR R14 RETURN CC=0 - PDDB NOT FOUND. T3191000 L R1,IOTPDDBP GET OFFSET AFTER LAST PDDB. T3191500 ALR R1,RIOT MAKE IT ABSOLUTE. T3192000 LR R4,RIOT POINT TO R4 T3192500 AL R4,$SVPDDB1 FIRST PDDB R4 T3192800 USING PDBDSECT,R4 SET PDDB ADDRESSABILITY. T3193000 HALFP20 DS 0H T3193500 CLR R4,R1 ARE WE PAST PDDBS IN IOT... T3194000 BNL HALFP10 BRANCH IF SO. T3194500 CH R0,PDBDSKEY DOES THIS PDDB MATCH DS KEY... T3195000 BE HALFP30 BRANCH IF SO. T3195500 LA R4,PDBLENG(,R4) POINT TO NEXT PDDB. T3196000 B HALFP20 AND CHECK IT. T3196500 HALFP30 DS 0H T3197000 SLR R15,R15 CORRECT PDDB FOUND - T3197500 BR R14 RETURN TO CALLER WITH CC=2. T3198000 SPACE 1 T3198500 DROP RIOT,RSOX,R7,R4 DROP BASES. T3199000 TITLE 'HALJMERG -- SUBROUTINE TO MERGE PDDB FIELDS INTO JFCB' T3199500 * T3200000 * T3200500 * HALJMERG - SUBROUTINE TO MERGE JFCB FIELDS T3201000 * T3201500 * T3202000 SPACE 1 T3202500 HALJMERG DS 0H T3203000 USING PDBDSECT,R4 SET PDDB ADDRESSABILITY. T3203500 USING INFMJFCB,R7 SET JFCB ADDRESSABILITY. T3204000 * MERGE JFCRECFM T3204500 CLI JFCRECFM,0 IF JFCRECFM NOT ZERO, T3205000 BNE HJM020 SKIP MERGE. T3205500 MVC JFCRECFM,PDBRECFM MERGE JFCRECFM. T3206000 * MERGE JFCLRECL AND JFCBLKSI T3206500 HJM020 DS 0H T3207000 SLR R0,R0 ZERO R0 FOR COMPARE. T3207500 LH R1,PDBLRECL GET PDBLRECL IN R1 T3208000 LR R15,R1 (AND R15 FOR JFCBLKSI). T3208500 TM JFCRECFM,JFCUND BR IF R41 T3209000 BO HJM040 RECFM=U R41 T3209300 TM JFCRECFM,JFCVAR BR IF R41 T3209500 BO HJM030 RECFM=V R41 T3209700 OI JFCRECFM,JFCFIX+JFCRFB ELSE FORCE RECFM=FB R41 T3210000 B HJM040 BR TO CONTINUE R41 T3210500 HJM030 DS 0H R41 T3210700 LA R1,4(,R1) VARIABLE. SET LRECL, BLKSI T3211000 LA R15,4(,R1) SET BLKSI = LRECL+4. T3213000 HJM040 DS 0H T3213500 CH R0,JFCLRECL IF JFCLRECL NOT ZERO, T3214000 BNE *+8 DON'T MERGE. T3214100 STH R1,JFCLRECL MERGE JFCLRECL. T3214200 CH R0,JFCBLKSI IF JFCBLKSI NOT ZERO, T3214300 BNE HJM080 DON'T MERGE. T3214400 STH R15,JFCBLKSI MERGE JFCBLKSI. T3214500 * MERGE JFCFCBID T3215000 HJM080 DS 0H T3215500 L R0,JFCFCBID IF JFCFCBID T3216000 LTR R0,R0 IS NOT ZERO, T3216500 BNZ HJM100 DON'T MERGE. T3217000 MVC JFCFCBID,PDBFCB MERGE JFCFCBID. T3217500 * MERGE JFCUCSID T3218000 HJM100 DS 0H T3218500 L R0,JFCUCSID IF JFCUCSID T3219000 LTR R0,R0 IS NOT ZERO, T3219500 BNZ HJM120 DON'T MERGE. T3220000 MVC JFCUCSID,PDBUCS MERGE JFCUCSID. T3220500 * MERGE JFCFUNC T3221000 HJM120 DS 0H T3221500 CLI JFCFUNC,0 IF JFCFUNC IS NONZERO, T3222000 BNE HJM140 DON'T MERGE. T3222500 MVC JFCFUNC,PDBFUNC MERGE JFCFUNC. T3223000 * THAT'S ALL THE MERGES. T3223500 HJM140 DS 0H T3224000 BR R14 RETURN. T3224500 DROP R4,R7 DROP PDDB, JFCB BASES. T3225000 TITLE 'HALCRIOT -- SUBROUTINE TO FORMAT AN IOT' T3225500 * T3226000 * T3226500 * HALCRIOT -- SUBROUTINE TO FORMAT AN IOT T3227000 * T3227500 * T3228000 SPACE 1 T3228500 HALCRIOT DS 0H T3229000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3229500 USING *,R12 SET LOCAL ADDRESSABILITY. T3230000 STM R14,R12,12(R13) SAVE REGISTERS. T3230500 LR R12,R15 SET LOCAL BASE. T3231000 SPACE 3 T3231500 * T3232000 * CLEAR FIRST PART OF IOT T3232500 * T3233000 SPACE 1 T3233500 LR R0,RIOT SET MVCL TO-ADDRESS. T3234000 L R4,0(,RIOT) SAVE GETMAIN TCB ADDRESS R4 T3234100 L R1,$SVPDDB1 CLEAR TO START OF 1ST PDDB R4 T3234500 SLR R3,R3 CAUSE CLEAR TO ZEROES. T3235000 MVCL R0,R2 CLEAR FIRST PART OF IOT. T3235500 ST R4,0(,RIOT) RESTORE GETMAIN TCB ADDRESS R4 T3235600 SPACE 3 T3236000 * T3236500 * SET FIELDS IN IOT T3237000 * T3237500 SPACE 1 T3238000 MVC IOTID,=CL4'IOT' SET IOTID. T3238500 LH R15,$SVBFSIZ SET R4 T3238800 LA R15,IOTSTART-IOTDSECT(,R15) IOT R4 T3239000 STH R15,IOTLENG LENGTH. R4 T3239300 MVI IOTFLAG1,IOT1CKPT FLAG IOT FOR CHECKPOINT. T3239500 MVC IOTJBKEY,SJBJKEY SET IOTJBKEY. T3240000 MVC IOTTRACK,24(R13) SET IOTTRACK. T3240500 * CHAINING POINTERS IOTIOTTR AND IOTIOT WILL BE SET DURING T3241000 * CHAINING IN SUBROUTINE HALCHIOT T3241500 ST RSJB,IOTSJB SET IOTSJB. T3242000 L R0,$SVPDDB1 SET OFFSET TO 1ST PDDB IN R4 T3242500 ST R0,IOTPDDBP IOTPDDBP. T3243000 SPACE 3 T3243500 * T3244000 * FURTHER SET IOTFLAG1 T3244500 * T3245000 SPACE 1 T3245500 USING SSALBGN,RSOX SET SSAL ADDRESSABILITY. T3246000 TM SSALFLG1,SSALHOLD+SSALTRKM+SSALSPIN IF SPECIAL, T3246500 BNZ HALCRI20 GO CHANGE FLAGS. T3247000 CALL HALCLASS IF NOT SCATHOLD, T3247500 BZ HALCRI90 LEAVE FLAGS ALONE. T3248000 HALCRI20 DS 0H T3248500 TM SJBFLG1,SJB1XBM IF BATCH MONITOR, @OZ28238 T3248600 BO HALCRI90 TREAT AS NON-SPIN/HOLD @OZ28238 T3248700 OI IOTFLAG1,IOT1SPIN INDICATE SPIN IOT. T3249000 TM SSALFLG1,SSALTRKM IF NEW TRACK MAP NEEDED, T3249500 BZ HALCRI90 THEN T3250000 OI IOTFLAG1,IOT1ALOC SET IOT1ALOC. T3250500 SPACE 3 T3251000 * T3251500 * RETURN TO CALLER T3252000 * T3252500 SPACE 1 T3253000 HALCRI90 DS 0H T3253500 OI IOTMSTAB+(TABFLAG-TABDSECT),TABMASTR SETUP MSTR TAB R4 T3253600 LM R14,R12,12(R13) RESTORE REGISTERS. T3254000 BR R14 RETURN. T3254500 DROP RIOT,RSOX DROP IOT, SSAL BASES. T3255000 TITLE 'HALCHIOT -- SUBROUTINE TO CHAIN AN IOT' T3255500 * T3256000 * T3256500 * HALCHIOT -- SUBROUTINE TO CHAIN AN IOT T3257000 * T3257500 * T3258000 SPACE 1 T3258500 HALCHIOT DS 0H T3259000 USING *,R12 SET LOCAL ADDRESSABILITY. T3259500 STM R14,R12,12(R13) SAVE REGISTERS. T3260000 LR R12,R15 SET LOCAL BASE. T3260500 SPACE 3 T3261000 * T3261500 * DECIDE WHICH TYPE OF CHAINING TO DO T3262000 * T3262500 SPACE 1 T3263000 L R7,SJBJCT POINT TO HASP JCT. T3263500 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T3264000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3264500 TM IOTFLAG1,IOT1SPIN IF SPIN IOT, T3265000 BO HALCHI50 GO CHAIN IT. T3265500 SPACE 3 T3266000 * T3266500 * CHAIN REGULAR IOT FIFO T3267000 * T3267500 SPACE 1 T3268000 L R1,SJBIOT POINT TO THE 1ST IOT. T3268500 HALCHI10 DS 0H T3269000 LR R2,R1 SAVE PREVIOUS IOT POINTER. T3269500 L R1,IOTIOT-IOTDSECT(,R1) POINT TO NEXT IOT. T3270000 LTR R1,R1 IF IT EXISTS, T3270500 BNZ HALCHI10 LOOP TILL END OF CHAIN. T3271000 SLR R0,R0 ZERO OUT T3271500 ST R0,IOTIOT IOTIOT T3272000 ST R0,IOTIOTTR AND IOTIOTTR. T3272500 MVC IOTIOTTR-IOTDSECT(,R2),IOTTRACK CHAIN AUX STOR. T3273000 ST RIOT,IOTIOT-IOTDSECT(,R2) CHAIN MAIN STORAGE. T3273500 OI IOTFLAG1-IOTDSECT(R2),IOT1CKPT CKPT PREV IOT. T3274000 B HALCHI90 RETURN. T3274500 SPACE 3 T3275000 * T3275500 * CHAIN SPIN IOT LIFO T3276000 * T3276500 SPACE 1 T3277000 HALCHI50 DS 0H T3277500 MVC IOTIOT,SJBSPIOT POINT THIS IOT TO NEXT. T3278000 ST RIOT,SJBSPIOT POINT HEADER TO THIS. T3278500 MVC IOTIOTTR,JCTSPIOT DO THE SAME FOR T3279000 MVC JCTSPIOT,IOTTRACK AUXILIARY STORAGE CHAIN. T3279500 OI JCTFLAG1,JCT1CKPT REQUIRE JCT CHECKPOINT. T3280000 SPACE 3 T3280500 * T3281000 * RETURN TO CALLER T3281500 * T3282000 SPACE 1 T3282500 HALCHI90 DS 0H T3283000 OI IOTFLAG1,IOT1CKPT REQUIRE IOT CHECKPOINT. T3283500 LM R14,R12,12(R13) RESTORE REGISTERS. T3284000 BR R14 RETURN. T3284500 DROP RIOT,R7 DROP IOT, JCT BASES. T3285000 TITLE 'HALCRPDB -- SUBROUTINE TO CREATE A PDDB' T3285500 HALCRPDB DS 0H T3286000 * T3286500 * T3287000 * CREATE PERIPHERAL DATASET DEFINITION BLOCK (PDDB) T3287500 * T3288000 * T3288500 USING *,R12 SET LOCAL ADDRESSABILITY. T3289000 STM R14,R12,12(R13) SAVE REGISTERS. T3289500 LR R12,R15 SET LOCAL BASE. T3290000 * SEE IF THERE'S ENOUGH SPACE IN THE IOT TO HOLD A PDDB T3290500 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3291500 L R6,IOTPDDBP GET OFFSET PAST LAST PDDB. T3292000 LA R15,PDBLENG(,R6) IF NO ROOM R4 T3292500 CH R15,IOTLENG FOR MAX PDDB, R4 T3292800 BH HCP800 RETURN CC=2 TO GET IOT. T3293000 * MOVE MAXIMUM-LENGTH PDDB BUT DON'T SET IOTPDDBP YET. T3293500 ALR R6,RIOT COMPUTE ABSOLUTE PDDB ADDRESS. T3294000 MVC 0(PDBLENG,R6),HALPDDB MOVE MODEL PDDB. T3294500 * IF SSOB EXTENSION EXISTS, VERIFY USER ID T3295000 USING SSALBGN,RSOX SET SSOB EXT ADDRESSABILITY. T3297000 L R1,SJBJCT POINT TO JCT R4 T3297100 SLR R2,R2 SET DEFAULT R4 T3297200 IC R2,JCTROUTE-JCTDSECT(R1) GET DEFAULT FIRST BYTE R4 T3297400 L R1,SSALDEST GET DESTINATION POINTER. T3297800 * FOLLOWING CALL DESTROYS R0,R1,R2,R3,R14,R15 T3298000 CALL USERDEST VALIDIFY AND COMPRESS DEST. T3298500 B HCP810 +0 - INVALID DESTINATION T3299000 * +4 - R2 CONTAINS DESTINATION T3299500 HCP100 DS 0H T3300000 * THIS LINE DELETED BY APAR NUMBER @OZ47891 T3301000 * THIS LINE DELETED BY APAR NUMBER @OZ47891 T3302000 * THIS LINE DELETED BY APAR NUMBER @OZ47891 T3303000 USING PDBDSECT,R6 SET NEW PDDB ADDRESSABILITY. T3304000 SPACE 1 @OZ39639 T3305000 * SET INDICATION IF JESNEWS DATA SET @OZ39639 T3305010 TM IOTFLAG1,IOT1NEWS IF JESNEWS DATA SET... @OZ39639 T3305020 BZ *+8 SET FLAG AND FORCE TRACK- @OZ39639 T3305030 OI PDBFLAG2,PDB2NEWS+PDB2TCEL CELL SPOOLING @OZ39639 T3305040 SPACE 1 @OZ39639 T3305050 * T3305500 * SET PDDB FROM SSOB EXTENSION T3306000 * T3306500 * SET FORMS IDENTIFIER UNLESS ARGUMENT IS ZERO T3308000 L R1,SSALFORM GET POINTER TO FORMS ID. T3308500 MVC PDBSSOFM,0(R1) SAVE FOR CHANGE AT UNALLOC @OZ47891 T3308600 L R1,0(,R1) GET FORMS ID. T3309000 CL R1,=CL4' ' IF BLANK FORMS, T3309500 BE *+8 DON'T USE IT. T3310000 ST R1,PDBFORMS ELSE STORE IT IN PDBFORMS. T3310500 * SET FORMS CONTROL BUFFER IDENTIFIER UNLESS ZERO T3311000 L R7,SSALJFCB POINT TO JFCB. T3311500 USING INFMJFCB,R7 SET JFCB ADDRESSABILITY. T3312000 L R1,JFCFCBID GET FORMS CONTROL BUFFER ID. T3312500 LTR R1,R1 IF ZERO, T3313000 BZ *+14 DON'T USE IT. T3313500 ST R1,PDBFCB ELSE STORE IT IN PDBFCB. T3314000 OC PDBFCB,=X'40404040' SET BINARY ZEROES TO BLANKS. T3314500 * SET UNIVERSAL CHARACTER SET IDENTIFIER UNLESS ZERO T3315000 L R1,JFCUCSID GET UNIV CHAR SET ID. T3315500 LTR R1,R1 IF ZERO, T3316000 BZ *+14 DON'T USE IT. T3316500 ST R1,PDBUCS ELSE STORE IT IN PDBUCS. T3317000 OC PDBUCS,=X'40404040' SET BINARY ZEROES TO BLANKS. T3317500 * SET 3525 FUNCTION BYTE IRREGARDFUL T3318000 MVC PDBFUNC,JFCFUNC SET PDBFUNC. T3318500 * SET DESTINATION, COMPUTED EARLIER, NOW IN R2 T3319000 STH R2,PDBDEST SET DESTINATION. T3319500 * SET COPY COUNT UNLESS ZERO T3320000 L R1,SSALCOPY POINT TO COPIES= PARM. T3320500 CLI 0(R1),0 TEST COPY COUNT. T3321000 BE *+10 BR IF NONE PROVIDED. T3321500 MVC PDBCOPYS,0(R1) ELSE SET COPIES. T3322000 * CHECK FOR DSID APPENDED TO DSNAME @Y30O T3322100 LA R1,DSNDSID+L'DSNDSID POINT TO DSID EXTENSION R4 T3322200 CLI 0(R1),C'.' WAS DSID APPENDED... R4 T3322300 BNE HCP200 BR IF NO TO TEST FOR WTRID R4 T3322400 * MOVE DSID TO PDDB @Y30O T3322500 MVC PDBDSID,1(R1) MOVE DSID(+ BLANKS) TO PDDB @Y30O T3322600 MVI 0(R1),C' ' CLEAR DSID EXTENSION INDICATOR R4 T3322700 MVC 1(8,R1),0(R1) BLANK OUT DSID IN DSNAME @Y30O T3322800 OC PDBDSID,0(R1) ENSURE DSID PADDED WITH BLANKS R4 T3322900 * FLAG PDDB FOR SPECIAL HANDLING @Y30O T3323000 OI PDBFLAG1,PDB1DSID+PDB1HOLD+PDB1PSO DSID/HOLD/PSO@Y30O T3323100 B HCP300 BYPASS WTRID TEST @Y30O T3323200 * SET USER WRITER IDENTIFIER (WHETHER OR NOT ZERO) R4 T3323300 HCP200 DS 0H R4 T3323400 L R1,SSALPGMN POINT TO USER WRITER NAME. T3323500 MVC PDBWTRID,0(R1) MOVE IT TO PDBWTRID. T3323600 EJECT R4 T3323700 HCP300 DS 0H T3324000 TM JFCOPTCD,JFCOPTJ TEST FOR 3800 OPTCD=J R41 T3324100 BZ HCPBURST BR IF NO R41 T3324200 OI PDBFLAG2,PDB2OPTJ ELSE, SET FLAG IN PDDB R4 T3324300 HCPBURST L R1,SJBJCT POINT TO JCT -- TEST JOB'S R41 T3324400 TM JCTFLAG1-JCTDSECT(R1),JCTBURST BURST DEFAULT... R41 T3324500 BZ *+8 BR IF BURST=N R41 T3324600 OI PDBFLAG2,PDB2BRST ELSE SET BURST=Y IN PDDB R41 T3324700 TM JFCUCSOP,JFCBEXTP TEST FOR 3800 EXTENSION R41 T3324800 BNO HCP310 BR IF NOT - END MERGE R4 T3324900 SPACE 1 R4 T3325000 L R7,JFCBEXAD-1 ESTABLISH JFCB R4 T3325100 USING JFCBE-16,R7 EXTENSION ADDRESSABILITY R4 T3325200 SPACE 1 R4 T3325300 * SET 3800 BURSTER SPECIFICATION R4 T3325400 TM JFCBFLAG,JFCBBST+JFCBCFS INDICATE IF B=Y OR N @OZ55601 T3325420 BZ SKIP120 IS SPECIFIED ON @OZ55601 T3325440 OI PDBFLAG3,PDB3BRST DD STATEMENT @OZ55601 T3325460 TM JFCBFLAG,JFCBBST TEST FOR BURST=YES ON DD R4 T3325500 BNO *+8 BR IF NOT R41 T3325600 OI PDBFLAG2,PDB2BRST ELSE, SET BURST=YES IN PDDB R4 T3325700 TM JFCBFLAG,JFCBCFS TEST FOR BURST=N ON DD R41 T3325800 BZ *+8 BR IF NOT R41 T3325900 NI PDBFLAG2,255-PDB2BRST ELSE SET BURST=N IN PDDB R41 T3326000 * SET 3800 COPY MODIFICATION IMAGE ID AND TABLE REF CHAR R4 T3326100 SKIP120 L R1,JFCMODIF GET MODIFY PARAMETER R4 T3326200 CL R1,=X'40404040' SET CHARS FROM JFCMODIF TO @OZ34625 T3326210 BE HCPFLSH PDBMODF IF SPECIFIED @OZ34625 T3326220 LTR R1,R1 TEST FOR NOT SPECIFIED R4 T3326300 BZ HCPFLSH BRANCH IF NOT SPECIFIED @OZ34625 T3326400 ST R1,PDBMODF ELSE, SET PDBMODF R4 T3326500 OC PDBMODF,=X'40404040' CONVERT BINARY ZEROS TO BLANKS R4 T3326600 MVC PDBMODFT,JFCIDTRC SET PDBMODFT R4 T3326700 * SET 3800 FLASH FRAME ID AND FLASH COUNT R4 T3326800 HCPFLSH DS 0H R4 T3326900 L R1,JFCBMAGT GET FLASH PARAMETER R4 T3327000 CL R1,=X'40404040' CHARS FROM @OZ36611 T3327030 BE HCPCHARS JFCB TO @OZ36611 T3327060 LTR R1,R1 TEST FOR FLASH SPECIFIED R4 T3327100 BZ HCPCHARS BR IF NOT SPECIFIED @OZ36611 T3327200 ST R1,PDBFLASH ELSE, SET PDBFLASH R4 T3327300 OC PDBFLASH,=X'40404040' CONVERT BINARY ZEROS TO BLANKS R4 T3327400 ICM R1,1,JFCIMTOT SET FLASH R41 T3327500 BZ HCPCHARS COUNT IF R41 T3327600 STC R1,PDBFLSHC SPECIFIED R41 T3327700 * SET 3800 CHAR1, CHAR2, CHAR3, CHAR4 R4 T3327800 HCPCHARS DS 0H R4 T3327900 L R1,JFCBTRS1 SET R4 T3328000 CL R1,=X'40404040' CHARS FROM @OZ30543 T3328010 BE SKIP130 JFCB TO @OZ30543 T3328020 LTR R1,R1 PDBCHAR1 R4 T3328100 BZ SKIP130 IF @OZ30543 T3328200 ST R1,PDBCHAR1 SPECIFIED R4 T3328300 OC PDBCHAR1,=X'40404040' AND CNVRT ZEROS TO BLANKS R4 T3328400 SKIP130 L R1,JFCBTRS2 SET R4 T3328500 CL R1,=X'40404040' CHARS FROM @OZ30543 T3328510 BE SKIP140 JFCB TO @OZ30543 T3328520 LTR R1,R1 PDBCHAR2 R4 T3328600 BZ SKIP140 IF @OZ30543 T3328700 ST R1,PDBCHAR2 SPECIFIED R4 T3328800 OC PDBCHAR2,=X'40404040' AND CNVRT ZEROS TO BLANKS R4 T3328900 SKIP140 L R1,JFCBTRS3 SET R4 T3329000 CL R1,=X'40404040' CHARS FROM @OZ30543 T3329010 BE SKIP150 JFCB TO @OZ30543 T3329020 LTR R1,R1 PDBCHAR3 R4 T3329100 BZ SKIP150 IF @OZ30543 T3329200 ST R1,PDBCHAR3 SPECIFIED R4 T3329300 OC PDBCHAR3,=X'40404040' AND CNVRT ZEROS TO BLANKS R4 T3329400 SKIP150 L R1,JFCBTRS4 SET R4 T3329500 CL R1,=X'40404040' CHARS FROM @OZ30543 T3329510 BE SKIP160 JFCB TO @OZ30543 T3329520 LTR R1,R1 PDBCHAR4 R4 T3329600 BZ SKIP160 IF @OZ30543 T3329700 ST R1,PDBCHAR4 SPECIFIED R4 T3329800 OC PDBCHAR4,=X'40404040' AND CNVRT ZEROS TO BLANKS R4 T3329900 * SET 3800 COPY GROUPS R4 T3330000 SKIP160 MVC PDBCOPYG,JFCGROUP SET PDBCOPYG R4 T3330100 * END OF JFCB-TO-PDDB MERGE R4 T3330200 EJECT R4 T3330300 HCP310 DS 0H R4 T3330400 * END OF PDDB SETUP FROM SSOB EXTENSION AND JFCB T3330500 SPACE 1 R41 T3330600 L R7,SSALJFCB RESTORE JFCB R41 T3330700 USING INFMJFCB,R7 ADDRESSABILITY R41 T3330800 SPACE 3 T3330900 * T3331000 * SEARCH FOR OUTPUT CTRL RECORD TO MATCH PDBFORMS T3331100 * T3331200 SLR R3,R3 ASSUME NO OCR @OZ27530 T3331250 TM PDBFLAG2,PDB2NEWS JESNEWS DATA SET... @OZ39639 T3331260 BO HCP495 BR TO IGNORE OCR IF YES @OZ39639 T3331270 ICM R0,15,PDBFORMS GET FORMS NUMBER FROM PDDB. T3331300 BZ HCP495 BR IF NONE PROVIDED @OZ27530 T3331400 * SET UP TO CHAIN OUTPUT CONTROL TABLES T3331500 LA R3,SJBOCT POINT TO OCT POINTER, T3331600 SL R3,=A(OCTOCT-OCTDSECT) SUBTRACT CHAIN OFFSET. T3331700 USING OCTDSECT,R3 SET OCT ADDRESSABILITY. T3331800 * POINT TO THE NEXT OUTPUT CONTROL TABLE T3331900 HCP320 DS 0H T3332000 L R3,OCTOCT POINT TO NEXT OCT. T3332100 LTR R3,R3 IF NO MORE, SEARCH FAILED - T3332500 BZ HCP495 SKIP OCR PROCESSING R41 T3333000 * SET UP TO SEARCH OUTPUT CONTROL RECORDS T3333500 L R1,OCTOCROF GET OFFSET TO LAST OCR. T3334000 ALR R1,R3 MAKE IT ABSOLUTE. T3334500 LA R2,OCTOCR POINT TO FIRST OCR. T3335000 * CHECK NEXT OCR IF IT EXISTS T3335500 HCP340 DS 0H T3336000 CLR R2,R1 ARE THERE MORE OCRS... T3336500 BNL HCP320 IF NOT, GO TO NEXT OCT. T3337000 USING OCRDSECT,R2 SET OCR ADDRESSABILITY. T3337500 CL R0,OCRCODE DOES OCR CODE MATCH FORMS... T3338000 BE HCP400 YES. THIS IS THE ONE. T3338500 LA R2,OCREND NO. POINT TO NEXT OCR AND T3339000 B HCP340 TEST IF IT IS ONE. T3339500 SPACE 1 T3340000 DROP R3 DROP OCT ADDRESSABILITY. T3340500 EJECT R4 T3340600 * MATCHING OCR IS FOUND - MERGE STARTS HERE T3341000 HCP400 DS 0H T3341500 * MERGE OCRFORMS INTO PDBFORMS T3342000 * THIS LINE DELETED BY APAR NUMBER @OZ47891 T3342500 L R0,OCRFORMS GET OCR FORMS ID T3343000 ST R0,PDBFORMS SET PDBFORMS T3343500 * THIS LINE DELETED BY APAR NUMBER @OZ47891 T3344000 * MERGE OCRFCB INTO PDBFCB AND INTO JFCFCBID T3344500 L R1,OCRFCB GET OCR FORMS CTRL BUFFER ID. T3345000 LTR R1,R1 IF NO OCR FCB, T3345500 BZ *+12 SKIP. T3346000 ST R1,PDBFCB SET PDBFCB. T3346500 ST R1,JFCFCBID SET JFCFCBID. T3347000 * MERGE OCRUCS INTO PDBUCS AND INTO JFCUCSID T3347500 L R1,OCRUCS GET OCR UNIVERSAL CHAR SET ID. T3348000 LTR R1,R1 IF NO OCR UCS, T3348500 BZ *+12 SKIP. T3349000 ST R1,PDBUCS SET PDBUCS. T3349500 ST R1,JFCUCSID SET JFCUCSID. T3350000 * MERGE OCRRECNT INTO PDBRECCT T3350500 L R1,OCRRECNT GET OCR RECORD COUNT FIELD. T3351000 LTR R1,R1 IF IT IS ZERO, T3351500 BZ *+8 SKIP. T3352000 ST R1,PDBRECCT SET PDBRECCT. T3352500 * MERGE OCRINDEX INTO PDBINDEX T3353000 ICM R1,8,OCRINDEX GET OCR 3211 PRINT INDEX. T3353500 BZ *+8 IF IT IS ZERO, SKIP. T3354000 STCM R1,8,PDBINDEX SET PDBINDEX. T3354500 * MERGE OCRCPTN INTO PDBCPTN R41 T3354600 MVC PDBCPTN(1),OCRCPTN SET PDBCPTN R41 T3354700 * MERGE OCRCKPTP AND OCRCKPTL INTO PDBCKPTP AND PDBCKPTL @OZ19494 T3354880 MVC PDBCKPTP,OCRCKPTP SET LOGICAL PAGE/CKPT SIZE @OZ19494 T3354900 MVC PDBCKPTL,OCRCKPTL SET LINES/LOGICAL PAGE SIZE @OZ19494 T3354920 * MERGE OCRDEST1 INTO PDBDEST T3355000 LH R1,OCRDEST1 GET FIRST OCR DESTINATION. T3355500 LTR R1,R1 IF IT'S DEFAULT, R4 T3356000 BE HCP480 BRANCH. T3356500 STH R1,PDBDEST SET PDBDEST. T3357000 L R1,SSALDEST AND CLEAR DEST FIELD @OZ47891 T3357100 MVC 0(8,R1),=CL8' ' POINTED TO BY SSOB. @OZ47891 T3357200 LH R1,OCRDEST2 PICK UP 2D OCR DESTINATION. T3357500 LTR R1,R1 IF IT'S DEFAULT, R4 T3358000 BE HCP480 ONLY ONE DESTINATION. T3358500 OI PDBFLAG1,PDB1MDES ELSE SET FLAG PDB1MDES. T3359000 L R1,SJBJCT POINT TO THE JCT T3359500 USING JCTDSECT,R1 AND GET ADDRESSABILITY. T3360000 MVC JCTWORK(8),OCRDEST1 MOVE 4 DESTS TO JCTWORK. T3360500 MVC JCTWORK+8(2),=X'0000' MOVE TERMINATOR. R4 T3361000 DROP R1 DROP JCT ADDRESSABILITY. T3361500 HCP480 DS 0H T3362000 * MERGE OCRCOPY INTO PDBCOPYS T3362500 ICM R1,8,OCRCOPY GET OCR COPY COUNTER. T3363000 BZ *+8 IF IT IS ZERO, SKIP. T3363500 STCM R1,8,PDBCOPYS SET PDBCOPYS. T3364000 EJECT R4 T3364100 * R4 T3364200 * MERGE 3800 OCR FIELDS WITH PDDB R4 T3364300 * R4 T3364400 * MERGE OCRFLAGS(BURST) INTO PDBFLAG2 R4 T3364500 TM OCRFLAGS,OCRBRSTY TEST FOR BURST=YES IN OCR R4 T3364600 BZ SKIP170 BR IF NOT R4 T3364700 OI PDBFLAG2,PDB2BRST SET PDBFLAG2(PDB2BRST) R4 T3364800 SKIP170 TM OCRFLAGS,OCRBRSTN TEST FOR BURST=NO IN OCR R4 T3364900 BZ SKIP180 BR IF NOT R4 T3365000 NI PDBFLAG2,255-PDB2BRST RESET PDBFLAG2(PDB2BRST) R4 T3365100 * MERGE OCRMODF/OCRMODFT INTO PDBMODF/PDBMODFT R4 T3365200 SKIP180 L R1,OCRMODF GET OCR MODIFY IMAGE ID R4 T3365300 LTR R1,R1 TEST FOR SPECIFIED R4 T3365400 BZ HCP490 BR IF NOT R4 T3365500 ST R1,PDBMODF SET PDBMODF R4 T3365600 ICM R1,1,OCRMODFT GET OCR COPY MOD TRC R4 T3365700 BZ HCP490 BR IF NOT SPECIFIED R4 T3365800 STC R1,PDBMODFT SET PDBMODFT R4 T3365900 HCP490 DS 0H R4 T3366000 * MERGE OCRFLASH/OCRFLSHC INTO PDBFLASH/PDBFLSHC R4 T3366100 L R1,OCRFLASH GET OCR FLASH FRAME ID R4 T3366200 LTR R1,R1 TEST FOR SPECIFIED R4 T3366300 BZ HCP492 BR IF NOT R4 T3366400 ST R1,PDBFLASH SET PDBFLASH R4 T3366500 ICM R1,1,OCRFLSHC GET OCR FLASH COUNT R4 T3366600 BZ HCP492 BR IF NOT SPECIFIED R4 T3366700 STC R1,PDBFLSHC SET PDBFLSHC R4 T3366800 HCP492 DS 0H R4 T3366900 * MERGE OCRCHAR1-4 INTO PDBCHAR1-4 R4 T3367000 L R1,OCRCHAR1 GET OCR CHAR1 R4 T3367100 LTR R1,R1 TEST FOR SPECIFIED R4 T3367200 BZ HCP494 BR IF NOT R4 T3367300 ST R1,PDBCHAR1 SET PDBCHAR1 R4 T3367400 L R1,OCRCHAR2 GET OCR CHAR2 R4 T3367500 LTR R1,R1 TEST FOR SPECIFIED R4 T3367600 BZ HCP494 BR IF NOT R4 T3367700 ST R1,PDBCHAR2 SET PDBCHAR2 R4 T3367800 L R1,OCRCHAR3 GET OCR CHAR3 R4 T3367900 LTR R1,R1 TEST FOR SPECIFIED R4 T3368000 BZ HCP494 BR IF NOT R4 T3368100 ST R1,PDBCHAR3 SET PDBCHAR3 R4 T3368200 L R1,OCRCHAR4 GET OCR CHAR4 R4 T3368300 LTR R1,R1 TEST FOR SPECIFIED R4 T3368400 BZ HCP494 BR IF NOT R4 T3368500 ST R1,PDBCHAR4 SET PDBCHAR4 R4 T3368600 HCP494 DS 0H R4 T3368700 * MERGE OCRCOPYG INTO PDBCOPYG R4 T3368800 CLI OCRCOPYG,0 TEST FOR SPECIFIED R4 T3368900 BZ HCP495 BR IF NOT R4 T3369000 MVC PDBCOPYG,OCRCOPYG SET PDBCOPYG R4 T3369100 EJECT R4 T3369200 * R4 T3369300 * IF JFCB EXTENSION EXISTS - MERGE-BACK PDDB TO JFCB R4 T3369400 * R4 T3369500 SPACE 1 R4 T3369600 HCP495 TM JFCUCSOP,JFCBEXTP TEST FOR 3800 EXTENSION R41 T3369700 BZ HCP500 BR IF NOT - END MERGE R4 T3369800 L R7,JFCBEXAD-1 ESTABLISH JFCB R4 T3369900 USING JFCBE-16,R7 EXTENSION ADDRESSABILITY R4 T3370000 SPACE 1 R4 T3370100 * MERGE PDBFLAG (BURST) INTO JFCBFLAG R4 T3370200 TM PDBFLAG2,PDB2BRST TEST FOR BURST=YES R4 T3370300 BZ HCP496 BR IF NO R4 T3370400 OI JFCBFLAG,JFCBBST INDICATE BURST=YES R4 T3370500 NI JFCBFLAG,255-JFCBCFS IN JFCB R4 T3370600 B HCP497 AND BR TO CONTINUE R41 T3370700 HCP496 OI JFCBFLAG,JFCBCFS INDICATE BURST=NO R4 T3370800 NI JFCBFLAG,255-JFCBBST IN JFCB R4 T3370900 * MERGE PDBFLSHC INTO JFCIMTOT @OZ53399 T3370950 HCP497 MVC JFCIMTOT,PDBFLSHC MOVE FLASH COUNT @OZ53399 T3371000 LTR R3,R3 TEST FOR OCR PRESENT @OZ53399 T3371050 BZ HCP500 END MERGE IF NOT R41 T3371100 * MERGE PDBMODF/PDBMODFT INTO JFCMODIF/JFCIDTRC R4 T3371200 HCP498 CLC PDBMODF,=C'****' WAS MODIFY SPECIFIED... R4 T3371300 BE SKIP200 BR IF NOT R4 T3371400 MVC JFCMODIF,PDBMODF MOVE COPY MOD ID R4 T3371500 MVC JFCIDTRC,PDBMODFT MOVE COPY MOD TRC R4 T3371600 * MERGE PDBFLASH INTO JFCBMAGT @OZ53399 T3371700 SKIP200 CLC PDBFLASH,=C'****' TEST FOR FLASH SPECIFIED R4 T3371800 BE SKIP210 BR IF NOT R4 T3371900 MVC JFCBMAGT,PDBFLASH MOVE FLASH FRAME ID R4 T3372000 * THIS LINE DELETED BY APAR NUMBER @OZ53399 T3372100 * MERGE PDBCHAR1-4 INTO JFCBTRS1-4 R4 T3372200 SKIP210 CLC PDBCHAR1,=C'****' MERGE CHAR1 R4 T3372300 BE SKIP220 IF R4 T3372400 MVC JFCBTRS1,PDBCHAR1 SPECIFIED R4 T3372500 SKIP220 CLC PDBCHAR2,=C'****' MERGE CHAR2 R4 T3372600 BE SKIP230 IF R4 T3372700 MVC JFCBTRS2,PDBCHAR2 SPECIFIED R4 T3372800 SKIP230 CLC PDBCHAR3,=C'****' MERGE CHAR3 R4 T3372900 BE SKIP240 IF R4 T3373000 MVC JFCBTRS3,PDBCHAR3 SPECIFIED R4 T3373100 SKIP240 CLC PDBCHAR4,=C'****' MERGE CHAR4 R4 T3373200 BE SKIP250 IF R4 T3373300 MVC JFCBTRS4,PDBCHAR4 SPECIFIED R4 T3373400 * MERGE PDBCOPYG INTO JFCGROUP R4 T3373500 SKIP250 CLI PDBCOPYG,0 TEST FOR SPECIFIED R4 T3373600 BE HCP500 BR IF NOT R4 T3373700 MVC JFCGROUP,PDBCOPYG MOVE IN COPY GROUPS R4 T3373800 SPACE 1 R4 T3373900 DROP R7 SUSPEND JFCBE ADDRESSABILITY R4 T3374000 SPACE 2 R4 T3374100 HCP500 DS 0H R4 T3374200 EJECT R4 T3374300 SPACE 3 T3374400 * T3374500 * T3374600 * SET CLASS, DATA SET KEY, FLAGS T3374700 * T3374800 * T3374900 CALL HALCLASS GET CLASS, SCATHOLD STATUS. T3375000 STC R2,PDBCLASS SET CLASS INTO PDDB. T3375100 BZ *+16 IF NOT SCATHOLD, SKIP. T3375200 TM SJBFLG1,SJB1XBM IF BATCH MONITOR JOB, T3375300 BO *+8 SKIP. T3375400 OI PDBFLAG1,PDB1HOLD SET HOLD FLAG IN PDDB. T3375500 TM SCATFLAG-SCADSECT(R1),SCATDUMM Q. DUMMY CLASS T3375600 BZ *+8 BR. IF NO T3375700 OI PDBFLAG1,PDB1NSOT MARK AS DUMMY T3375800 TM SCATFLAG-SCADSECT(R1),SCATTCEL TRAKCELL SYSOUT CLASS R4 T3375900 BZ SKIP260 NO R4 T3376000 OI PDBFLAG2,PDB2TCEL YES - SHOW TRAKCELL DATA SET R4 T3376100 SKIP260 CVB R1,SJBDBLWK CONVERT DS NUMBER TO T3376200 STH R1,PDBDSKEY BINARY AND SET KEY. T3376300 TM SSALFLG1,SSALTRKM IF ALLOC SPECIFIED T3376400 BZ *+8 INDIVIDUAL TRACK GROUP MAP, T3376500 OI PDBFLAG1,PDB1SPIN SET FLAG PDB1SPIN. T3376600 TM SSALFLG1,SSALHOLD IF ALLOC SPECIFIED T3376700 BZ *+12 HOLD-AT-UNALLOCATION @OZ29148 T3376800 OI PDBFLAG1,PDB1HOLD SET PDB1HOLD. T3376900 OI PDBFLAG2,PDB2HLDS ALSO SPECIFIC HOLD @OZ29148 T3376950 TM PDBFLAG1,PDB1SPIN+PDB1HOLD IF EITHER FLAG T3377000 BZ *+8 WAS SET, T3377100 OI PDBFLAG1,PDB1PSO SET PDB1PSO. T3377200 L R7,SJBJCT GET JCT ADDRESS FROM SJB. T3377300 USING JCTDSECT,R7 PROVIDE JCT ADDRESSABILITY. T3377500 TM JCTJOBFL,JCTNOUPT TEST 'NO OUTPUT' OPTION. T3378000 BZ *+8 BR IF NO. T3378500 OI PDBFLAG1,PDB1NSOT ELSE DON'T LET DATASET PRINT. T3379000 ICM R1,15,PDBFORMS GET FINAL FORMS NUMBER. T3379500 BNZ HCP600 BR IF 'VALID'. T3380000 MVC PDBFORMS,JCTFORMS ELSE USE JOB FORMS. T3380500 OI PDBFLAG2,PDB2JFMS SHOW PDBFORMS SET BY JCTFORMS R41 T3380600 L R1,SSALFORM GET FORMS ID ADDRESS R41 T3380700 MVC 0(4,R1),JCTFORMS UPDATE FORMS ID FIELD R41 T3380800 HCP600 DS 0H T3381000 SPACE 3 T3381500 * T3382000 * T3382500 * UPDATE IOTPDDBP AND RETURN. T3383000 * T3383500 * T3384000 LA R0,PDBLENG GET PDDB LENGTH. T3384500 AL R0,IOTPDDBP ADD OLD IOTPDDBP. T3385000 ST R0,IOTPDDBP SET NEW IOTPDDBP. T3385500 ST R6,44(,R13) SAVE PDDB ADR IN SAVEAREA. T3386000 LM R14,R12,12(R13) RESTORE REGISTERS. T3386500 SR R15,R15 SET CC=0. T3387000 BR R14 RETURN TO CALLER. T3387500 EJECT T3388000 * T3388500 * T3389000 * NO SPACE - RETURN CC=2 TO GET ANOTHER IOT T3389500 * T3390000 * T3390500 HCP800 DS 0H T3391000 LM R14,R12,12(R13) RESTORE REGISTERS. T3391500 SLR R15,R15 SET CC=2. T3392000 BR R14 RETURN TO CALLER. T3392500 SPACE 1 R4 T3392600 * T3393500 * T3394000 * INVALID DESTINATION - RETURN CC = 1 T3394500 * T3395000 * T3395500 HCP810 DS 0H T3396000 CLI *,X'FF' SET CC = 1 (MASK OF 4) R4 T3396500 LM R14,R12,12(R13) RESTORE REGISTERS. T3397000 BR R14 RETURN TO CALLER. T3397500 EJECT @OZ19494 T3397600 * T3398500 * T3399000 * DEFAULT FULL-LENGTH PERIPHERAL DATASET DEFINITION BLOCK T3399500 * T3400000 * T3400500 DS 0F FORCE HALPDDB TO FULLWORD. T3401500 HALPDDB DS 0CL(PDBLENG) MODEL PDDB. T3402000 DC AL1(PDB1NULL) FLAG BYTE T3402500 DC AL1(0) RECORD FORMAT T3403000 DC H'0' MAXIMUM LOGICAL RECORD LENGTH T3403500 DC F'0' STARTING TRACK ADDRESS T3404000 DC H'0' DATA SET KEY T3404500 DC C'A' DEFAULT SYSOUT CLASS T3405000 DC AL1(1) DEFAULT COPY COUNT T3405500 DC X'8000' DESTINATION T3406000 DC AL1(0,0,0) CPU ID, SECURITY, 3211 INDEX T3406500 DC AL1(JFCFNCBP) 3525 FUNCTION BYTE T3407000 DC AL1(0) FLAG BYTE 2 R4 T3407100 DC X'FF' DEFAULT COMPACTION TABLE NUMBER R41 T3407200 DC F'0' RECORD COUNT T3408000 DC XL4'00' FORMS NUMBER T3408500 DC C'****' FCB ID T3409000 DC C'****' UCS ID T3409500 DC CL8' ' USER WRITER NAME T3410000 DC XL8'00' CHECKPOINT RBA T3410500 DC CL4'****' TRANSLATE TABLE 1 R4 T3410600 DC CL4'****' TRANSLATE TABLE 2 R4 T3410700 DC CL4'****' TRANSLATE TABLE 3 R4 T3410800 DC CL4'****' TRANSLATE TABLE 4 R4 T3410900 DC CL4'****' FLASH ID R4 T3411000 DC CL4'****' MODIFY ID R4 T3411100 DC AL1(255) FLASH COUNT R41 T3411200 DC AL1(0) TABLE REFERENCE CHARACTER R4 T3411300 DC AL1(0,0,0,0,0,0,0,0) COPY GROUPS R4 T3411400 DC X'FFFF' LOGICAL PAGES/CHECKPOINT @OZ19494 T3411500 DC X'FFFF' LINES/LOGICAL PAGE @OZ19494 T3411520 DC XL14'0' RESERVED @OZ19494 T3411540 DS 0F FORCE TO FULLWORD BOUNDARY @OZ19494 T3411560 EJECT R4 T3411600 * T3411700 * TEST SCATHOLD. R10 POINTS TO SSAL. T3412000 * T3412500 HALCLASS DS 0H T3413000 USING *,R15 SET LOCAL ADDRESSABILITY. T3413500 L R1,SJBJCT POINT TO JOB'S HASP JCT. T3414000 SLR R2,R2 ZERO R2 FOR IC. T3414500 IC R2,JCTMCLAS-JCTDSECT(,R1) GET MESSAGE CLASS. T3415000 LA R1,$SVSCAT(R2) POINT TO ITS SCAT ENTRY. T3415500 USING SCADSECT,R1 SET SCAT ADDRESSABILITY. T3416000 TM SCATFLAG,SCATHOLD SET CC=0 IF HOLD DISALLOWED. T3416500 BALR R0,0 SAVE CONDITION CODE. T3417000 L R1,SSALCLAS POINT TO DATA SET'S CLASS. T3417500 CLI 0(R1),C'$' IF CLASS IS $, T3418000 BE HALCLAS1 USE JCTMCLAS. T3418500 CLI 0(R1),C' ' IF CLASS IS NULL R41 T3418600 BE HALCLAS1 USE JCTMCLAS R41 T3418700 CLI 0(R1),C'*' IF CLASS IS *, T3419000 BE HALCLAS1 USE JCTMCLAS. T3419500 IC R2,0(,R1) ELSE USE GIVEN CLASS. T3420000 B HALCLAS2 CHECK FOR HOLD ALLOWED @OZ45950 T3420200 HALCLAS1 DS 0H T3420500 CLI SJBXQFN1+1,SSOBUNAL IF CALLED FROM UNALLOCATE @OZ45950 T3420600 BNE HALCLAS2 FOR PSO AND SSALCLAS IS @OZ45950 T3420700 CLI DSNDSTYP-JFCB(RJFC),C'P' BLANK OR ASTERISK, @OZ45950 T3420730 BNE HALCLAS2 USE DATA SETS @OZ45950 T3420760 IC R2,PDBCLASS-PDBDSECT(R4) ORIGINAL CLASS @OZ45950 T3420800 HALCLAS2 DS 0H @OZ45950 T3420900 SPM R0 RESTORE CONDITION CODE. T3421000 LA R1,$SVSCAT(R2) POINT TO PROPER SCAT ENTRY. T3421500 BZR R14 RETURN IF HOLD DISALLOWED. T3422000 TM SCATFLAG,SCATHOLD SET CC ACC. TO SCATHOLD. T3422500 BR R14 RETURN CONDITION CODE. T3423000 DROP , DROP ALL ADDRESSABILITY. T3423500 TITLE 'LITERAL POOL FOR ALLOCATE' R4 T3423600 LTORG R4 T3423700 TITLE 'HASP SUBSYSTEM SUPPORT ROUTINE -- UNALLOCATE' T3424000 * T3424500 * T3425000 * HASP SUBSYSTEM SUPPORT ROUTINE -- UNALLOCATE T3425500 * T3426000 * T3426500 SPACE 1 T3427000 HOSUNAL $PROLOG SSOBUNAL,SSALSIZE,LOCK=REQ T3427500 LR RSIB,RSOX TRANSFER SSAL ADDRESS TO RSIB. T3428000 USING SSALBGN,RSIB SET SSAL ADDRESSABILITY. T3428500 L RJFC,SSALJFCB POINT TO THE JFCB. T3429000 USING INFMJFCB,RJFC SET JFCB ADDRESSABILITY. T3429500 L RSDB,SSALSSCM POINT TO THE SDB/DCT. T3430000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T3430500 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T3431000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T3431500 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3432000 SPACE 3 T3432500 * T3436500 * BRANCH ACCORDING TO DATA SET TYPE T3437000 * T3437500 SPACE 1 T3438000 LH R0,DSNDSTYP LOAD DATA SET TYPE. T3438500 CH R0,=C'SI' IF SYSIN, T3439000 BE HUAI GO UNALLOCATE. T3439500 CH R0,=C'SO' IF SYSOUT, T3440000 BE HUAO GO UNALLOCATE. T3440500 CH R0,=C'PS' IF PROCESS-SYSOUT, T3441000 BE HUAP GO UNALLOCATE. T3441500 B HUA800 ERROR - UNRECOGNIZABLE TYPE. T3442000 EJECT T3442500 * T3443000 * T3443500 * SYSIN DATA SET UNALLOCATION R41 T3444000 * T3444500 * T3445000 SPACE 1 T3445500 HUAI DS 0H T3450000 CALL $SDBFREE FREE THE SDB. T3450500 B HUA950 RETURN WITHOUT CHECKPOINT. T3451000 SPACE 1 R41 T3451100 * R41 T3451200 * R41 T3451300 * PROCESS-SYSOUT DATA SET UNALLOCATION R41 T3451400 * R41 T3451500 * R41 T3451600 SPACE 1 R41 T3451700 USING PDBDSECT,R4 PROVIDE PDDB ADDRESSABILITY R41 T3451800 SPACE 1 R41 T3451900 HUAP CLC SJBPSOP,=F'0' PSO STILL PRESENT @OZ50462 T3452000 BNE HUAP1 YES, POINT TO PDDB @OZ50462 T3452020 CALL $SDBFREE FREE SDB @OZ50462 T3452040 B HUA950 NORMAL RETURN @OZ50462 T3452060 HUAP1 L R4,SDBPDDB PDDB IS IN PSO @OZ50462 T3452080 TM PDBFLAG1,PDB1HOLD DATA SET ALREADY HELD... R41 T3452100 BZ HUAO50 BR IF NO (XWTR REQUEST) R41 T3452200 NI PDBFLAG1,255-PDB1HOLD RESET HOLD BIT R41 T3452300 B HUAO20 BR TO UPDATE PDDB R41 T3452400 EJECT T3452500 * T3452600 * T3452700 * SYSOUT DATA SET UNALLOCATION T3453000 * T3453500 * T3454000 SPACE 1 T3454500 HUAO DS 0H T3455000 L R1,SSALPGMN POINT TO USER WRITER NAME. T3455500 CLC =CL8'INTRDR',0(R1) IF IT'S INTERNAL READER, T3456000 BE HUAR GO UNALLOCATE. T3456500 LTR RSDB,RSDB IF NO SDB, T3457000 BZ HUA950 RETURN NORMALLY. T3457500 CLC =CL4'SDB',SDBID IF BAD CONTROL BLOCK ID, T3458000 BNE HUA800 ERROR - CAN'T UNALLOCATE. T3458500 SLR R15,R15 SET ZERO RETURN CODE R41 T3458600 TM SJBFLG1,SJB1XBWT BIT IF XBM ENDING, T3459000 BO HUA890 JUST FREE THE SDB R41 T3459500 SPACE 1 T3460000 * T3460500 * POINT TO PDDB AND ITS IOT T3461000 * T3461500 SPACE 1 T3462000 L R1,SJBIOT IF THERE IS NO T3462100 LTR R1,R1 PRIMARY ALLOCATION IOT, T3462200 BZ HUA800 ALLOCATION MAY FAIL. T3462300 MVI SJBDBLWK+4,0 SET MULT DEST NULL FLAG R41 T3462400 L RIOT,SDBPIOT POINT TO PDDB'S IOT. T3462500 L R4,SDBPDDB POINT TO PDDB. T3463000 TM PDBFLAG2,PDB2NEWS JESNEWS UNALLOCATION... @OZ39639 T3463200 BZ HUAO10 BR IF NO @OZ39639 T3463210 OI SSALFLG1,SSALSPIN ELSE FORCE SPIN @OZ39639 T3463220 SPACE 1 @OZ39639 T3463260 HUAO10 MVC PDBRECCT,SDBRECCT MOVE RECORD COUNT TO PDDB @OZ39639 T3463500 NI PDBFLAG1,255-PDB1NSOT-PDB1HOLD-PDB1SPIN-PDB1PSO R41 T3464000 SPACE 1 R41 T3464100 HUAO20 L R1,SSALDEST GET DESTINATION ADDRESS R41 T3464200 CLC =CL8' ',0(R1) TEST DESTINATION R41 T3464300 BE HUAO25 BR IF NOT SPECIFIED R41 T3464400 L R2,SJBJCT GET JCT ADDRESS R41 T3464500 IC R2,JCTROUTE-JCTDSECT(,R2) GET DEFAULT DEST R41 T3464600 CALL USERDEST VALIDATE USER DESTINATION R41 T3464700 B HUAO25 BR IF INVALID DESTINATION +0 R41 T3464800 STH R2,PDBDEST SET NEW DESTINATION +4 R41 T3464900 SPACE 1 R41 T3465000 * THIS LINE DELETED BY APAR NUMBER @OZ45950 T3465100 * THIS LINE DELETED BY APAR NUMBER @OZ45950 T3465200 * THIS LINE DELETED BY APAR NUMBER @OZ45950 T3465300 * THIS LINE DELETED BY APAR NUMBER @OZ45950 T3465400 EJECT R41 T3465500 HUAO25 LR RSDB,RSIB RELOAD SSAL ADDRESS @OZ45950 T3465600 CALL HALCLASS GET CLASS, HOLD STATUS R41 T3465700 L RSDB,SSALSSCM RESTORE SDB ADDRESS R41 T3465800 BZ HUAO40 BR IF NON-HOLD CLASS R41 T3465900 CLI DSNDSTYP,C'P' TEST FOR PSO REQUEST R41 T3466000 BE HUAO40 BR IF YES (IGNORE HOLD) R41 T3466100 OI PDBFLAG1,PDB1HOLD ELSE SET HOLD FLAG R41 T3466200 SPACE 1 R41 T3466300 HUAO40 STC R2,PDBCLASS SET SYSOUT CLASS R41 T3466400 TM SSALFLG1,SSALHOLD TEST FOR EXPLICIT HOLD R41 T3466500 BZ *+8 BR IF NO R41 T3466600 OI PDBFLAG1,PDB1HOLD ELSE SET HOLD FLAG R41 T3466700 TM SCATFLAG-SCADSECT(R1),SCATDUMM DUMMY CLASS... R41 T3466800 BZ *+8 BR IF NO R41 T3466900 OI PDBFLAG1,PDB1NSOT ELSE SET NO-PRINT FLAG R41 T3467000 TM PDBFLAG1,PDB1DSID TEST FOR DSID R41 T3467100 BO HUAO45 BR IF YES (IGNORE WTR ID) R41 T3467200 L R1,SSALPGMN GET WTR ID ADDRESS R41 T3467300 CLI 0(R1),C' ' WTR ID SPECIFIED... R41 T3467400 BE HUAO45 BR IF NO R41 T3467500 MVC PDBWTRID,0(R1) MOVE WTR ID TO PDDB R41 T3467600 SPACE 1 R41 T3467700 HUAO45 L R1,SSALFORM GET FORMS ID ADDRESS R41 T3467800 CLI 0(R1),C' ' FORMS ID SPECIFIED... R41 T3467900 BE HUAO50 BR IF NO R41 T3468000 CLC PDBSSOFM,0(R1) FORMS CHANGE AT UNALLOC... @OZ47891 T3468030 BE HUAO50 BRANCH IF NO @OZ47891 T3468060 MVC PDBFORMS,0(R1) MOVE FORMS ID TO PDDB R41 T3468100 SPACE 1 R41 T3468200 HUAO50 TM SSALFLG1,SSALDELT TEST FOR EXPLICIT DELETE R41 T3468300 BZ *+8 BR IF NO R41 T3468400 OI PDBFLAG1,PDB1NSOT ELSE SET NO-PRINT FLAG R41 T3468500 CLI DSNDSTYP,C'P' TEST FOR PSO REQUEST R41 T3468600 BNE HUAO60 BR IF NO (NORMAL UNALLOC) R41 T3468700 CALL $SDBFREE ELSE FREE THE SDB R41 T3468800 B HUA950 RETURN WITHOUT CHECKPOINTING R41 T3468900 EJECT R41 T3469000 HUAO60 OI IOTFLAG1,IOT1CKPT FORCE IOT CHECKPOINT R41 T3469100 NI SJBDBLWK+4,PDB1NULL TEST MULT DEST NULL FLAG R41 T3469200 BZ *+8 BR IF NON-NULL DATA SET R41 T3469300 OI PDBFLAG1,PDB1NULL ELSE PROPAGATE NULL BIT R41 T3469400 MVC SJBDBLWK(4),IOTIOT SAVE ADDRESS OF NEXT IOT R41 T3469500 MVC SJBDBLWK+4(1),PDBFLAG1 SAVE PDDB FLAG BYTE R41 T3469600 L R2,SJBJCT GET JCT ADDRESS R41 T3469700 TM JCTJOBFL-JCTDSECT(R2),JCTNOUPT TEST FOR NO PRNT R41 T3469800 BZ *+8 BR IF NO (PRINT ALLOWED) R41 T3469900 OI PDBFLAG1,PDB1NSOT ELSE SET NO-PRINT FLAG R41 T3470000 TM PDBFLAG1,PDB1DSID TEST FOR DSID R41 T3470100 BZ *+8 BR IF NO R41 T3470200 OI PDBFLAG1,PDB1HOLD ELSE SET HOLD FLAG R41 T3470300 TM SSALFLG1,SSALSPIN TEST FOR SPIN REQUEST R41 T3470400 BZ HUAO63 BR IF NO @OZ29364 T3470500 SPACE 1 @OZ29364 T3470505 * UPDATE SMF INFORMATION BEFORE SPINNING @OZ29364 T3470510 USING JCTDSECT,R2 @OZ29364 T3470515 L R1,PSATOLD-PSA FIND CURRENT TCB @OZ29364 T3470520 ICM R1,7,TCBTCTB-TCB(R1) GET 24-BIT TCT ADDR. @OZ29364 T3470525 BZ HUAO62 BR IF NO SMF. @OZ29364 T3470530 L R1,TCTJMR-SMFTCT(,R1) GET JMR ADDRESS. @OZ29364 T3470535 CLC JCTUSEID,JCTUSEID-JCTJMR(R1) TEST USER SMF. @OZ29364 T3470540 BNE HUAO61 BR IF CHANGED. @OZ29364 T3470545 CLC JCTUCOM,JCTUCOM-JCTJMR(R1) TEST USER SMF COMM. @OZ29364 T3470550 BE HUAO62 BR IF ALL UNCHANGED @OZ29364 T3470555 HUAO61 MVC JCTUSEID,JCTUSEID-JCTJMR(R1) XFER USER SMF @OZ29364 T3470560 MVC JCTUCOM,JCTUCOM-JCTJMR(R1) FROM JMR TO JCT. @OZ29364 T3470565 OI JCTFLAG1,JCT1CKPT CAUSE JCT CHECKPOINT. @OZ29364 T3470570 HUAO62 OI PDBFLAG1,PDB1SPIN SET SPIN FLAG. @OZ29364 T3470600 HUAO63 DS 0H COMMON RETURN @OZ29364 T3470625 DROP R2 @OZ29364 T3470650 SPACE 1 @OZ29364 T3470675 TM PDBFLAG1,PDB1HOLD+PDB1SPIN TEST FOR HOLD/SPIN R41 T3470700 BZ *+8 BR IF NO R41 T3470800 OI PDBFLAG1,PDB1PSO ELSE SET PSO FLAG R41 T3470900 SPACE 1 T3490000 * T3490500 * CHECK IF SPIN IOT PRESENT OR REQUIRED T3491000 * T3491500 SPACE 1 T3492000 TM IOTFLAG1,IOT1SPIN IS IOT ALREADY SPIN-TYPE... T3492500 BO HUAO200 BRANCH IF SO. T3493000 TM PDBFLAG1,PDB1PSO SHOULD IOT BE SPIN-TYPE... T3493500 BZ HUAO280 BR IF NO (ALL FOR THIS PDDB) R41 T3494000 EJECT T3500000 * T3500500 * CREATE A SPIN IOT FOR UNALLOCATE T3501000 * T3501500 SPACE 1 T3502000 HUAO100 DS 0H T3502500 CALL HCBGM GET STORAGE FOR IOT. T3503000 BNZ HUA800 ERROR - STORAGE UNAVAILABLE. T3503500 LR RIOT,R1 SET IOT BASE REGISTER. T3504000 L R1,SJBIOT POINT TO ALLOCATION IOT. T3504500 LA R1,IOTMSTAB-IOTDSECT(,R1) PT TO THE MASTER TAB R4 T3504600 CALL $STRAK ALLOCATE A TRACK FOR IOT. T3506500 L R15,SJBIOT GET ALLOCATION IOT ADDRESS @OZ17477 T3506600 OI IOTFLAG1-IOTDSECT(R15),IOT1CKPT FORCE IOT CHKPT @OZ17477 T3506700 LR RSOX,RSIB POINT RSOX TO THE SSAL. T3507000 CALL HALCRIOT FORMAT THE IOT. T3507500 OI IOTFLAG1,IOT1SPIN PUT ON CORRECT CHAIN @OZ17491 T3507650 CALL HALCHIOT CHAIN IOT TO SJB, JCT. T3507800 MVC SJBSPIOT,IOTIOT DECHAIN IT FROM SJB. T3508000 L R15,$SVPDDB1 MOVE PDDB R4 T3508300 LA RSDB,0(RIOT,R15) TO NEW R4 T3508500 MVC 0(PDBLENG,RSDB),PDBDSECT SPIN IOT R4 T3508800 L RSDB,SSALSSCM RESTORE RSDB. T3509000 OI PDBFLAG1,PDB1NSOT DELETE THE OLD PDDB. T3509500 LA R0,PDBLENG(,R15) GET OFFSET OF NEXT PDDB R4 T3511000 ST R0,IOTPDDBP AND STORE POINTER IN IOT. T3511500 SPACE 1 T3512000 * T3512500 * WRITE THE IOT AND SPIN IT T3513000 * T3513500 SPACE 1 T3514000 CALL HIOTSPIN SPIN/HOLD THE IOT. T3515000 L RIOT,SDBPIOT POINT BACK TO ORIGINAL R4 T3516000 L R4,SDBPDDB IOT AND PDDB R4 T3517000 B HUAO280 GO CHECK FOR MULTI-DEST R4 T3518000 EJECT T3521500 CNOP 0,8 T3522000 HUAO200 BAL R14,HALDCIOT DE-CHAIN IOT FROM SPIN IOT CHAIN T3522500 * SPIN/HOLD THE IOT IF DATASET SPUN/HELD/DELETE/NOPRINT @OZ29594 T3523000 TM PDBFLAG1,PDB1SPIN+PDB1HOLD+PDB1NSOT SPIN NOW? @OZ29594 T3523100 BZ HUAO210 BR IF NOT R4 T3523500 CALL HIOTSPIN SPIN/HOLD THE IOT R4 T3523600 TM SDBFLG2,SDB2LOG IF SYSLOG DS SPIN FAILED, @OZ58848 T3523620 BO HUAO210 BR TO CONVERT TO REGULAR. @OZ58848 T3523640 TM SJBDBLWK+4,PDB1MDES IF MULTIPLE DESTINATIONS, R4 T3523700 BO HUAO285 CONSIDER THE NEXT IOT, R4 T3523800 B HUAO300 ELSE FREE THE SDB R4 T3523900 SPACE 1 T3524000 * T3524500 * SPIN/HOLD DATASET WAS NOT SPUN/HELD T3525000 * T3525500 SPACE 1 T3526000 HUAO210 L R1,SJBIOT GET ALLOCATION IOT ADDRESS R4 T3526500 OI IOTFLAG1-IOTDSECT(R1),IOT1CKPT REQUEST IOT CHECKPOINT T3528000 MVI IOTFLAG1,0 RESET SPIN IOT FLAG T3528500 L R0,$SVMAPL GET LENGTH OF TRACK GROUP MAP R4 T3529000 LA R1,IOTTGMAP-IOTDSECT+TGMAP-TGMDSECT(,R1) MERGE R4 T3529100 $VFL OC,(R1),IOTTGMAP+TGMAP-TGMDSECT,(R0) MAPS R4 T3529200 LA R0,IOTTGMAP+TGMAP-TGMDSECT CLEAR R4 T3529300 L R1,$SVMAPL OLD R4 T3529400 SLR R15,R15 TRACK GROUP R4 T3529500 MVCL R0,R14 MAP R4 T3529600 NI IOTFLAG1,255-IOT1CKPT-IOT1ALOC-IOT1NEWS RESET @OZ39639 T3529900 OI PDBFLAG1,PDB1NSOT NULLIFY PDDB ON SPIN CHAIN @OZ26752 T3529950 L R0,IOTTRACK RE-WRITE T3530000 LR R1,RIOT CLEANED-UP T3530500 CALL HCBWR SPIN IOT T3531000 NI PDBFLAG1,255-PDB1NSOT PRINT ON REGULAR CHAIN @OZ26752 T3531250 LR R2,RIOT SAVE PDDB'S IOT ADDRESS T3531500 L R1,SJBIOT PREPARE TO FIND LAST REGULAR IOT T3532000 SPACE 1 T3532500 * T3533000 * RETURN SPIN/HOLD DATASET TO FOLD T3533500 * T3534000 SPACE 1 T3534500 HUAO220 LR RIOT,R1 RE-LOAD LAST VALID IOT ADDRESS T3535000 L R1,IOTIOT GET ADDR OF NEXT OUTPUT IOT T3535500 LTR R1,R1 TEST FOR VALID IOT ADDRESS T3536000 BNZ HUAO220 BR IF SO T3536500 SPACE 1 T3537000 L R6,IOTPDDBP GET OFFSET OF LAST PDDB IN IOT T3537500 LA R15,PDBLENG(,R6) ROOM FOR R4 T3538000 CH R15,IOTLENG ANOTHER... R4 T3538300 BNH HUAO240 BR IF SO T3538500 EJECT T3539000 * T3539500 * USE SPIN/HOLD IOT AS NEXT OUTPUT IOT T3540000 * T3540500 SPACE 1 T3541000 L R1,SJBIOT GET ALLOCATION IOT ADDRESS T3541500 LA R1,IOTMSTAB-IOTDSECT(,R1) GET NEW TRACK ADDRESS R4 T3541600 CALL $STRAK FOR NEW OUTPUT IOT T3542500 L R15,SJBIOT GET ALLOCATION IOT ADDRESS @OZ17477 T3542600 OI IOTFLAG1-IOTDSECT(R15),IOT1CKPT FORCE IOT CHKPT @OZ17477 T3542700 ST R1,IOTIOTTR EXTEND OUTPUT IOT T3543000 ST R2,IOTIOT ON SPOOL AND IN STORAGE T3543500 OI IOTFLAG1,IOT1CKPT REQUEST IOT CHECKPOINT T3544000 LR RIOT,R2 RESTORE EX-SPIN IOT ADDRESS T3544500 ST R1,IOTTRACK STORE NEW TRACK ADDRESS T3545000 SLR R0,R0 CLEAR NEW T3545500 ST R0,IOTIOTTR OUTPUT IOT T3546000 ST R0,IOTIOT CHAIN ADDRESSES T3546500 OI IOTFLAG1,IOT1CKPT REQUEST IOT CHECKPOINT @OZ26752 T3546750 B HUAO280 END FOR THIS PDDB. T3547000 SPACE 1 T3547500 * T3548000 * MOVE PDDB TO END OF LAST OUTPUT IOT T3548500 * T3549000 SPACE 1 T3549500 CNOP 0,8 T3550000 HUAO240 LA R1,0(R6,RIOT) MOVE PDDB TO END T3550500 MVC 0(PDBLENG,R1),PDBDSECT OF LAST OUTPUT IOT T3551000 LR R1,R2 FREE THE T3551500 CALL HCBFM SPIN IOT BUFFER T3552000 LA R6,PDBLENG(,R6) UPDATE OFFSET TO T3552500 ST R6,IOTPDDBP NEXT PDDB IN IOT T3553000 OI IOTFLAG1,IOT1CKPT CAUSE NORMAL IOT CHECKPOINT. T3553500 B HUAO285 END FOR THIS PDDB. T3553600 EJECT T3553700 * T3553800 * T3553900 * SELECT NEXT PDDB IF MULTIPLE DESTINATION T3554000 * T3554100 * T3554200 HUAO280 DS 0H T3554300 TM SJBDBLWK+4,PDB1MDES DID OLD PDDB SAY MDES... T3554400 BZ HUAO300 IF NOT, END UNALLOCATION. T3554500 L R1,IOTPDDBP POINT TO LIMIT OF PDDBS T3554600 ALR R1,RIOT IN THIS IOT. T3554700 LA R4,PDBLENG(,R4) POINT PAST OLD PDDB. T3554800 CLR R1,R4 IF THERE'S ANOTHER PDDB T3554900 BH HUAO290 IN THIS IOT, BRANCH. T3555000 HUAO285 DS 0H T3555100 L RIOT,SJBDBLWK POINT TO THE NEXT IOT. T3555200 LTR RIOT,RIOT IF NO MORE IOTS, T3555300 BZ HUAO300 END UNALLOCATION. T3555400 ST RIOT,SDBPIOT SET SDBPIOT TO NEW IOT. T3555500 L R4,$SVPDDB1 POINT TO FIRST R4 T3555600 ALR R4,RIOT PDDB IN IT R4 T3555700 HUAO290 DS 0H T3555800 ST R4,SDBPDDB SET SDBPDDB TO NEW PDDB. T3555900 CLC PDBDSKEY,SDBDKEY IF DATA SET KEY MATCHES, T3556000 BE HUAO10 BR TO UNALLOCATE IT TOO R41 T3556100 * T3556200 * T3556300 * FREE THE SUBSYSTEM DATASET BLOCK AND EXIT T3556400 * T3556500 * T3556600 HUAO300 DS 0H T3556700 CALL $SDBFREE FREE THE SDB. T3556800 B HUA900 EXIT NORMALLY. T3556900 EJECT T3558500 * T3559000 * INTERNAL READER UNALLOCATION T3559500 * T3560000 HUAR DS 0H T3560500 USING DCTDSECT,RSDB USE DCT DSECT. T3561000 CLI DCTDEVTP,DCTINR DOES SSALSSCM POINT TO INT RDR... T3561500 BE HUAR05 IF SO, CONTINUE @OZ38453 T3562000 LA R15,SSALWTFL IF NOT, CAN'T ALLOCATE. T3562500 $EPILOG , RETURN FAILURE CODE. T3563000 HUAR05 DS 0H @OZ38453 T3563050 ICM R0,7,RIDUBF+1 HAS CLOSE BEEN DONE @OZ38453 T3563100 BZ HUAR10 IF YES, CONTINUE UNALLOC @OZ38453 T3563150 OI RIDFLAGS,RIDEOM+RIDEND+RIDPOST N,TELL RDR TO @OZ38453 T3563200 OI DCTFLAGS,DCTDELET CLEAN UP @OZ38453 T3563250 OI DCTSTAT,DCTHOLD HOLD DCT @OZ38453 T3563300 NI RIDFLAGS,255-RIDBUSY LET RDR HAVE DCT @OZ38453 T3563350 NI DCTFLAGS,255-DCTSTOP CLEAR POSSIBLE STOP @OZ38453 T3563400 MVC RIDEOMA,PSAAOLD-PSA SHOW ASCB TO POST @OZ38453 T3563450 $$POST ELMT=$SVIRDR POST INTRDR @OZ38453 T3563500 WAIT 1,ECB=RIDEOME WAIT FOR RDR TO FINISH @OZ38453 T3563550 XR R0,R0 CLEAR ZERO @OZ38453 T3563600 ST R0,RIDEOMA CLEAR ASCB @OZ38453 T3563650 ST R0,RIDEOME CLEAR EOM ECB @OZ38453 T3563700 ST R0,RIDECB CLEAR ECB @OZ38453 T3563750 * T3564000 * ACQUIRE CMS LOCK T3564500 * T3565000 HUAR10 DS 0H T3565500 LR R2,R13 SAVE REGISTERS T3566000 STM R11,R13,12(R2) 11 THROUGH 13. T3566500 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=HUAR30 CT3567000 ACQUIRE LOCAL LOCK. T3567500 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,RELATED=HUAR30 CT3568000 ACQUIRE CMS LOCK. T3568500 LM R11,R13,12(R2) RESTORE REGISTERS 11 THROUGH 13. T3569000 * T3569500 * UNALLOCATE INTERNAL READER T3570000 * T3570500 SLR R0,R0 ZERO OUT INTERNAL READER'S T3571000 ST R0,RIDASCBP ASCB POINTER AND T3571500 ST R0,RIDUBF UNPROTECTED-BUFFER POINTER. T3572000 NI RIDFLAGS,255-RIDALLOC SHOW INTERNAL READER NOT ALLOC. T3572500 * T3573000 * POST EVERYBODY WAITING ON INTERNAL READER ALLOCATION. T3573500 * T3574000 SLR R0,R0 ZERO R0 FOR ZEROING. T3574500 L R6,$SVIRWT POINT TO FIRST WAIT ELEMENT T3575000 CS R6,R0,$SVIRWT AND MAKE THE T3575500 BNE *-4 CHAIN HEADER ZERO. T3576000 HUAR20 DS 0H T3576500 LTR R6,R6 IS THERE A WAIT ELEMENT... T3577000 BZ HUAR30 IF NOT, DONE POSTING. T3577500 L R5,12(,R6) POINT TO THE ASCB. T3578000 USING ASCB,R5 SET ASCB ADDRESSABILITY. T3578500 TM ASCBFLG1,ASCBTERM+ASCBABNT IF MEMORY ENDING, T3579000 BNZ HUAR25 GO FREE ELEMENT. T3579500 DROP R5 DROP ASCB BASE. T3580000 STM R14,R12,12(R13) SAVE REGISTERS. T3580500 LR R9,R13 ONLY 9, 14 GOOD AFTER CALL. T3581000 L R15,CVTPTR POINT TO CVT. T3581500 L R15,CVT0PT01-CVT(,R15) POINT THENCE TO IEA0PT01. T3582000 SLR R10,R10 SHOW ZERO COMPLETION CODE. T3582500 L R11,8(,R6) POINT R11 TO ECB. T3583000 O R11,=X'80000000' SHOW CROSS-MEMORY POST. T3583500 L R12,16(,R6) POINT R12 TO ERRET. T3584000 L R13,12(,R6) POINT R13 TO ASCB. T3584500 BALR R14,R15 GO POST. T3585000 LR R13,R9 RESTORE R13 FROM R9. T3585500 LM R14,R12,12(R13) RESTORE REGISTERS. T3586000 L R6,0(,R6) POINT TO NEXT ELEMENT. T3586500 B HUAR20 GO CHECK IT. T3587000 HUAR25 DS 0H T3587500 LR R1,R6 INSTEAD OF POST, FREE ELEMENT T3588000 L R6,0(,R6) AFTER POINTING TO NEXT ONE. T3588500 $FREMAIN RC,A=(R1),LV=32,SP=231,KEY=1 FREE WAIT ELEMENT. T3589000 B HUAR20 THEN CHECK NEXT ELEMENT. T3589500 * T3590000 * RELEASE CMS LOCK T3590500 * T3591000 HUAR30 DS 0H T3591500 LR R2,R13 SAVE REGISTERS T3592000 STM R11,R13,12(R2) 11 THROUGH 13. T3592500 SETLOCK RELEASE,TYPE=CMS,RELATED=HUAR10 CT3593000 RELEASE CMS LOCK. T3593500 SETLOCK RELEASE,TYPE=LOCAL,RELATED=HUAR10 CT3594000 RELEASE LOCAL LOCK. T3594500 LM R11,R13,12(R2) RESTORE REGISTERS 11 THROUGH 13. T3595000 * T3595500 * RETURN TO CALLER. T3596000 LA R15,SSALRTOK SET NORMAL RETURN CODE. T3596500 $EPILOG KEY=0 RETURN TO CALLER. T3597000 EJECT T3597500 * T3598000 * T3598500 * FAILURE IN UNALLOCATION T3599000 * T3599500 * T3600000 SPACE 1 T3600500 HUA800 DS 0H T3601000 LA R15,SSALWTFL SET UNABLE-TO-ALLOCATE. T3601500 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY R41 T3601600 CLC =CL4'SDB',SDBID TEST SDB ID R41 T3601700 BE HUA890 BR IF OK R41 T3602000 $EPILOG , ELSE RETURN R41 T3602200 HUA820 DS 0H T3602500 LA R15,SSALIDST SET INVALID DESTINATION. T3603000 SPACE 3 T3603500 HUA890 DS 0H T3604000 LR R2,R15 SAVE RETURN CODE. T3604500 CALL $SDBFREE FREE THE SDB. T3605000 LR R15,R2 RESTORE RETURN CODE. T3605500 $EPILOG , RETURN. T3606000 SPACE 3 T3606500 * T3607000 * T3607500 * NORMAL EXIT FROM UNALLOCATION T3608000 * T3608500 * T3609000 SPACE 1 T3609500 HUA900 DS 0H T3610000 CALL HCBCK CHECKPOINT MARKED BLOCKS. T3610500 SPACE 1 T3611000 HUA950 DS 0H T3611500 SLR R15,R15 SHOW NORMAL EXIT. T3612000 $EPILOG , RETURN. T3612500 TITLE 'HALDCIOT -- SUBROUTINE TO DECHAIN IOT' T3613000 * T3613500 * T3614000 * HALDCIOT -- DECHAIN OUTPUT OR SPIN IOT T3614500 * T3615000 * T3615500 * OUTPUT IOT - IOT IS DECHAINED FROM SJBIOT AND JCTIOT T3616000 * SPIN IOT - IOT IS DECHAINED FROM SJBSPIOT AND JCTSPIOT T3616500 * THIS SUBROUTINE OPERATES UNDER HOSUNAL ADDRESSABILITY. T3617000 SPACE 1 T3617500 HALDCIOT DS 0H T3618000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3618500 TM IOTFLAG1,IOT1SPIN IS THIS A SPIN IOT... T3619000 BZR R14 IGNORE NON-SPIN IOT NOW. T3619500 SPACE 3 T3620000 * T3620500 * DE-CHAIN SPIN IOT FROM SJBSPIOT ONLY R4 T3620600 * T3621500 SPACE 1 T3622000 LA R1,SJBSPIOT POINT TO SPIN IOT HEADER. T3622500 SL R1,=A(IOTIOT-IOTDSECT) SET UP TO CHAIN. T3623000 HALDCI10 DS 0H T3623500 LR R2,R1 SAVE PREVIOUS IOT POINTER. T3624000 L R1,IOTIOT-IOTDSECT(,R1) POINT TO NEXT IOT. T3624500 LTR R1,R1 IF NO MORE IOTS, T3625000 BZR R14 RETURN. T3625500 CLR RIOT,R1 IF THIS IS NOT THE T3626000 BNE HALDCI10 ARGUMENT IOT, KEEP GOING. T3626500 MVC IOTIOT-IOTDSECT(,R2),IOTIOT DECHAIN ARGUMENT IOT. T3627000 BR R14 RETURN. T3627500 DROP , DROP ALL ADDRESSABILITY. T3628000 TITLE 'LITERAL POOL FOR UNALLOCATE' R4 T3628100 LTORG T3629000 TITLE 'HJEAHOLD - HOLD SPECIAL DATA SETS IF HELD MSGCLASS' T3629500 * T3630000 * ROUTINE NAME - HJEAHOLD T3630500 * T3631000 * PURPOSE - TO PUT INTO HOLD STATUS A JOB'S FOUR FAKE-OPENED T3631500 * DATASETS AND/OR XBM JOB'S SYSOUT DATASETS - T3632000 * JCL DATASET (NORMALLY NOT SYSOUT) T3632500 * JES2 JOB LOG T3633000 * JCL IMAGES (NOT SYSOUT IF XBM) T3633500 * SYSTEM MESSAGES T3634000 * EXECUTION BATCH MONITOR JOB'S SYSOUT DATASETS. T3634500 * T3635000 * FUNCTION - IF AN ATTRIBUTE OF THE JOB'S MESSAGE CLASS IS T3635500 * 'HOLD', THIS ROUTINE CALLS HJH100 ONCE FOR EACH OF THE T3636000 * JOB'S FOUR FAKE-OPENED DATASETS. THEN, FOR XBM JOBS, T3636500 * IT CALLS HJH100 ONCE FOR EACH SYSOUT DATASET WHICH T3637000 * SHOULD BE HELD BY REASON OF CLASS OR ALLOCATION T3637500 * DIRECTIVE. T3638000 * T3638500 * OPERATION - T3639000 * 1. IF NO MAIN OUTPUT ALLOCATION IOT EXISTS, RETURN. T3639500 * 2. THE SYSOUT CLASS ATTRIBUTE TABLE IS INDEXED BY T3640000 * THE BYTE AT JCTMCLAS. THE ATTRIBUTE 'HOLD' IS T3640500 * TESTED. IF NOT 'HOLD' THE NEXT 4 STEPS ARE SKIPPED. T3641000 * 3. HJH100 IS CALLED FOR JCL DATA SET. T3641500 * 4. HJH100 IS CALLED FOR JES2 JOB LOG. T3642000 * 5. HJH100 IS CALLED FOR JCL IMAGES. T3642500 * 6. HJH100 IS CALLED FOR SYSTEM MESSAGES. T3643000 * 7. IF NOT AN XBM JOB, RETURN. T3643500 * 8. FOR EACH XBM SYSOUT DATASET - T3644000 * A. IF PDB1HOLD, CALL HJH100. ELSE - T3644500 * B. IF JCTMCLAS AND PDBCLASS HAVE 'HOLD' ATTRIBUTE, T3645000 * CALL HJH100. T3645500 * T3646000 * REGISTERS AT ENTRY - T3646500 * R7 = HASP JCT T3647000 * R11 = SUBSYSTEM VECTOR TABLE T3647500 * R13 = SUBSYSTEM JOB BLOCK T3648000 * R14 = RETURN ADDRESS T3648500 * R15 = ADDRESS OF HJEAHOLD T3649000 * T3649500 * REGISTER USAGE IN ADDITION TO ABOVE- T3650000 * R1 = SCAT ENTRY T3650500 * R2 = LOCAL BASE, SET FROM R15 T3651000 * R3 = IOT CONTAINING PDDB BEING PROCESSED. T3651500 * R4 = PDDB CURRENTLY TO BE PROCESSED T3652000 * R6 = LINK REGISTER T3652500 * R7 = HASP JCT T3653000 * R8 = RETURN REGISTER, SET FROM R14 T3653500 * R11 = SUBSYSTEM VECTOR TABLE T3654000 * R13 = SUBSYSTEM JOB BLOCK T3654500 * R14 = RETURN REGISTER, USED TO SET R8 T3655000 * R15 = ENTRY REGISTER, USED TO SET R2 T3655500 * T3656000 * REGISTER DIFFERENCES AT EXIT - T3656500 * R0-R6, R8, R10, R14-R15 DESTROYED T3657000 * T3657500 * EXITS - NULL AND NORMAL - T3658000 * ON R8 T3658500 * T3659000 SPACE 1 T3659500 HJEAHOLD DS 0H T3660000 USING *,R2 SET LOCAL ADDRESSABILITY. T3660500 LR R2,R15 SET LOCAL BASE. T3661000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T3661500 L R3,SJBIOT POINT TO ALLOCATION IOT. T3662000 LTR R3,R3 IF IT DOESN'T EXIST, T3662500 BZR R14 NULL RETURN. T3663000 LR R8,R14 SAVE RETURN IN R8. T3663500 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T3664000 SLR R6,R6 ZERO R6 FOR IC. T3664500 IC R6,JCTMCLAS GET MSGCLASS FROM JCT. T3665000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T3665500 LA R1,$SVSCAT(R6) POINT TO SCAT ENTRY FOR T3666000 USING SCADSECT,R1 MSGCLASS, SET ADDRESSABILITY. T3666500 TM SCATFLAG,SCATHOLD IF MSGCLASS NOT TO BE HELD, T3667000 BZ HJEAH20 BR TO TEST FOR OTHERS. T3667500 USING IOTDSECT,R3 SET ALLOCATION IOT ADDR. T3668000 L R4,$SVPDDB1 POINT TO PDDB R4 T3668500 LA R4,IOTPDBOJ(R3,R4) FOR JCL DATA SET R4 T3668800 BAL R6,HJH100 CALL HJH100. T3669000 L R4,$SVPDDB1 POINT TO PDDB R4 T3669500 LA R4,IOTPDBOL(R3,R4) FOR JES2 JOB LOG R4 T3669800 BAL R6,HJH100 CALL HJH100. T3670000 L R4,$SVPDDB1 POINT TO PDDB R4 T3670500 LA R4,IOTPDBOI(R3,R4) FOR JCL IMAGES R4 T3670800 BAL R6,HJH100 CALL HJH100. T3671000 L R4,$SVPDDB1 POINT TO PDDB R4 T3671500 LA R4,IOTPDBOM(R3,R4) FOR SYSTEM MESSAGES R4 T3671800 BAL R6,HJH100 CALL HJH100. T3672000 SPACE 1 T3672500 HJEAH20 TM SJBFLG1,SJB1XBM IF NOT XBM JOB, T3673000 BZR R8 RETURN. T3673500 L R4,$SVPDDB1 PREPARE TO HOLD R4 T3674000 LA R4,IOTPDBOD-PDBLENG(R3,R4) SYSOUT DATA SETS R4 T3674300 SPACE 1 T3674500 HJEAH40 LA R4,PDBLENG(,R4) POINT TO NEXT PDDB (IF ANY). T3675000 L R1,IOTPDDBP IF NOT END T3675500 LA R1,IOTDSECT(R1) OF PDDBS IN T3676000 CLR R4,R1 CURRENT IOT, T3676500 BL HJEAH60 GO TO TEST HOLD REQUIREMENT. T3677000 ICM R3,15,IOTIOT IF NO MORE IOT(S), T3677500 BZR R8 RETURN. T3678000 L R4,$SVPDDB1 ELSE R4 T3678300 ALR R4,R3 PREPARE R4 T3678400 SL R4,=A(PDBLENG) TO SCAN R4 T3678800 B HJEAH40 NEXT IOT. T3679000 SPACE 1 T3679500 USING PDBDSECT,R4 SET PDDB ADDRESSABILITY. T3680000 HJEAH60 TM PDBFLAG1,PDB1HOLD IF 'HOLD=YES' SPECIFIED, T3680500 BO HJEAH80 GO TO HOLD THE DATASET. T3681000 SLR R6,R6 IF MSGCLASS T3681500 IC R6,JCTMCLAS OF JOB NOT T3682000 LA R1,$SVSCAT(R6) A 'HOLD' T3682500 TM SCATFLAG,SCATHOLD CLASS, T3683000 BZ HJEAH40 TEST NEXT PDDB. T3683500 IC R6,PDBCLASS IF SYSOUT T3684000 LA R1,$SVSCAT(R6) CLASS NOT A T3684500 TM SCATFLAG,SCATHOLD 'HOLD' CLASS, T3685000 BZ HJEAH40 TEST NEXT PDDB. T3685500 SPACE 1 T3686000 HJEAH80 BAL R6,HJH100 CALL HJH100 TO HOLD THE DATASET. T3686500 B HJEAH40 THEN TEST NEXT PDDB. T3687000 EJECT T3687500 * T3688000 * ROUTINE NAME - HJH100 T3688500 * T3689000 * PURPOSE - TO PUT INTO HOLD STATUS A SUBSYSTEM DATA SET. T3689500 * T3690000 * FUNCTION - A NEW IOT IS CREATED AND THE DATA SET'S PDDB T3690500 * IS MOVED INTO IT. THE OLD PDDB IS NULLIFIED. T3691000 * THE IOT IS CHAINED ON THE SPIN QUEUE FOR FURTHER T3691500 * PROCESSING BY HASPXEQ. T3692000 * T3692500 * OPERATION - T3693000 * 1. IF DATASET NULL OR NOT SYSOUT, RETURN. T3693500 * 2. IF NO STORAGE FOR NEW IOT, ERROR RETURN. T3694000 * 3. INITIALIZE THE NEW IOT. T3694500 * 4. COPY THE PDDB TO THE NEW IOT. T3695000 * 5. NULLIFY THE OLD PDDB. T3695500 * 6. TRACK-ADDRESS-CHAIN THE IOT LIFO TO JCTSPIOT. T3696000 * 7. WRITE THE IOT TO ITS ASSIGNED TRACK. T3696500 * 8. MAIN-STORAGE-CHAIN THE IOT LIFO TO $SVSPIOT. T3697000 * 9. NOTIFY HASPXEQ THAT AN ADDITION HAS BEEN MADE TO T3697500 * $SVSPIOT AND RETURN NORMALLY. T3698000 * T3698500 * REGISTERS AT ENTRY - T3699000 * R2 = LOCAL BASE, FROM ROUTINE HJEAHOLD T3699500 * R4 = PDDB TO BE PROCESSED T3700000 * R6 = RETURN ADDRESS T3700500 * R7 = HASP JCT T3701000 * R11 = SUBSYSTEM VECTOR TABLE T3701500 * R13 = SUBSYSTEM JOB BLOCK T3702000 * T3702500 * REGISTER USAGE IN ADDITION TO ABOVE - T3703000 * R0 = WORK, SUBROUTINE ARGUMENT T3703500 * R1 = SUBROUTINE ARGUMENT T3704000 * R5 = NEW IOT T3704500 * R14 = SUBROUTINE RETURN T3705000 * R15 = SUBROUTINE ENTRY T3705500 * T3706000 * REGISTER DIFFERENCE AT EXIT - T3706500 * R5 = 0 T3707000 * R0, R1, R10, R14, R15 DESTROYED T3707500 * T3708000 * EXIT - NORMAL T3708500 * ON R6 WITH R5 POINTING TO NEW IOT T3709000 * T3709500 * EXIT - ERROR T3710000 * ON R6 WITH MESSAGE HASP376 WRITTEN AND NEW IOT T3710500 * STORAGE FREED T3711000 * T3711500 * EXIT - NULL T3712000 * ON R6 WITH NO ACTION TAKEN T3712500 * T3713000 EJECT T3713500 HJH100 DS 0H T3714000 TM PDBFLAG1,PDB1NULL+PDB1NSOT IF DATA SET IS NULL OR T3714500 BNZR R6 NOT FOR SYSOUT, NULL RETURN. T3715000 SLR RIOT,RIOT SHOW NO NOW IOT. T3715500 CALL HCBGM GET MAIN STORAGE FOR IOT. T3716000 BNZ HJH800 ERROR RETURN - NO STORAGE. T3716500 LR RIOT,R1 SHOW NEW IOT ADDRESS. T3717000 L R1,SJBIOT POINT TO ALLOCATION IOT. T3717500 LA R1,IOTMSTAB-IOTDSECT(,R1) PT TO MASTER TAB R4 T3717600 CALL $STRAK GET A TRACK FOR NEW IOT. T3718500 L R15,SJBIOT GET ALLOCATION IOT ADDRESS @OZ17477 T3718600 OI IOTFLAG1-IOTDSECT(R15),IOT1CKPT FORCE IOT CHKPT @OZ17477 T3718700 LA R10,HJHCON POINT R10 TO FAKE SSAL. T3719000 CALL HALCRIOT FORMAT THE NEW IOT. T3719500 USING IOTDSECT,RIOT SET NEW IOT ADDRESSABILITY. T3720000 L R15,$SVPDDB1 MOVE PDDB R4 T3720300 LA R14,0(R15,RIOT) TO R4 T3720500 MVC 0(PDBLENG,R14),PDBDSECT NEW IOT R4 T3720800 NI PDBFLAG1-PDBDSECT(R14),PDB1LOG CLEAR ALL BUT LOG BIT R4 T3721000 OI PDBFLAG1-PDBDSECT(R14),PDB1HOLD+PDB1PSO R4 T3721500 OI PDBFLAG1,PDB1NSOT NULLIFY OLD PDDB. T3722000 LA R0,PDBLENG(,R15) SET PDDB LIMIT R4 T3722500 ST R0,IOTPDDBP OFFSET IN NEW IOT. T3723000 MVC IOTIOTTR,JCTSPIOT TRACK-ADDRESS CHAIN T3724000 L R0,IOTTRACK NEW IOT ONTO T3724500 ST R0,JCTSPIOT JCT'S SPIN CHAIN LIFO. T3725000 OI JCTFLAG1,JCT1CKPT FLAG JCT FOR CHECKPOINT. T3725500 CALL HIOTSPIN SPIN/HOLD THE IOT. T3726000 BR R6 NORMAL RETURN. T3730500 DROP R3,R4,R5 DROP BASES. T3731000 HJHCON EQU *-(SSALFLG1-SSALBGN) FAKE SSAL FOR SSALHOLD FLAG. T3731500 DC AL1(SSALHOLD) FLAG SSALHOLD IN BYTE SSALFLG1. T3732000 SPACE 2 T3732500 $MID 376 SET HASP MESSAGE ID. T3733000 HJH800 WTO '&MID.- UNABLE TO PROCESS SUBSYSTEM DATA SET FOR HOLD', CT3733500 ROUTCDE=11,DESC=6 T3734000 LR R1,RIOT POINT R1 TO IOT OR ZERO. T3734500 CALL HCBFM FREE NEW IOT STORAGE. T3735000 BR R6 ERROR RETURN. T3735500 DROP , DROP ALL ADDRESSABILITY. T3736000 SPACE 4 R4 T3736100 LTORG R4 T3736200 TITLE 'HIOTSPIN - SPIN THE ARGUMENT IOT' T3736300 * T3736400 * ROUTINE NAME - HIOTSPIN T3736500 * T3736600 * PURPOSE - TO PASS A SPIN/HOLD IOT TO HASPXEQ ON CHAIN T3736700 * $SVSPIOT TO BE SPUN OR HELD T3736800 * T3736900 HIOTSPIN DS 0H T3737000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T3737100 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T3737200 L R15,SJBJCT POINT TO THE JCT AND SET T3737300 USING JCTDSECT,R15 TEMPORARY ADDRESSABILITY. T3737400 STM R14,R12,JCTWORK+12 SAVE REGS IN JCTWORK. T3737500 DROP R15 KILL TEMP. JCT ADDRESSABILITY R4 T3737600 USING JCTDSECT,R7 SET NORMAL JCT ADDRESSABILITY R4 T3737700 BALR R12,0 ESTABLISH T3737800 USING *,R12 LOCAL ADDRESSABILITY. T3737900 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T3738000 LH R1,$SVBFSIZ GET SPIN IOT R4 T3738100 LA R0,IOTSTART-IOTDSECT(,R1) BUFFER STORAGE R4 T3738200 $GETMAIN RC,LV=(R0),SP=231,KEY=1 IN CSA R4 T3738300 L R7,SJBJCT RESTORE JCT ADDRESS R4 T3738400 BZ HIS010 BR IF STORAGE OBTAINED R4 T3738500 $MID 358 SET MESSAGE NUMBER R4 T3738600 WTO '&MID.HIOTSPIN - NO STORAGE AVAILABLE IN SP 231', R4CT3738700 ROUTCDE=10,DESC=6 R4 T3738800 ICM R1,7,SJBTCBP+1 IF TCB POINTER NOT ZERO, @OZ58848 T3738900 BNZ HIS005 THIS WAS NOT REQ-JOBID JOB @OZ58848 T3738920 OI SDBFLG2-SDBDSECT(RSDB),SDB2LOG SHOW SYSLOG... @OZ58848 T3738940 EJECT @OZ36864 T3738950 B HIS900 .....ERROR, THEN EXIT @OZ58848 T3738960 SPACE 1 @OZ58848 T3738970 HIS005 DS 0H @OZ58848 T3738980 L R3,$SVPDDB1 POINT TO SPIN @OZ41600 T3739000 ALR R3,RIOT DATASET PDDB IN LSQA @OZ41600 T3739020 USING PDBDSECT,R3 GET PDDB ADDRESSABILITY @OZ41600 T3739040 OI PDBFLAG1,PDB1NSOT NO PRINT OF LOST DATASET @OZ41600 T3739060 MVC IOTJQOFF,JCTJQE STORE JQE OFFSET IN IOT @OZ41600 T3739080 NI IOTFLAG1,255-IOT1CKPT RESET CHECKPOINT FLAG @OZ41600 T3739100 L R0,IOTTRACK SET TRACK OF IOT @OZ41600 T3739120 LR R1,RIOT AND IOT'S STORAGE ADDR @OZ41600 T3739140 CALL HCBWR WRITE THE IOT @OZ41600 T3739160 CALL HCBFM FREE OLD SPIN IOT @OZ41600 T3739180 B HIS900 THEN EXIT @OZ41600 T3739200 EJECT @OZ58848 T3739220 HIS010 LR R8,R1 RELOAD IOT ADDRESS @OZ41600 T3739240 * T3739600 * FOR HOLD DATA SETS, PERFORM HQT PROCESSING T3739700 * T3739800 L R3,$SVPDDB1 POINT TO R4 T3739900 ALR R3,RIOT SPIN DATA SET PDDB R4 T3740000 USING PDBDSECT,R3 PROVIDE PDDB ADDRESSABILITY R4 T3740100 TM PDBFLAG1,PDB1NULL+PDB1NSOT DATA SET PRINTABLE... R41 T3740200 BZ *+8 BR IF YES R41 T3740300 NI PDBFLAG1,255-PDB1HOLD DON'T BOTHER HOLDING R41 T3740400 TM PDBFLAG1,PDB1HOLD SHOULD DATA SET BE HELD... R4 T3740500 BZ HIS060 FLAG IS OFF, SKIP AROUND. T3740600 DROP R3 KILL PDDB ADDRESSABILITY R4 T3742500 SKIP280 SLR R1,R1 ZERO R1 - WILL BECOME IOTHQT. T3742600 LH R3,JCTHQRCT GET CT OF HQRS BEFORE THIS. T3742700 LTR R4,R3 TEST AND SAVE FOR LATER. T3742800 LA R6,1(,R3) INCREMENT HQR COUNT. T3742900 BZ HIS020 BRANCH IF THIS IS 1ST HQR. T3743000 SLR R2,R2 ZERO HIGH DIVIDEND. T3743100 D R2,$SVHQRCT DIVIDE HQR CT BY HQRS/HQT R4 T3743200 LTR R2,R2 IF REMAINDER IS ZERO, T3743300 BNZ HIS040 WE NEED A NEW HQT TRACK. T3743400 B HIS030 GET NEW HQT TRACK R4 T3743500 * NEW HQT NEEDED - GET A TRACK FOR IT T3743600 HIS020 DS 0H T3743700 L R1,JCTHQT IF TRACK ADDRESS T3743800 LTR R1,R1 IN JCTHQT, T3743900 BNZ HIS040 BR TO USE FOR 1ST HQT. T3744000 HIS030 L R1,SJBIOT POINT TO MAIN ALLOCATION IOT R4 T3744100 LA R1,IOTMSTAB-IOTDSECT(,R1) SET ARG TO $STRAK R4 T3744200 CALL $STRAK GET A TRACK FOR NEW HQT. T3744300 EJECT @OZ36864 T3744400 * SET HQT INFORMATION IN JCT, IOT, AND HQT @OZ36864 T3744500 SPACE 1 @OZ36864 T3744600 HIS040 ST R1,IOTHQT STORE HQT TRACK ADDRESS @OZ36864 T3744700 MVC IOTHQT1,JCTHQT AND PTR TO FIRST HQT @OZ36864 T3744800 STH R6,JCTHQRCT UPDATE HQR COUNT IN JCT @OZ36864 T3744900 SPACE 1 @OZ36864 T3745000 * IF FIRST HELD DATA SET, WRITE JCT AT HQT LOCATION @OZ36864 T3745100 SPACE 1 @OZ36864 T3745200 LTR R4,R4 FIRST HELD DATA SET... @OZ36864 T3745300 BNZ HIS045 BR IF NO @OZ36864 T3745400 ST R1,JCTHQT STORE POINTER TO 1ST HQT @OZ36864 T3745500 ST R1,IOTHQT1 IN JCT AND IN IOT @OZ36864 T3745600 LR R0,R1 RELOAD HQT TRACK ADDRESS @OZ36864 T3745700 LR R1,R7 RELOAD JCT ADDRESS @OZ36864 T3745800 CALL HCBWR WRITE JCT AT HQT LOCATION @OZ36864 T3745900 SPACE 1 @OZ36864 T3746000 * REWRITE THE JCT, UNLESS CALLED BY THE CONVERTER @OZ36864 T3746100 SPACE 1 @OZ36864 T3746200 HIS045 TM SJBFLG2,SJB2CONV CALLED BY CONVERTER... @OZ36864 T3746300 BO HIS060 BR IF YES @OZ36864 T3746400 NI JCTFLAG1,FF-JCT1CKPT RESET CHECKPOINT FLAG @OZ36864 T3746500 L R0,SJBJCTRK GET JCT TRACK ADDRESS @OZ36864 T3746600 LR R1,R7 RELOAD JCT ADDRESS @OZ36864 T3746700 CALL HCBWR WRITE THE JCT @OZ36864 T3746800 B HIS060 GO WRITE AND QUEUE IOT @OZ36864 T3746900 EJECT @OZ36864 T3747000 * T3747700 * FOR SPIN/HOLD DATA SETS, WRITE AND QUEUE THE IOT T3747800 * T3747900 HIS060 DS 0H T3748000 MVC IOTJQOFF,JCTJQE STORE JQE OFFSET IN IOT. T3748100 MVC IOTHQRCT,JCTHQRCT SET UNALLOCATION NUMBER IN IOT R4 T3748200 NI IOTFLAG1,255-IOT1CKPT RESET CHECKPOINT FLAG R41 T3748300 TM SJBFLG2,SJB2CONV CALLED BY CONVERTER... @OZ36864 T3748310 BO *+8 BR IF YES @OZ36864 T3748320 OI IOTFLAG1,IOT1NTPR SET NOT PROCESSED FLAG @OZ35742 T3748350 L R0,IOTTRACK SET TRACK OF IOT T3748400 LR R1,RIOT AND IOT'S STORAGE ADDRESS. T3748500 CALL HCBWR WRITE THE IOT. T3748600 MVC JCTWORK+20+RIOT*4(4),IOTIOT SAVE OLD IOT CHAIN. T3748700 LH R1,IOTLENG MOVE R4 T3748800 LR R0,R8 SPIN R4 T3748900 LR R15,R1 IOT R4 T3749000 LR R14,RIOT TO R4 T3749100 MVCL R0,R14 CSA R4 T3749200 LR R1,RIOT FREE OLD R4 T3749300 CALL HCBFM SPIN IOT R4 T3749400 LR RIOT,R8 RELOAD NEW SPIN IOT ADDRESS R4 T3749500 TM SJBFLG2,SJB2CONV CALLED BY CONVERTER... @OZ36864 T3749510 BZ HIS070 BR IF NO @OZ36864 T3749520 EJECT @OZ36864 T3749530 ***************************************************************@OZ36864 T3749540 * @OZ36864 T3749550 * IF CALLED BY CONVERTER SUBTASK, ERRORS WERE FOUND. @OZ36864 T3749560 * THE JOB WILL BE QUEUED FOR OUTPUT BY THE CONVERSION @OZ36864 T3749570 * PROCESSOR UPON RETURN FROM THE CONVERTER SUBTASK. @OZ36864 T3749580 * SUBSYSTEM DATA SETS WHICH ARE TO BE HELD MUST BE @OZ36864 T3749590 * HANDLED BY THE CONVERSION PROCESSOR PRIOR TO ITS @OZ36864 T3749600 * QUEUING THE JOB FOR OUTPUT. THIS AVOIDS WARM START @OZ36864 T3749610 * CONSIDERATIONS FOR JOBS IN CONVERSION PROCESSING @OZ36864 T3749620 * AND ENSURES THAT THE JOB NOT BE PURGED BY THE @OZ36864 T3749630 * OUTPUT PROCESSOR DURING SPIN/HOLD PROCESSING BY @OZ36864 T3749640 * HASPXEQ OR HASPHOLD. @OZ36864 T3749650 * @OZ36864 T3749660 ***************************************************************@OZ36864 T3749670 SPACE 1 @OZ36864 T3749680 LA R8,$SVXIOTQ-(IOTIOT-IOTDSECT) PREPARE TO SCAN Q @OZ36864 T3749690 SPACE 1 @OZ36864 T3749700 HIS065 LR R1,R8 SAVE LAST IOT ADDRESS @OZ36864 T3749710 ICM R8,15,IOTIOT-IOTDSECT(R1) POINT TO NEXT @OZ36864 T3749720 BNZ HIS065 LOOP UNTIL END OF CHAIN @OZ36864 T3749730 ST RIOT,IOTIOT-IOTDSECT(,R1) ADD IOT TO END OF @OZ36864 T3749740 ST R8,IOTIOT PCE HOLD QUEUE @OZ36864 T3749750 OI IOTFLAG1,IOT1CKPT FLAG IOT FOR CHECKPOINT @OZ36864 T3749760 B HIS900 BRANCH TO EXIT @OZ36864 T3749770 SPACE 1 @OZ36864 T3749780 HIS070 L R0,$SVSPIOT CHAIN @OZ36864 T3749790 ST R0,IOTIOT IOT @OZ36864 T3749795 CS R0,RIOT,$SVSPIOT ON T3749800 BNE *-8 $SVSPIOT. T3749900 $$POST ELMT=$SVJOB ACTIVATE JES2. T3750000 HIS900 LM R14,R12,JCTWORK+12 RESTORE REGISTERS R4 T3750100 BR R14 AND RETURN. T3750200 DROP , DROP ALL ADDRESSABILITY. T3750300 LTORG R4 T3750400 TITLE 'HASP SUBSYSTEM SUPPORT ROUTINE -- OPEN' T3750500 * T3750600 * T3750700 * HASP SUBSYSTEM SUPPORT ROUTINE -- OPEN T3750800 * T3750900 * T3751000 HOSOPEN $PROLOG SSOBOPEN,SSDASIZE,LOCK=SDB OPEN T3751100 HOSOPENB DS 0H OPEN BASE LABEL T3751200 SPACE 1 T3751300 RJFC EQU R7 RJFC IS REGISTER 7. T3751400 RDEB EQU R6 RDEB IS REGISTER 6. T3751500 * T3751600 * USE SUBROUTINE TO SET UP REGISTERS AND T3751700 * TO DETERMINE TYPE OF OPEN T3751800 * T3751900 CALL HOCSETUP CALL SUBROUTINE. T3752000 USING DEBBASIC,RDEB SET DEB ADDRESSABILITY. T3752100 USING INFMJFCB,RJFC SET JFCB ADDRESSABILITY. T3752200 USING SSDABGN,RSIB SET SSDA ADDRESSABILITY. T3752300 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T3752400 B HO000 INTERNAL READER T3752500 B HO100 SUBSYSTEM DATA SET - SI T3752600 B HO200 SUBSYSTEM DATA SET - SO T3752700 B HO300 SUBSYSTEM DATA SET - PS T3752800 B HO400 SUBSYSTEM DATA SET - INVALID T3752900 B HOERR ERROR DETECTING TYPE T3753000 EJECT T3753100 * T3753200 * O P E N I N T E R N A L R E A D E R T3753300 * T3753400 HO000 DS 0H T3753500 USING DCTDSECT,RSDB SET DCT ADDRESSABILITY. T3753600 ******************************************************************* L R1,548 USING ASCB,R1 L R1,ASCBASXB DROP R1 USING ASXB,R1 L R1,ASXBSENV DROP R1 LTR R1,R1 BZ HO000_NO_ACEE USING ACEE,R1 MVC RIDUSER(8),ACEEUSRI B HO000_USERID_INSERTED HO000_NO_ACEE DS 0H XC RIDUSER(8),RIDUSER DROP R1 HO000_USERID_INSERTED DS 0H ******************************************************************* ST RSDB,DEBIRBAD SAVE DCT ADDRESS IN DEB. T3753800 MVC DEBAPPAD,=A(HASPAM) SET HAM ADDRESS IN DEB. T3753900 L R1,DEBDCBAD POINT TO OPENING ACB. T3754000 USING IFGACB,R1 SET ACB ADDRESSABILITY. T3754500 MVC ACBINRTN,=A(HASPAM) POINT ACB TO HASP ACS METH. T3755000 OI ACBINRTN,ACBINR SHOW DEB POINTS TO INTRDR. T3755500 SLR R15,R15 SET NORMAL RETURN CODE. T3756000 ST R15,RIDUBF ZERO UNPROTECTED-BUFFER POINTER T3756500 $EPILOG , RETURN TO CALLER. T3757000 DROP R1 DROP ACB ADDRESSABILITY. T3757500 EJECT T3758000 * T3758500 * O P E N S Y S I N D A T A S E T T3759000 * T3759500 HO100 DS 0H T3760000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T3760500 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T3761000 * IF XBM AND ALREADY OPEN, DON'T OPEN AGAIN. T3761500 TM SJBFLG1,SJB1XBM IF NOT XBM, T3762000 BZ HO107 CONTINUE. T3762500 L R0,SDBUBF IF NO UNPROTECTED BUFFER, T3763000 LTR R0,R0 DATA SET IS NOT OPEN - T3763500 BZ HO107 CONTINUE. T3764000 BAL R14,HODEBACB ELSE SET UP DEB & ACB T3764500 B HORET AND RETURN. T3765000 * NOT XBM AND/OR NOT OPEN - CONTINUE NORMALLY T3765500 HO107 DS 0H T3766000 * T3766500 * O P E N P R O C E S S - S Y S O U T D A T A S E T T3767000 * T3767500 HO300 DS 0H T3768000 L R0,SDBDEB GET SDB'S DEB POINTER. T3768500 LTR R0,R0 IF NO DEB, DATA SET IS T3769000 BZ HO110 CLOSED. GO OPEN IT. T3769500 TM SJBFLG1,SJB1XBM IF OPEN ALREADY AND XBM, T3770000 BO HORET IGNORE OPEN. T3770500 B HOERR NOT XBM BUT OPEN - ERROR. T3771000 HO110 DS 0H T3771500 * T3772000 * OPEN SYSIN DATA SET T3772500 * T3773000 CALL HOOLDINP GET BUFFERS ETC. FOR DATA SET. T3773500 BNZ HOERR BRANCH IF HOOLDINP FAILED. T3774000 SLR R0,R0 ZERO T3774500 ST R0,SDBRECCT SDB RECORD COUNTER. T3775000 * TEST FOR CHECKPOINT RESTART T3775500 TM SSDARESF,SSDAAUTO+SSDADEFR IF NOT T3776000 BZ HO140 CHECKPOINT RESTART, BRANCH. T3776500 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER T3777000 USING BFD,RBUF AND SET ADDRESSABILITY. T3777500 L R1,SSDABUFR POINT TO RESTART BUFFER. T3778000 MVC BFRBA,16(R1) ASSUME AUTOMATIC RESTART. T3778500 TM SSDARESF,SSDAAUTO IF AUTOMATIC, T3779000 BO HO120 CONTINUE. T3779500 MVC BFRBA(5),SDBTRKF IF DEFERRED, SET STARTING T3780000 MVC BFRBA+5(3),25(R1) TRACK & SAVED RECORD COUNT. T3780500 * FOR CHECKPOINT RESTART, POSITION THE DATA SET. T3781000 HO120 DS 0H T3781500 DROP RBUF DROP BUFFER ADDRESSABILITY. T3782000 BAL R14,HODEBACB SET UP DEB AND ACB. T3782500 LCR R1,R1 COMPLEMENT ACB ADDRESS. T3783000 LA R0,HSVCPNT SET SVC FUNCTION = POINT. T3783500 SVC HAMSVC ISSUE HAM SVC. T3784000 B HORET RETURN TO CALLER. T3784500 * FOR STEP RESTART AND NORMAL OPEN, READ. T3785000 HO140 DS 0H T3785500 CALL HCNVFDAD CONVERT TRACK TO OS FORMAT. T3786000 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T3786500 BAL R14,HODEBACB SET UP DEB AND ACB. T3787000 EXCP SDBIOB READ IN FIRST RECORD. T3787500 WAIT 1,ECB=SDBECB WAIT FOR COMPLETION. T3788000 B HORET THEN RETURN. T3788500 EJECT T3789000 * T3789500 * O P E N S Y S O U T D A T A S E T T3790000 * T3790500 HO200 DS 0H T3791000 * T3791500 * UP OPEN COUNT. IF ALREADY OPEN, SET UP & EXIT T3792000 * T3792500 L R1,SDBCCW3+4 GET OPEN COUNT. T3793000 LA R0,1(,R1) INCREMENT IT. T3793500 ST R0,SDBCCW3+4 STORE OPEN COUNT. T3794000 LTR R1,R1 IF DATA SET WASN'T OPEN, T3794500 BZ HO203 GO OPEN IT. T3795000 LA R14,HORET ELSE SET RETURN ADDRESS T3795500 B HODEBACB AND SET UP DEB & ACB. T3796000 * T3796500 * OPEN SYSOUT DATA SET T3797000 * T3797500 HO203 DS 0H T3798000 L R1,SDBPDDB POINT TO PDDB FOR DATA SET. T3798500 USING PDBDSECT,R1 USE PDDB DSECT. T3799000 TM PDBFLAG1,PDB1NULL IS DATA SET OLD... T3799500 BO HO210 BRANCH IF NOT. T3800000 DROP R1 DROP PDDB BASE. T3800500 CALL HOOLDOUT YES. OPEN FOR OLD OUTPUT. T3801000 BNE HOERR ERROR - OPEN FAILED. T3801500 * T3802000 * FOR OLD SYSOUT, SET CURRENT RBA T3802500 * T3803000 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T3803500 USING BFD,RBUF USE THE UBF DSECT. T3804000 LM R0,R1,SDBTRK GET RESUME TRACK AND T3804500 STM R0,R1,BFRBA SET IT IN BFRBA. T3805000 ALR R0,R1 ERROR IF ZERO TRACK AND T3805500 BZ HOERR PDB1NULL IS OFF. T3806000 BAL R14,HODEBACB SET UP DEB AND ACB. T3806500 TM SSDARESF,SSDAAUTO IF NOT A RESTART CALL, T3807000 BZ HO205 GO CHECK CLOSED-AT-CHECKPOINT. T3807500 L R1,SSDABUFR POINT TO RESTART DATA. T3808000 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T3808500 MVC SDBTRKF(16),8(R1) SET SDBTRKF, SDBTRK, T3809000 MVC BFRBA,16(R1) AND BFRBA FROM RESTART DATA. T3809500 B HO207 BR TO CONTINUE R41 T3810000 HO205 DS 0H T3810500 CLC =X'FFFFFF',SDBTRK+5 IF NOT CLOSED-AT-CHECKPOINT, T3811000 BNE HORET RETURN TO CALLER. T3811500 LCR R1,R1 SET ACB COMPLEMENT. T3812000 LA R0,HSVCPNT SET FUNCTION REGISTER. T3812500 SVC HAMSVC POSITION TO END OF DATA SET. T3813000 CL R15,=A(HERNOEOD) IF EOD NOT FOUND, T3813500 BNE HOERR ERROR. T3814000 LA R0,1 OTHERWISE, SET T3814500 STCM R0,7,SDBTRK+5 RECORD NUMBER ONE T3815000 L RBUF,SDBUBF IN SDBTRK T3815500 STCM R0,7,BFRBA+5 AND IN BFRBA. T3816000 B HORET RETAB DONE BY POINT @OZ35029 T3816100 HO207 ICM R0,15,SDBTRK+1 GET RESUME MTTR R41 T3816200 CALL HJSRETAB RE-BUILD TRACK ALLOC. BLOCK R41 T3816300 B HORET RETURN. T3816500 * T3817000 * OPEN NEW SYSOUT T3817500 * T3818000 SPACE 2 T3818500 HO210 DS 0H T3819000 CALL HONEWOUT OPEN NEW SYSOUT DATA SET. T3819500 BNE HOERR ERROR IF NO STORAGE. T3819800 BAL R14,HODEBACB SET UP DEB AND ACB. T3820000 * T3820500 * SET MTTR, RECFM, LRECL, FCB, UCS, AND FUNC T3821000 * T3821500 USING IOTDSECT,RIOT SET IOT AND PDDB T3822000 USING PDBDSECT,R6 ADDRESSABILITY. T3822500 L RIOT,SDBAIOT SET CHECKPOINT FLAG T3823000 OI IOTFLAG1,IOT1CKPT IN ALLOCATION IOT. T3823500 L RIOT,SDBPIOT POINT TO PDDB'S IOT. T3824000 L R6,SDBPDDB POINT TO PDDB. T3824500 L R4,PDBMTTR SET R4 = STARTING TRACK T3825000 LH R3,PDBDSKEY AND R3 = DATA SET KEY. T3825500 HO270 DS 0H T3826000 * SET PDBRECFM T3826500 MVC PDBRECFM,JFCRECFM SET PDBRECFM FROM JFCB. T3827000 * SET PDBLRECL T3827500 LH R0,JFCLRECL GET LRECL FROM JFCB. T3828000 LTR R0,R0 IF JFCLRECL IS NONZERO, T3828100 BNZ *+8 CONTINUE. T3828200 LH R0,JFCBLKSI OTHERWISE USE JFCBLKSI. T3828300 TM JFCRECFM,JFCFIX IF RECFM=F, T3828500 BO HO275 USE IT. T3829000 TM JFCRECFM,JFCVAR IF RECFM=U, T3829500 BZ HO275 USE IT. T3830000 SH R0,=H'4' FOR RECFM=V, SUBTRACT 4. T3830500 TM JFCRECFM,JFCRFS TEST FOR SPANNED RECORDS @OZ34422 T3830600 BZ HO275 NOT SPANNED, USE JFCRECFM @OZ34422 T3830700 MVI PDBRECFM,JFCUND ELSE FAKE 'U' FOR XWTR OPEN @OZ34422 T3830800 HO275 STH R0,PDBLRECL SET PDBLRECL. T3831000 * SET PDBUCS T3831500 L R0,JFCUCSID GET UCS FROM JFCB. T3832000 LTR R0,R0 IF ZERO, T3832500 BZ *+8 DON'T USE IT. T3833000 ST R0,PDBUCS ELSE SET PDBUCS. T3833500 * SET PDBFCB T3834000 L R0,JFCFCBID GET FCB FROM JFCB. T3834500 LTR R0,R0 IF ZERO, T3835000 BZ *+8 DON'T USE IT. T3835500 ST R0,PDBFCB ELSE SET PDBFCB. T3836000 * SET PDBFUNC T3836500 MVC PDBFUNC,JFCFUNC SET PDBFUNC FROM JFCB. T3837000 EJECT R4 T3837100 * SET PDB2OPTJ R4 T3837200 TM JFCOPTCD,JFCOPTJ SET OR R41 T3837300 BZ SKIP290 RESET R4 T3837400 OI PDBFLAG2,PDB2OPTJ PDB2OPTJ R4 T3837500 B SKIP300 BASED UPON R4 T3837600 SKIP290 NI PDBFLAG2,255-PDB2OPTJ JFCOPTCD R4 T3837700 SPACE 1 R4 T3837800 * R4 T3837900 * IF 3800 JFCB EXTENSION EXISTS, SET PDDB 3800 FIELDS R4 T3838000 * R4 T3838100 SKIP300 TM JFCUCSOP,JFCBEXTP TEST FOR 3800 EXTENSION R41 T3838200 BNO HO279 BR IF NOT R4 T3838300 SPACE 1 R4 T3838400 L R15,JFCBEXAD-1 ESTABLISH JFCB R4 T3838500 USING JFCBE-16,R15 EXTENSION ADDRESSABILITY R4 T3838600 SPACE 1 R4 T3838700 * SET PDB2BRST R4 T3838800 TM JFCBFLAG,JFCBBST SET OR R4 T3838900 BZ SKIP310 RESET R4 T3839000 OI PDBFLAG2,PDB2BRST PDB2BRST R4 T3839100 B SKIP320 BASED UPON R4 T3839200 SKIP310 NI PDBFLAG2,255-PDB2BRST JFCBFLAG R4 T3839300 * SET PDBMODF/PDBMODFT R4 T3839400 SKIP320 L R0,JFCMODIF SET R4 T3839500 CL R0,=X'40404040' CHARS FROM @OZ34625 T3839510 BE SKIP330 JFCMODIF TO @OZ34625 T3839520 LTR R0,R0 PDBMODF, R4 T3839600 BZ SKIP330 PDBMODFT @OZ34625 T3839700 ST R0,PDBMODF IF R4 T3839800 MVC PDBMODFT,JFCIDTRC SPECIFIED R4 T3839900 * SET PDBFLASH/PDBFLSHC R4 T3840000 SKIP330 L R0,JFCBMAGT SET R4 T3840100 CL R0,=X'40404040' CHARS FROM @OZ36611 T3840130 BE SKIP340 JFCBMAGT TO @OZ36611 T3840160 LTR R0,R0 PDBFLASH, R4 T3840200 BZ SKIP340 PDBFLSHC @OZ36611 T3840300 ST R0,PDBFLASH IF R4 T3840400 MVC PDBFLSHC,JFCIMTOT SPECIFIED R4 T3840500 * SET PDBCHAR1-4 R4 T3840600 SKIP340 L R0,JFCBTRS1 SET R4 T3840700 CL R0,=X'40404040' CHARS FROM @OZ30543 T3840710 BE SKIP350 JFCB TO @OZ30543 T3840720 LTR R0,R0 PDBCHAR1 R4 T3840800 BZ SKIP350 IF @OZ30543 T3840900 ST R0,PDBCHAR1 SPECIFIED T3841000 SKIP350 L R0,JFCBTRS2 SET R4 T3841100 CL R0,=X'40404040' CHARS FROM @OZ30543 T3841110 BE SKIP360 JFCB TO @OZ30543 T3841120 LTR R0,R0 PDBCHAR2 R4 T3841200 BZ SKIP360 IF @OZ30543 T3841300 ST R0,PDBCHAR2 SPECIFIED R4 T3841400 SKIP360 L R0,JFCBTRS3 SET R4 T3841500 CL R0,=X'40404040' CHARS FROM @OZ30543 T3841510 BE SKIP370 JFCB TO @OZ30543 T3841520 LTR R0,R0 PDBCHAR3 R4 T3841600 BZ SKIP370 IF @OZ30543 T3841700 ST R0,PDBCHAR3 SPECIFIED R4 T3841800 SKIP370 L R0,JFCBTRS4 SET R4 T3841900 CL R0,=X'40404040' CHARS FROM @OZ30543 T3841910 BE SKIP380 JFCB TO @OZ30543 T3841920 LTR R0,R0 PDBCHAR4 R4 T3842000 BZ SKIP380 IF @OZ30543 T3842100 ST R0,PDBCHAR4 SPECIFIED R4 T3842200 * SET PDBCOPYG R4 T3842300 SKIP380 MVC PDBCOPYG,JFCGROUP SET PDDB COPY GROUPS R4 T3842400 HO279 DS 0H R4 T3842500 EJECT R4 T3842600 * MERGE PDBUCS AND PDBCHAR1 R4 T3842700 CLC PDBUCS,=C'****' TEST FOR UCS SPECIFIED R4 T3842800 BNE SKIP390 BR IF YES R4 T3842900 MVC PDBUCS,PDBCHAR1 ELSE USE CHAR1 VALUS R4 T3843000 SKIP390 CLC PDBCHAR1,=C'****' TEST FOR CHAR1 SPECIFIED R4 T3843100 BNE SKIP400 BR IF YES R4 T3843200 MVC PDBCHAR1,PDBUCS ELSE USE UCS VALUE R4 T3843300 * END OF JFCB-TO-PDDB MERGE T3843400 SKIP400 OC PDBUCS,=X'40404040' SET BINARY ZEROES TO BLANKS. T3843500 OC PDBCHAR1,=X'40404040' SET ZEROES TO BLANKS. @OZ25663 T3843550 OC PDBFCB,=X'40404040' SET BINARY ZEROES TO BLANKS. T3843600 OI IOTFLAG1,IOT1CKPT FLAG IOT FOR CHECKPOINT. T3843700 TM PDBFLAG1,PDB1MDES IF NOT MULTIPLE T3843800 BZ HO290 DESTINATIONS, SKIP. T3843900 LA R6,PDBLENG(,R6) POINT TO NEXT PDDB. T3844000 L R0,IOTPDDBP COMPUTE ADDRESS OF T3844100 ALR R0,RIOT END OF PDDBS. T3844200 CLR R6,R0 IS THERE ANOTHER PDDB HERE... T3844300 BL HO280 BRANCH IF SO. T3844400 L RIOT,IOTIOT NO. POINT TO NEXT IOT. T3844500 LTR RIOT,RIOT IS THERE ANOTHER IOT... T3844600 BZ HO290 BRANCH IF NOT. T3844700 L R6,$SVPDDB1 YES. POINT TO R4 T3844800 ALR R6,RIOT FIRST PDDB. R4 T3844900 HO280 DS 0H T3845000 CH R3,PDBDSKEY IF DATA SET KEY DIFFERS, T3845500 BNE HO290 END OF MULT DEST PDDBS. T3846000 ST R4,PDBMTTR SET STARTING TRACK AND T3846500 NI PDBFLAG1,255-PDB1NULL RESET THE NULL FLAG. T3847000 B HO270 BRANCH TO SET MORE. T3847500 EJECT R4 T3847600 * T3848000 * CHECKPOINT AND RETURN T3848500 * T3849000 HO290 DS 0H T3849500 CALL HCBCK CHECKPOINT AS REQUIRED. T3850000 * RETURN TO CALLER T3850500 B HORET EXIT TO CALLER. T3851000 DROP R6,RIOT DROP PDDB, IOT BASES. T3851500 SPACE 5 T3852000 * T3852500 * ADD OTHER DATA SET TYPES HERE T3853000 * T3853500 HO400 DS 0H T3854000 $MID 352 T3854500 WTO '&MID.OPEN FAILED BECAUSE NOT SYSIN, SYSOUT, NOR PROCESSCT3855000 -SYSOUT',ROUTCDE=10,DESC=6 T3855500 B HOERR T3856000 EJECT T3856500 * T3857000 * SUBROUTINE TO SET UP DEB AND ACB T3857500 * T3858000 HODEBACB DS 0H T3858500 * ON ENTRY, R8 POINTS TO SSDA, R10 POINTS TO SDB T3859000 * ON EXIT, R6 POINTS TO DEB, R1 POINTS TO ACB T3859500 * CALL IS BAL R14,HODEBACB T3860000 * FIELDS SET - DEBIRBAD, DEBAPPAD, ACBINRTN T3860500 L RDEB,SSDADEBP POINT TO THE DEB FROM SSDA. T3861000 USING DEBBASIC,RDEB SET DEB ADDRESSABILITY. T3861500 ST RSDB,DEBIRBAD POINT DEB TO SDB. T3862000 ST RDEB,SDBDEB POINT SDB TO DEB. T3862500 L R0,=A(HASPAM) GET POINTER TO HASPAM. T3863000 ST R0,DEBAPPAD POINT DEB TO HASPAM. T3863500 L R1,DEBDCBAD POINT TO THE ACB FROM DEB. T3864000 LA R1,0(,R1) CLEAR HIGH-ORDER BYTE. T3864500 USING IFGACB,R1 SET ACB ADDRESSABILITY. T3865000 ST R0,ACBINRTN POINT ACB TO HASPAM. T3865500 BR R14 RETURN. T3866000 DROP R1,RDEB DROP ACB, DEB BASES. T3866500 SPACE 3 T3867000 * T3867500 * RETURN NORMALLY TO CALLER T3868000 * T3868500 HORET DS 0H T3869000 SR R15,R15 SET RETURN CODE TO ZERO. T3869500 $EPILOG KEY=0 *** TEMPORARY *** T3870000 SPACE 3 T3870500 * T3871000 * RETURN ABNORMALLY TO CALLER T3871500 * T3872000 HOERR DS 0H T3872500 LA R15,4 NOTE- NO RET CODES ARE DEFINED. T3873000 $EPILOG KEY=0 *** TEMPORARY *** T3873500 DROP RJFC,RSIB,RSDB,RSJB DROP JFCB, SSAL, SDB, SJB BASES. T3874000 TITLE 'OPEN PROCESSING FOR OLD INPUT DATASET' T3874500 * T3875000 * T3875500 * OPEN PROCESSING FOR ANY OLD INPUT DATASET T3876000 * T3876500 * T3877000 * LINKAGE --- T3877500 * CALL HOOLDINP T3878000 * T3878500 * INPUT --- T3879000 * RSDB POINTS TO AN SDB T3879500 * T3880000 * FIELDS USED --- T3880500 * SDBUBF IS SET T3881000 * SDBPBF IS SET T3881500 * SDBPDDB IS USED T3882000 * SDBTRKF IS SET T3882500 * SDBMTTR IS SET T3883000 * SDBCCW4 IS SET T3883500 * T3884000 * OPERATION --- T3884500 * 1. AN UNPROTECTED BUFFER IS GOTTEN AND ITS ADDRESS T3885000 * PLACED IN SDBUBF. T3885500 * 2. A PROTECTED BUFFER IS GOTTEN AND ITS ADDRESS T3886000 * PLACED IN SDBPBF. T3886500 * 3. THE TRACK ADDRESS IN THE PDDB IS MOVED TO SDBTRKF. T3887000 * T3887500 EJECT T3888000 HOOLDINP DS 0H T3888500 STM R14,R12,12(R13) SAVE REGISTERS. T3889000 BALR R12,0 ESTABLISH T3889500 USING *,R12 ADDRESSABILITY. T3890000 USING SDBDSECT,RSDB USE THE SDB DSECT. T3890500 * T3891000 * GET A UBF T3891500 * T3892000 $GETBUF TYPE=UNPROT GET A BUFFER. T3892500 BNZ HOOIFAIL BRANCH IF GETMAIN FAILED. T3893000 LR RBUF,R1 USE BUFFER REGISTER T3893500 USING BFD,RBUF AND BUFFER DSECT. T3894000 MVI BFID,C'U' SHOW UNPROTECTED BUFFER. T3894500 OI BFFL1,BF1EOB SHOW BUFFER EMPTY. R4 T3895000 ST RBUF,SDBUBF SET POINTER TO UBF IN SDB. T3895500 * T3896000 * GET A PBF T3896500 * T3897000 $GETBUF TYPE=PROT GET A BUFFER. T3897500 BNZ HOOIFAIL BRANCH IF GETMAIN FAILED. T3898000 LR RBUF,R1 USE BUFFER REGISTER. T3898500 MVI BFID,C'P' SHOW PROTECTED BUFFER. T3899000 ST RBUF,SDBPBF SET POINTER TO PBF IN SDB. T3899500 * T3900000 * SET STARTING TRACK ADDRESS AND KEYS T3900500 * T3901000 L R2,SDBPDDB POINT TO PDDB. T3901500 USING PDBDSECT,R2 USE ITS DSECT. T3902000 L R0,PDBMTTR GET STARTING TRACK. T3902500 LA R1,X'100' SET R1 FOR LATER SRDL. T3903000 ST R0,SDBMTTR SET SDBMTTR FOR CONVENIENCE. T3903500 SRDL R0,8 SET UP '0MTTR001'. T3904000 STM R0,R1,SDBTRKF SET SDBTRKF = STARTING TRACK. T3904500 MVC SDBDKEY,PDBDSKEY SET DATASET KEY IN SDB. T3905000 TM PDBFLAG2,PDB2NEWS JESNEWS DATA SET... @OZ39639 T3905100 BZ *+10 BR IF NO @OZ39639 T3905200 MVC SDBKEY,=C'$$NEWS' ELSE USE SPECIAL KEY @OZ39639 T3905300 LA R0,BFIO GET PBF READ START ADDRESS. T3905500 ST R0,SDBCCW4 SET IT IN CCW4. T3906000 MVI SDBCCW4,6 SET COMMAND TO READ. T3906500 OI SDBFLG1,SDB1GET SHOW GET ALLOWED ON DATASET. T3907000 NI SDBFLG1,255-SDB1CLOS RESET THE CLOSE FLAG. T3907500 NI SDBFLG2,255-SDB2IOE-SDB2EOD RESET FLAGS. T3908000 SR R15,R15 SHOW GOOD COMPLETION. T3908500 HOOIFAIL ST R15,16(,R13) LABEL FOR BAD COMPLETION. T3909000 LM R14,R12,12(R13) RESTORE REGISTERS. T3909500 BR R14 RETURN. T3910000 DROP R2,RBUF,R12 DROP PDB, BF, LOCAL BASES. T3910500 TITLE 'OPEN PROCESSING FOR NEW OUTPUT DATASET' T3911000 * T3911500 * T3912000 * OPEN PROCESSING FOR NEW OUTPUT DATASET T3912500 * T3913000 * T3913500 * LINKAGE --- T3914000 * CALL HONEWOUT T3914500 * T3915000 * INPUT --- T3915500 * RSDB POINTS TO AN SDB T3916000 * T3916500 * FIELDS USED --- T3917000 * SDBUBF IS SET T3917500 * SDBAIOT IS USED T3918000 * SDBPDDB IS USED T3918500 * SDBPIOT IS USED T3919000 * SDBTRKF IS SET T3919500 * SDBTRK IS SET T3920000 * UBFRBA IS SET T3920500 * PDBMTTR IS SET T3921000 * PDB1NULL IS RESET T3921500 * IOT1CKPT IS SET T3922000 * UBFPDDBK IS SET T3922500 * UBFDSKEY IS SET T3923000 * T3923500 * OPERATION --- T3924000 * 1. AN UNPROTECTED BUFFER IS GOTTEN AND ITS ADDRESS T3924500 * PLACED IN SDBUBF. T3925000 * 2. AN INITIAL TRACK IS GOTTEN FROM THE IOT POINTED T3925500 * TO BY SDBAIOT, AND ITS MTTR IS PLACED INTO SDBTRKF, T3926000 * SDBTRK, UBFRBA, AND PDBMTTR. THE PDDB KEY IS MOVED T3926500 * TO THE SDB AND THE UBF. PDB1NULL IS RESET. T3927000 * IOT1CKPT IS SET IN THE IOT POINTED TO BY SDBPIOT. T3927500 * T3928000 EJECT T3928500 * T3929000 * T3929500 * SUBROUTINE TO OPEN A NEW OUTPUT DATASET T3930000 * T3930500 * T3931000 HONEWOUT DS 0H T3931500 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS. T3932000 BALR R12,0 ESTABLISH T3932500 USING *,R12 ADDRESSABILITY. T3933000 ST R13,SDBSAVE+4 POINT SDB SAVEAREA TO USER'S. T3933500 ST RSDB,8(,R13) POINT USER'S SAVEAREA TO SDB. T3934000 LA R13,SDBSAVE SET R13 TO SDB SAVEAREA. T3934500 $GETBUF TYPE=UNPROT GET A BUFFER. T3935000 BNZ HONOFAIL BRANCH IF GETMAIN FAILED. T3935500 LR RBUF,R1 USE BUFFER REGISTER, T3936000 USING BFD,RBUF AND SET BUFFER ADDRESSABILITY. T3936500 MVI BFID,C'U' SHOW UNPROTECTED BUFFER. T3937000 LA R0,BFDAT SET IN BUFFER T3937500 ST R0,BFLOC POINTER TO FIRST DATA BYTE. T3938000 LH R0,$SVBFSIZ SET IN R4 T3938500 SL R0,=A(BFDAT+1-BFIO) BUFFER R4 T3938800 ST R0,BFLEN LENGTH OF DATA SPACE. T3939000 ST RBUF,SDBUBF SET POINTER TO UBF IN SDB. T3939500 * T3940000 * GET INITIAL TRACK FOR DATASET. T3940500 * T3941000 L R2,SDBPDDB POINT TO DATA SET'S PDDB. T3941200 USING PDBDSECT,R2 SET PDDB ADDRESSABILITY. T3941300 L R1,PDBMTTR IF DS PREVIOUSLY OPENED & T3941400 LTR R1,R1 CLOSED WITHOUT DATA, T3941500 BNZ HONO010 USE ORIG. STARTING TRACK. @OZ56167 T3941600 LA R1,SDBTAB POINT TO SDB'S TAB R4 T3941700 CALL $STRAK GET A TRACK. T3943500 ST R1,PDBMTTR SET STARTING TRACK ADDRESS. T3945000 B HONO020 SKIP RETAB FOR NEW TRACK. @OZ56167 T3945100 HONO010 DS 0H @OZ56167 T3945150 LR R0,R1 SET STARTING MTTR. @OZ56167 T3945200 CALL HJSRETAB REBUILD TRACK ALLOC. BLK. @OZ56167 T3945250 HONO020 DS 0H T3945300 NI PDBFLAG1,255-PDB1NULL SHOW PDDB NOT NULL. T3945500 MVC SDBDKEY,PDBDSKEY SET DS KEY IN SDB FROM PDDB. T3946000 TM PDBFLAG2,PDB2NEWS JESNEWS DATA SET... @OZ39639 T3946100 BZ *+10 BR IF NO @OZ39639 T3946200 MVC SDBKEY,=C'$$NEWS' ELSE USE SPECIAL KEY @OZ39639 T3946300 MVC BFKEY,SDBJKEY SET JOB AND DS KEY IN BUFFER. T3946500 L RIOT,SDBPIOT POINT TO PDDB'S IOT. T3947000 USING IOTDSECT,RIOT USE IOT DSECT. T3947500 OI IOTFLAG1,IOT1CKPT SHOW IOT NEEDS A CHECKPOINT. T3948000 LR R0,R1 SET UP T3948500 LA R1,X'100' R0 AND R1 T3949000 SRDL R0,8 TO '0MTTR001'. T3949500 STM R0,R1,SDBTRKF SET DATASET FIRST TRACK. T3950000 STM R0,R1,SDBTRK SET DATASET CURRENT TRACK. T3950500 STM R0,R1,BFRBA SET STARTING RBA IN BUFFER. T3951000 OI SDBFLG1,SDB1PUT SHOW PUT ALLOWED ON DATASET. T3951500 NI SDBFLG1,255-SDB1CLOS RESET THE CLOSE FLAG. T3952000 MVI SDBCCW4,5 SET WRITE-DATA COMMAND. T3952500 SR R15,R15 SHOW GOOD COMPLETION. T3953000 HONOFAIL DS 0H LABEL FOR BAD COMPLETION. T3953500 L R13,4(,R13) POINT TO CALLER'S SAVEAREA. T3954000 ST R15,16(,R13) SET R15 FOR RESTORE. T3954500 LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS. T3955000 LTR R15,R15 SET COND CODE ACCORDING TO R15. T3955500 BR R14 RETURN. T3956000 DROP R2,RIOT,RBUF,R12 DROP PDB, IOT, BF, LOCAL BASES. T3956500 TITLE 'OPEN PROCESSING FOR OLD OUTPUT DATASET' T3957000 * T3957500 * OPEN PROCESSING FOR OLD OUTPUT DATASET T3958000 * T3958500 * LINKAGE --- T3959000 * CALL HOOLDOUT T3959500 * T3960000 * INPUT --- T3960500 * RSDB POINTS TO AN SDB T3961000 * T3961500 * FIELDS USED --- T3962000 * SDBUBF IS SET T3962500 * SDBPDDB IS USED T3963000 * SDBTRKF IS SET T3963500 * SDBTRK IS SET T3964000 * UBFRBA IS SET T3964500 * PDBMTTR IS USED T3965000 * UBFPDDBK IS SET T3965500 * UBFDSKEY IS SET T3966000 * T3966500 * OPERATION --- T3967000 * 1. AN UNPROTECTED BUFFER IS GOTTEN AND ITS ADDRESS T3967500 * PLACED IN SDBUBF. T3968000 * FIELD UBFDSKEY IS SET. T3968500 * 2. FROM THE PDDB, MTTR IS MOVED TO SDBTRKF, SDBTRK, T3969000 * AND UBFRBA. PDBDSKEY IS MOVED TO UBFPDDBK AND T3969500 * TO SDBDKEY. T3970000 * T3970500 EJECT T3971000 * T3971500 * HOOLDOUT - SUBROUTINE TO OPEN AN OLD OUTPUT DATASET T3972000 * T3972500 HOOLDOUT DS 0H T3973000 STM R14,R12,12(R13) SAVE REGISTERS. T3973500 BALR R12,0 ESTABLISH T3974000 USING *,R12 ADDRESSABILITY. T3974500 $GETBUF TYPE=UNPROT GET A BUFFER. T3975000 BNZ HOOOFAIL BRANCH IF GETMAIN FAILED. T3975500 LR RBUF,R1 USE BUFFER REGISTER AND T3976000 USING BFD,RBUF SET BUFFER ADDRESSABILITY. T3976500 MVI BFID,C'U' SHOW UNPROTECTED BUFFER. T3977000 LA R0,BFDAT SET IN BUFFER T3977500 ST R0,BFLOC POINTER TO FIRST DATA BYTE. T3978000 LH R0,$SVBFSIZ SET IN R4 T3978500 SL R0,=A(BFDAT+1-BFIO) BUFFER R4 T3978800 ST R0,BFLEN LENGTH OF DATA SPACE. T3979000 ST RBUF,SDBUBF SET POINTER TO UBF IN SDB. T3979500 L R2,SDBPDDB POINT TO PDDB. T3980000 USING PDBDSECT,R2 USE DSECT. T3980500 OI SDBFLG1,SDB1PUT SHOW PUT ALLOWED. T3981000 NI SDBFLG1,255-SDB1CLOS RESET THE CLOSE FLAG. T3981500 MVC SDBDKEY,PDBDSKEY MOVE DATASET KEY TO SDB. T3982000 TM PDBFLAG2,PDB2NEWS JESNEWS DATA SET... @OZ39639 T3982100 BZ *+10 BR IF NO @OZ39639 T3982200 MVC SDBKEY,=C'$$NEWS' ELSE USE SPECIAL KEY @OZ39639 T3982300 MVC BFKEY,SDBJKEY SET JOB AND DS KEY IN BUFFER. T3982500 MVI SDBCCW4,5 SET WRITE-DATA COMMAND. T3983000 SR R15,R15 SHOW GOOD COMPLETION. T3983500 HOOOFAIL DS 0H T3984000 ST R15,16(,R13) SET R15 FOR RESTORE. T3984500 LM R14,R12,12(R13) RESTORE REGISTERS. T3985000 BR R14 RETURN. T3985500 DROP R2,RBUF,R12 DROP BASES. T3986000 TITLE 'FAKE OPEN SERVICE FOR CONVERTER' T3986500 * T3987000 * ROUTINE NAME - SSVOPNC T3987500 * T3988000 * PURPOSE - TO OPEN THE SUBSYSTEM DATA SETS REQUIRED FOR T3988500 * THE CONVERTER. T3989000 * T3989500 * FUNCTION - T3990000 * 1. PROCURE AN SJB AS A BASE FOR THE DATA SETS TO T3990500 * BE OPENED. T3991000 * 2. FOR EACH DATA SET TO BE OPENED, CALL HFCLSUB T3991500 * AND EITHER HOOLDINP OR HONEWOUT, EXCEPT - T3992000 * 3. IF CONVERTING FOR EXECUTION BATCH MONITOR, T3992500 * MOVE FAKE JCL TO BUFFER INSTEAD OF CALLING T3993000 * HOOLDINP. T3993500 * 4. INITIALIZE JES2 JOB LOG DATA SET WITH TITLE. T3994000 * 5. RETURN TO CALLER. T3994500 * T3995000 * OPERATION - T3995500 * 1. SAVE REGISTERS AND SET PROTECT KEY TO ZERO. T3996000 * SET R11 TO POINT TO SSVT. PRESERVE SAVE AREA T3996500 * POINTER IN R5. T3997000 * 2. IF NO SJB HAS BEEN GOT FOR CONVERTER T3997500 * (JPCESJBP=0), CALL $SJBINIT TO CREATE ONE. T3998000 * IF FAILURE, TAKE ERROR EXIT. T3998500 * SET FLAG SJB2CONV TO INDICATE CONVERTER SJB. T3999000 * STORE PCE POINTER IN SJBSSIB. T3999500 * STORE SJB POINTER IN JPCESJBP. T4000000 * 3. MOVE JOB KEY, JOB ID, JOB NAME, ESTIMATED T4000500 * PRINT LINES, AND ESTIMATED PUNCH CARDS TO THE T4001000 * SJB FROM THE JCT. T4001500 * 4. DOUBLE-CHAIN THE SJB SAVE AREA AND THE T4002000 * CALLER'S SAVE AREA. POINT THE SAVE AREA T4002500 * REGISTER, R13, TO THE SJB. T4003000 * 5. FOR THE JCL DATA SET, CALL HFOPSUB TO CON- T4003500 * STRUCT AN SDB AND SET POINTERS IN THE ACB AND T4004000 * DEB. THIS DATA SET'S ACB IS AT SYMBOL T4004500 * JPCEJCL. T4005000 * 6. THE JCL DATA SET IS CONSTRUCTED HERE IF THIS T4005500 * ROUTINE IS OPENING DATA SETS FOR BATCH MONITOR T4006000 * CONVERSION (JPCEXBNM IS THE BATCH MONITOR T4006500 * PROCEDURE NAME). GET AND FORMAT AN UNPROTEC- T4007000 * TED BUFFER, SAVING ITS ADDRESS IN SDBUBF. T4007500 * SET FLAG SDB2EOD TO PREVENT HAM ROUTINE HAMGET T4008000 * FROM INVOKING SVCGET FOR I/O. SET FLAG T4008500 * SDB1GET TO SHOW INPUT DATA SET. MOVE FAKE T4009000 * JOB, EXEC, AND DD CARDS TO THE BUFFER AND SET T4009500 * THE CONTENTS OF JPCEXBNM AS JOB NAME AND T4010000 * PROCEDURE NAME. T4010500 * 7. THE JCL DATA SET IS OPENED AND PRIMED IF T4011000 * JPCEXBNM IS ZERO. POINT SDBPDDB TO THE JCL T4011500 * DATA SET'S PDDB AND CALL HOOLDINP. TO PRIME, T4012000 * CALL HCNVFDAD TO CONVERT JES2 TRACK ADDRESS TO T4012500 * OS TRACK ADDRESS, ISSUE EXCP, AND WAIT. T4013000 * 8. FOR THE JCL IMAGES DATA SET, CALL HFOPSUB. T4013500 * THE ACB IS AT JPCEJCLI. T4014000 * 9. POINT SDBPDDB TO THE JCL IMAGES PDDB AND CALL T4014500 * HONEWOUT TO OPEN THE DATA SET. SET FLAG T4015000 * SDB1OUT TO SHOW DATA SET IS PRINTABLE. T4015500 * 10. FOR THE JES2 JOB LOG DATA SET, CALL HFOPSUB. T4016000 * THE ACB IS AT SJBLACB. THIS DATA SET IS NOT T4016500 * REQUIRED BY THE CONVERTER INTERFACE. T4017000 * 11. POINT SDBPDDB TO THIS DATA SET'S PDDB AND CALL T4017500 * HONEWOUT. SET FLAG SDB1OUT TO SHOW DATA SET T4018000 * IS PRINTABLE. MOVE TITLE TEXT TO DATA SET'S T4018500 * UNPROTECTED BUFFER AND ADJUST BUFFER POSITION T4019000 * AND REMAINING LENGTH. T4019500 * 12. FOR THE INTERNAL TEXT DATA SET, CALL HFOPSUB. T4020000 * THE ACB IS AT JPCETXT. T4020500 * 13. POINT SDBPDDB TO THIS DATA SET'S PDDB AND CALL T4021000 * HONEWOUT. T4021500 * 14. SET PROTECT KEY BACK TO 'HASP', RESTORE T4022000 * REGISTERS, AND RETURN TO CALLER WITH CONDITION T4022500 * CODE ZERO. T4023000 * 15. ERROR EXIT - FOR EACH SDB CHAINED FROM CHAIN T4023500 * WORD SJBSDB, CALL $SDBFREE. THEN RETURN TO T4024000 * CALLER WITH CONDITION CODE NONZERO. T4024500 * T4025000 * ENTRY - T4025500 * WORD $SVCOPN IN THE SUBSYSTEM VECTOR TABLE POINTS T4026000 * TO SSVOPNC. T4026500 * T4027000 * REGISTERS AT ENTRY - T4027500 * R5 = SUBSYSTEM VECTOR TABLE T4028000 * R8 = CONVERTER PROCESSOR CONTROL ELEMENT T4028500 * R13 = USER-SUPPLIED STANDARD SAVE AREA T4029000 * R14 = RETURN ADDRESS T4029500 * R15 = ENTRY ADDRESS T4030000 * T4030500 * REGISTERS USED IN ADDITION TO ABOVE - T4031000 * R0 = WORK, ARGUMENT TO $SJBINIT T4031500 * R1 = WORK, ARGUMENT TO HGFMAIN T4032000 * R2 = WORK FOR HGFMAIN T4032500 * R3 = CURRENT ACB T4033000 * R4 = LINKAGE TO HGFMAIN T4033500 * R5 = CURRENT IOT, FROM JPCEIOT T4034000 * R7 = WORK FOR HGFMAIN T4034500 * R10 = CURRENT SUBSYSTEM DATASET BLOCK T4035000 * R11 = SUBSYSTEM VECTOR TABLE T4035500 * R12 = LOCAL BASE T4036000 * R13 = SUBSYSTEM JOB BLOCK, FROM JPCESJBP T4036500 * R14 = LINK REGISTER FOR CALLS T4037000 * R15 = ENTRY REGISTER FOR CALLS T4037500 * T4038000 * REGISTERS CHANGED AT EXIT - T4038500 * R15 CONTAINS RETURN CODE - T4039000 * 0 - SUCCESSFUL COMPLETION T4039500 * 4 - UNABLE TO OPEN ALL DATA SETS T4040000 * 8 - UNABLE TO INITIALIZE SJB T4040500 * T4041000 * CONDITION CODE AT EXIT - T4041500 * 0 - REGISTER 15 IS ZERO T4042000 * 2 - REGISTER 15 IS FOUR OR EIGHT T4042500 * T4043000 SSVOPNC DS 0H T4043500 USING *,R15 ESTABLISH ADDRESSABILITY. T4044000 STM R14,R12,12(R13) SAVE USER'S REGISTERS. T4044500 MODESET EXTKEY=ZERO SET KEY ZERO FOR FAKE OPEN. T4045000 USING PCEDSECT,R8 USE PCE DSECT. T4045500 LR RSVT,R5 HOSCNVT PASSES SSVT IN R5. T4046000 LR R5,R13 SAVE USER SAVE AREA POINTER. T4046500 ICM RSJB,15,JPCESJBP POINT TO CONVERTER SJB. T4047000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T4047500 BNZ SOC10 BRANCH IF IT EXISTS. T4048000 LA R0,24(,R13) MAKE SAVE AREA A FAKE SSCVT. T4048500 CALL $SJBINIT ELSE GO BUILD ONE. T4049000 BALR R14,0 SET BASE REGISTER T4049300 USING *,R14 PROVIDE TEMPORARY ADDRESSABILITY T4049500 BNZ SOC820 BRANCH IF SJB NOT BUILT. T4050000 OI SJBFLG2,SJB2CONV SHOW CONVERTER SJB. T4050500 ST RSJB,JPCESJBP STORE SJB POINTER IN PCE. T4051000 ST R8,SJBSSIB POINT SJB TO CONVERTER PCE. T4051500 SOC10 BALR R12,0 ESTABLISH T4052000 USING *,R12 ADDRESSABILITY. T4052500 L R7,PCEJCT GET JCT ADDRESS FROM PCE. T4053000 ST R7,SJBJCT SET JCT POINTER INTO SJB @OZ26284 T4053300 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T4053500 MVC SJBJKEY,JCTJBKEY SET JOB KEY FROM JCT. T4054000 MVC SJBJOBID,JCTJOBID SET CONVERTER JOB ID. T4054500 MVC SJBJOBNM,JCTJNAME SET CONVERTER JOB NAME. T4055000 MVC SJBESTLN,JCTESTLN SET PRINT AND PUNCH T4055500 MVC SJBESTPU,JCTESTPU EXCESSION LIMITS. T4056000 ST RSJB,8(,R5) CHAIN T4056500 ST R5,SJBSAVE+4 SAVEAREAS. T4057000 USING IOTDSECT,RIOT USE THE IOT DSECT. T4057500 * T4058000 * OPEN THE JCL DATASET T4058500 * T4059000 LA R3,JPCEJCL POINT TO ACB. T4059500 L RIOT,JPCEIOT POINT TO THE 1ST IOT. T4060000 ST RIOT,SJBIOT SAVE ADDRESS IN SJB. T4060500 CALL HFOPSUB SET SDB, ACB, DEB. T4061000 BNZ SSVOFAIL BRANCH IF HFOPSUB FAILED. T4061500 * T4062000 * CREATE BATCH MONITOR JCL IF REQUIRED T4062500 * T4063000 LM R0,R1,JPCEXBNM GET BATCH MONITOR JOBNAME. T4063500 ALR R0,R1 IF ZERO, T4064000 BZ SOC20 OPEN JCL DATA SET. T4064500 $GETBUF TYPE=UNPROT GET AN UNPROTECTED BUFFER. T4065000 BNZ SSVOFAIL ERROR IF NONE AVAILABLE. T4065500 L R7,PCEJCT RESTORE JCT ADDRESS IN R7. T4066000 ST R1,SDBUBF SAVE UBF ADDRESS IN SDB. T4066500 LR RBUF,R1 SET UBF REGISTER. T4067000 USING BFD,RBUF SET UBF ADDRESSABILITY. T4067500 MVI BFID,C'U' SET UBF IDENTIFIER. T4068000 OI SDBFLG2,SDB2EOD SHOW NO MORE DATA. T4068500 OI SDBFLG1,SDB1GET SHOW INPUT DATA SET. T4069000 MVC BFDAT(L'SOCJCL),SOCJCL MOVE FAKE JCL TO BUFFER. T4069500 LA R2,BFDAT SET ADDRESS OF START T4070000 ST R2,BFLOC OF DATA IN BUFFER. T4070500 LM R0,R1,JPCEXBNM GET BATCH MONITOR JOB NAME. T4071000 STM R0,R1,SOCJNM(R2) SET IT AS JOB NAME. T4071500 STM R0,R1,SOCPNM(R2) SET IT AS PROCEDURE NAME. T4072000 B SOC30 CONTINUE BY OPENING JCLI. T4072500 DROP RBUF DROP BUFFER ADDRESSABILITY. T4073000 * T4073500 * IF NOT BATCH MONITOR, OPEN JCL DATA SET T4074000 * T4074500 SOC20 DS 0H T4075000 L R15,$SVPDDB1 POINT TO R4 T4075500 LA R0,IOTPDBOJ(RIOT,R15) JCL PDDB R4 T4075800 ST R0,SDBPDDB SET POINTER IN SDB. T4076000 CALL HOOLDINP OPEN OLD INPUT DATASET. T4076500 BNZ SSVOFAIL BRANCH IF HOOLDINP FAILED. T4077000 CALL HCNVFDAD CONVERT SDBMTTR TO FDAD T4077500 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T4078000 EXCP SDBIOB AND DO INITIAL READ. T4078500 WAIT 1,ECB=SDBECB WAIT FOR I/O TO END. T4079000 SOC30 DS 0H T4079500 * T4080000 * OPEN THE JCLI DATASET T4080500 * T4081000 LA R3,JPCEJCLI POINT TO ACB. T4081500 L R15,$SVPDDB1 POINT TO R4 T4081600 LA R0,IOTPDBOI(RIOT,R15) JCL IMAGES PDDB R4 T4081700 CALL HFOPSUB SET SDB, ACB, DEB. T4082000 BNZ SSVOFAIL BRANCH IF HFOPSUB FAILED. T4082500 CALL HONEWOUT OPEN NEW OUTPUT DATASET. T4084000 BNZ SSVOFAIL BRANCH IF HONEWOUT FAILED. T4084500 OI SDBFLG1,SDB1OUT SHOW DATA SET SYSOUT. T4085000 * T4085500 * OPEN THE SYSTEM MESSAGES DATASET T4086000 * T4086500 LA R3,JPCEMSG POINT TO ACB. T4087000 L R15,$SVPDDB1 POINT TO R4 T4087100 LA R0,IOTPDBOM(RIOT,R15) SYSTEM MESSAGES PDDB R4 T4087200 CALL HFOPSUB SET SDB, ACB, DEB. T4087500 BNZ SSVOFAIL BRANCH IF HFOPSUB FAILED. T4088000 CALL HONEWOUT OPEN NEW OUTPUT DATASET. T4089500 BNZ SSVOFAIL BRANCH IF HONEWOUT FAILED. T4090000 OI SDBFLG1,SDB1OUT SHOW DATA SET SYSOUT. T4090500 * T4091000 * OPEN THE HASP JOB LOG DATASET T4091500 * T4092000 LA R3,SJBLACB POINT TO ACB. T4092500 L R15,$SVPDDB1 POINT TO R4 T4092600 LA R0,IOTPDBOL(RIOT,R15) HASP JOB LOG PDDB R4 T4092700 CALL HFOPSUB SET SDB, ACB, DEB. T4093000 BNZ SSVOFAIL BRANCH IF HFOPSUB FAILED. T4093500 CALL HONEWOUT OPEN NEW OUTPUT DATASET. T4095000 BNZ SSVOFAIL BRANCH IF HONEWOUT FAILED. T4095500 OI SDBFLG1,SDB1OUT SHOW DATA SET SYSOUT. T4096000 L R3,SDBUBF POINT TO UNPROTECTED BUFFER. T4096500 USING BFD,R3 SET BUFFER ADDRESSABILITY. T4097000 L R1,BFLOC GET PLACE TO PUT JOB LOG HEADER. R4 T4097500 MVC 0(HJLHDL,R1),HJLHDR MOVE 'H A S P J O B L O G'. T4098000 LA R1,HJLHDL(,R1) UPDATE BUFFER POSITION T4100300 ST R1,BFLOC AND SET NEW POSITION. R4 T4100400 LH R1,$SVBFSIZ UPDATE LENGTH R4 T4100500 SL R1,=A(BFDAT-BFIO-HJLHDL) REMAINING R4 T4100600 ST R1,BFLEN IN UBF. R4 T4100700 L R1,BFRCT GET BUFFER COUNT @OZ17756 T4100710 LA R1,1(,R1) UPDATE @OZ17756 T4100720 ST R1,BFRCT COUNT @OZ17756 T4100730 DROP R3 DROP BUFFER ADDRESSABILITY. T4100800 * T4101000 * OPEN THE INTERNAL TEXT DATASET T4101500 * T4102000 LA R3,JPCETXT POINT TO ACB. T4102500 L R15,$SVPDDB1 POINT TO R4 T4102600 LA R0,IOTPDBOT(RIOT,R15) INTERNAL TEXT PDDB R4 T4102700 CALL HFOPSUB SET SDB, ACB, DEB. T4103000 BNZ SSVOFAIL BRANCH IF HFOPSUB FAILED. T4103500 CALL HONEWOUT OPEN NEW OUTPUT DATASET. T4105000 BNZ SSVOFAIL BRANCH IF HONEWOUT FAILED. T4105500 * T4106000 * RETURN TO CALLER T4106500 * T4107000 MODESET EXTKEY=HASP SET HASP KEY BEFORE RETURN. T4107500 L R13,SJBSAVE+4 POINT TO USER SAVEAREA. T4108000 LM R14,R12,12(R13) RESTORE REGISTERS. T4108500 SR R15,R15 SHOW CALLER GOOD COMPLETION. T4109000 BR R14 RETURN. T4109500 SPACE 3 T4110000 HJLHDR DS 0H JES2 JOB LOG HEADER T4110500 DC AL1(0) ZERO TEXT LENGTH T4111000 DC AL1(LRC1CCTL+LRC1TMCH) MACHINE CARRIAGE CONTROL T4111500 DC AL1(0) ZERO LRECL T4112000 DC X'8B' IMMED SKIP TO CHANNEL 1 T4112500 HJLT EQU * TITLE START T4113000 DC AL1(HJLTL-(LRCSOUT-LRCDSECT)) TEXT LENGTH T4113500 DC AL1(LRC1CCTL+LRC1TMCH) MACHINE CARRIAGE CONTROL T4114000 DC AL1(HJLTL-(LRCSOUT-LRCDSECT)) LRECL T4114500 DC X'19' PRINT AND SPACE 3 T4115000 DC CL48' ' CENTER ON 120 WIDTH T4115500 DC C'J E S 2 J O B L O G' T4116000 HJLTL EQU *-HJLT TITLE LENGTH T4116500 HJLHDL EQU *-HJLHDR HEADER LENGTH T4117000 SPACE 3 T4118500 * T4118600 * RETURN IF CONVERTER OPENS FAILED T4118700 * T4119000 SOC800 DS 0H ERROR CODE 4 T4119500 SSVOFAIL EQU SOC800 EQUATE TO OLD LABEL. T4120000 L RSDB,SJBSDB POINT TO AN SDB. T4120500 LTR RSDB,RSDB IF NO MORE, T4121000 BZ SOC810 RETURN. T4121500 CALL $SDBFREE DECHAIN & FREE BUFS & SDB. T4122000 B SOC800 TRY FOR ANOTHER SDB. T4122500 SOC810 L R13,4(,R13) POINT TO CALLER'S SAVE AREA. T4123000 LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS. T4123500 LA R15,4 SET ERROR CODE 4. T4124000 LTR R15,R15 SET CONDITION CODE 2. T4124500 BR R14 RETURN TO CALLER. T4125000 SPACE 3 T4125500 SOC820 DS 0H ERROR CODE 8 T4126000 LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS. T4126500 LA R15,8 SET ERROR CODE 8. T4127000 LTR R15,R15 SET CONDITION CODE 2. T4127500 BR R14 RETURN TO CALLER. T4128000 SPACE 3 T4128500 DROP RIOT,R7,R8,R12,R14,R15 DROP BASES. T4129000 SPACE 3 T4129500 * T4130000 * JCL TO USE WITH BATCH MONITOR T4130500 * T4131000 *//JPCEXBNM JOB 1,SYS,MSGLEVEL=1 T4131500 *//FAKE EXEC JPCEXBNM T4132000 *//GO.SYSIN DD * T4132500 * T4133000 * JCL STARTS --- T4133500 SOCXBJCL EQU * T4134000 * JOB CARD --- T4134500 SOCJ1 DC AL1(L'SOCJ1A,0,80) T4135000 SOCJ1A DC C'//******** JOB 1,SYS,MSGLEVEL=1' T4135500 * EXECUTE CARD --- T4136000 SOCJ2 DC AL1(L'SOCJ2A,0,80) T4136500 SOCJ2A DC C'//FAKE EXEC ********' T4137000 * SYSIN DD CARD --- T4137500 SOCJ3 DC AL1(L'SOCJ3A,0,80) T4138000 SOCJ3A DC C'//GO.SYSIN DD *' T4138500 * END-OF-BUFFER MARKER --- T4139000 SOCJ4 DC AL1(LRCBFEND) T4139500 * EQUATES FOR USE IN EXECUTABLE CODE --- T4140000 SOCJCL EQU SOCXBJCL,*-SOCXBJCL JCL TO MOVE TO BUFFER T4140500 SOCJNM EQU SOCJ1A+2-SOCJCL,8 JOB NAME T4141000 SOCPNM EQU SOCJ2A+12-SOCJCL,8 PROCEDURE NAME T4141500 TITLE 'FAKE OPEN SUBROUTINE' T4142000 *********************************************************************** T4142100 * * T4142200 * HFOPSUB -- ACB 'FAKE OPEN' SUBROUTINE -- OBTAIN SDB * T4142300 * * T4142400 * INPUT R0 - PDDB ADDRESS * T4142500 * R3 - ACB ADDRESS * T4142600 * RIOT - IOT ADDRESS * T4142700 * RSJB - SJB ADDRESS * T4142800 * R14 - RETURN ADDRESS * T4142900 * R15 - ENTRY POINT ADDRESS * T4143000 * * T4143100 * OUTPUT R1 - PDDB ADDRESS * T4143200 * R3 - DEB ADDRESS * T4143300 * RSDB - SDB ADDRESS * T4143400 * * T4143500 * CC - ZERO = NORMAL COMPLETION * T4143600 * - NON-ZERO = ABNORMAL COMPLETION * T4143700 * GETMAIN FAILED FOR SDB * T4143800 * * T4143900 *********************************************************************** T4144000 SPACE 1 R4 T4144100 USING HFOPSUB,R15 PROVIDE LOCAL ADDRESSABILITY R4 T4144200 USING IFGACB,R3 PROVIDE ACB ADDRESSABILITY R4 T4144300 SPACE 1 R4 T4144400 CNOP 0,8 R4 T4144500 HFOPSUB DS 0H R4 T4144600 LR R1,R14 SAVE RETURN ADDRESS. T4145000 CALL $SDBINIT CREATE AN SDB. T4145500 BNZR R1 RETURN IF SDB NOT BUILT. T4146000 LR R14,R1 RESTORE RETURN ADDRESS. T4146500 SPACE 1 R4 T4146600 BALR R15,0 RE-ESTABLISH LOCAL R4 T4146700 USING *,R15 ADDRESSABILITY R4 T4146800 SPACE 1 R4 T4146900 OI ACBOFLGS,ACBOPEN SHOW THAT ACB IS OPEN. T4148500 MVC ACBINRTN,=A(HASPAM) POINT ACB TO HASP ACCESS METHOD. T4149000 L R3,ACBDEB-1 POINT TO DATA SET'S DEB. T4149500 ST R3,SDBDEB SET DEB POINTER IN SDB. T4150000 USING DEBBASIC,R3 USE THE DEB DSECT. T4150500 ST RSDB,DEBIRBAD POINT THE DEB TO THE SDB. T4151000 MVC DEBAPPAD,=A(HASPAM) POINT THE DEB TO HASP ACCESS METHOD. T4151500 ST RIOT,SDBAIOT POINT SDB TO ALLOCATION IOT T4152000 ST RIOT,SDBPIOT AND TO IOT CONTAINING PDDB. T4152500 OI SDBFLG1,SDB1FOPN SHOW DATA SET FAKE-OPENED. T4153000 SPACE 1 R4 T4153100 LTR R1,R0 PICK-UP PDDB ADDRESS R4 T4153200 BZ HFOPEXIT AND RETURN IF ZERO R4 T4153300 ST R1,SDBPDDB SAVE PDDB ADDRESS IN SDB R4 T4153400 TM PDBFLAG2-PDBDSECT(R1),PDB2TCEL SET MAJOR TAB FLAG R4 T4153500 BZ HFOPEXIT IN SDB IF PDDB R4 T4153600 OI SDBTAB+(TABFLAG-TABDSECT),TABMAJOR IS TRACK-CELLED R4 T4153700 SPACE 1 R4 T4153800 HFOPEXIT DS 0H R4 T4153900 SR R15,R15 SHOW GOOD COMPLETION T4155000 BR R14 RETURN TO CALLER. T4155500 SPACE 1 R4 T4155600 DROP , SUSPEND ALL ADDRESSABILITY R4 T4155700 SPACE 2 R4 T4155800 LTORG , R4 T4155900 TITLE 'HOCSETUP - OPEN && CLOSE SETUP SUBROUTINE' T4156500 * T4157000 * HOCSETUP - OPEN & CLOSE SETUP SUBROUTINE T4157500 * T4158000 * REGISTERS ON ENTRY - AS SET BY $PROLOG T4158500 * T4159000 * REGISTERS ON EXIT - T4159500 * R6 - DEB POINTER T4160000 * R7 - JFCB POINTER T4160500 * R8 - SSDA POINTER T4161000 * R10 - SDB/DCT POINTER T4161500 * R0-R5,R15 - UNPREDICTABLE R41 T4162000 * R11-R14 - UNCHANGED R41 T4162500 * T4163000 * EXIT OFFSETS - T4163500 * +0 - VALID INTERNAL READER T4164000 * +4 - VALID SYSIN DATA SET T4164500 * +8 - VALID SYSOUT DATA SET T4165000 * +12 - VALID PROCESS-SYSOUT DATA SET T4165500 * +16 - VALID UNKNOWN-TYPE DATA SET T4166000 * +20 - ERROR IN VALIDATION T4166500 * T4167000 HOCSETUP DS 0H T4167500 USING *,R5 ESTABLISH R41 T4168000 LR R5,R15 LOCAL ADDRESSABILITY R41 T4168100 LR RSIB,RSOX POINT R8 TO SSDA. T4168500 USING SSDABGN,RSIB SET SSDA ADDRESSABILITY. T4169000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T4169500 L RJFC,SSDAJFCB POINT TO JFCB FROM SSDA. T4170000 USING INFMJFCB,RJFC SET JFCB ADDRESSABILITY. T4170500 L RDEB,SSDADEBP POINT TO DEB FROM SSDA. T4171000 USING DEBBASIC,RDEB SET DEB ADDRESSABILITY. T4171500 L RSDB,SSDASSCM POINT TO SDB/DCT FROM SSDA. T4172000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T4172500 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T4173000 * T4175500 * VERIFY SJB PRESENT IF REQUIRED T4176000 * T4176500 LTR RSDB,RSDB IF NO SDB/DCT PRESENT, T4177000 BZ HOCS60 PROCESS SPECIAL INTRDR. T4177500 LTR R12,R12 OTHERWISE IF SJB NOT PRESENT, T4178000 BNM 20(,R14) RETURN +20 - ERROR. T4178500 * T4179000 * TEST FOR SUBSYSTEM DATASET BLOCK T4179500 * T4180000 CLC SDBID,=CL4'SDB' IF SDB ID NOT PRESENT, T4180500 BNE HOCS40 GO TEST FOR INTRDR ID. T4181000 * T4181100 * SDB - IF CLOSE, RESTORE I/O T4181200 * T4181300 CLI SJBXQFN1+1,SSOBCLOS SKIP IF T4181400 BNE HOCS10 FUNCTION ISN'T CLOSE. T4181500 TM SDBFLG2,SDB2IOA IF FLAG SHOWS THAT T4181600 BZ HOCS10 I/O IS ACTIVE T4181700 CLI SDBICMP,X'48' YET IOB COMPLETION CODE T4181800 BNE HOCS10 SHOWS PURGED, T4181900 MVI SDBECB,0 CLEAR ECB T4182000 LR R4,R14 SAVE RETURN REG ACROSS EXCP R41 T4182100 EXCP SDBIOB AND RE-EXCP. T4182200 LR R14,R4 RESTORE RETURN REGISTER R41 T4182300 HOCS10 DS 0H T4182400 * T4182500 * TEST FOR SYSOUT T4182600 * T4182700 CLI DSNDSTYP,C'S' BRANCH IF NEITHER T4183000 BNE HOCS20 SYSIN NOR SYSOUT. T4183500 CLI DSNDSTYP+1,C'O' IF DSTYP IS 'SO', T4184000 BE 8(,R14) RETURN +8 - SYSOUT. T4184500 * T4185000 * TEST FOR SYSIN T4185500 * T4186000 CLI DSNDSTYP+1,C'I' IF DSTYP IS 'SI', T4186500 BE 4(,R14) RETURN +4 - SYSIN. T4187000 * T4187500 * TEST FOR PROCESS-SYSOUT T4188000 * T4188500 HOCS20 DS 0H T4189000 CLC DSNDSTYP,=C'PS' IF DSTYP IS 'PS', T4189500 BE 12(,R14) RETURN +12 - PSO. T4190000 B 16(,R14) ELSE RETURN +16 - UNKNOWN. T4190500 * T4191000 * TEST FOR NORMAL INTERNAL READER T4191500 * T4192000 HOCS40 DS 0H T4192500 USING DCTDSECT,RSDB SET DCT ADDRESSABILITY. T4193000 CLC =C'INTRDR',DCTDEVN IF ID IS 'INTRDR', T4193500 BER R14 RETURN +0 - INTRDR. T4194000 B 20(,R14) ELSE RETURN +20 - ERROR. T4194500 * T4195000 * TEST FOR SPECIAL INTERNAL READER T4195500 * T4196000 HOCS60 DS 0H T4196500 CLC =C'.MSTR .MS0000.',DSNSSNM+4 IF NOT SPECIAL, T4197000 BNE 20(,R14) RETURN +20 - ERROR. T4197500 L RSDB,$SVIRDRS POINT TO STCINRDR. T4198000 CLC DSNDDNM,DCTDEVN IF IT MATCHES DDNAME, T4198500 BER R14 RETURN +0 - INTRDR. T4199000 L RSDB,DCTCHAIN POINT TO TSOINRDR. T4199500 CLC DSNDDNM,DCTDEVN IF IT MATCHES DDNAME, T4200000 BER R14 RETURN +0 - INTRDR. T4200500 B 20(,R14) ELSE RETURN +20 - ERROR. T4201000 SPACE 3 T4201500 DROP , DROP ALL ADDRESSABILITY. T4202000 TITLE 'HASP SUBSYSTEM SUPPORT ROUTINE -- CLOSE' T4202500 * T4203000 * T4203500 * HASP SUBSYSTEM SUPPORT ROUTINE -- CLOSE T4204000 * T4204500 * T4205000 HOSCLOS $PROLOG SSOBCLOS,SSDASIZE,LOCK=SDB CLOSE T4205500 SPACE 1 T4206000 HOSCLOSB DS 0H CLOSE BASE ADDRESS. T4206500 * T4207000 * USE SUBROUTINE TO SET UP REGISTERS T4207500 * AND TO DETERMINE TYPE OF CLOSE T4208000 * T4208500 CALL HOCSETUP CALL SUBROUTINE T4209000 USING DEBBASIC,RDEB SET DEB ADDRESSABILITY. T4209500 USING INFMJFCB,RJFC SET JFCB ADDRESSABILITY. T4210000 USING SSDABGN,RSIB SET SSDA ADDRESSABILITY. T4210500 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. T4211000 B HC000 INTERNAL READER T4211500 B HC100 SUBSYSTEM DATA SET - SI T4212000 B HC200 SUBSYSTEM DATA SET - SO T4212500 B HC300 SUBSYSTEM DATA SET - PS T4213000 B HC400 SUBSYSTEM DATA SET - INVALID T4213500 B HCERR ERROR DETECTING TYPE T4214000 EJECT T4214500 * T4215000 * C L O S E I N T E R N A L R E A D E R T4215500 * T4216000 HC000 DS 0H T4216500 USING DCTDSECT,RSDB SET DCT ADDRESSABILITY. T4217000 LM R2,R3,HCIEOF GET POINTERS TO /*EOF RECORD. T4217500 L R1,PSATOLD-PSA POINT TO CURRENT TCB. T4218000 USING TCB,R1 SET TCB ADDRESSABILITY. T4218500 TM TCBFBYT1,TCBRTM2 SET CC=3 IF TASK ABENDING. T4219000 DROP R1 DROP TCB ADDRESSABILITY. T4219500 BZ *+8 IF TASK IS ABENDING, T4220000 LM R2,R3,HCIDEL GET POINTERS TO /*DEL RECORD. T4220500 L RACB,DEBDCBAD POINT TO THE ACB. T4221000 LA RACB,0(,RACB) BE SURE HIGH BIT IS OFF. T4221500 AL R12,=A(HAMBASE-HOSCLOSB) ADJUST R12 FOR BAL. T4222000 USING HAMBASE,R12 TELL ASSEMBLER ABOUT IT. T4222500 BAL R14,HINTRDR CALL INTRDR SUBROUTINE. T4223000 BALR R15,0 TO RESTORE BASE, ESTABLISH T4223500 USING *,R15 TEMPORARY ADDRESSABILITY. T4224000 SL R12,=A(HAMBASE-HOSCLOSB) RE-ADJUST R12. T4224500 DROP R15 DROP TEMPORARY BASE. T4225000 USING HOSCLOSB,R12 TELL ASSEMBLER ABOUT IT. T4225500 CLI RIDJOBID,C'J' IF USER INTRDR @OZ29612 T4225600 BE HCRET MERELY RETURN @OZ29612 T4225700 SLR R1,R1 ZERO THE ASCB POINTER @OZ29612 T4225800 ST R1,RIDASCBP FOR STC AND TSU @OZ29612 T4225900 B HCRET RETURN FROM CLOSE. T4226000 DROP RDEB DROP DEB ADDRESSABILITY. T4226500 DS 0F T4227000 HCIEOF DC AL1(RIDCLS),AL3(HCIEOFC),A(5) /*EOF POINTERS T4227500 HCIDEL DC AL1(RIDCLS),AL3(HCIDELC),A(5) /*DEL POINTERS T4228000 HCIEOFC DC C'/*EOF' /*EOF TEXT T4228500 HCIDELC DC C'/*DEL' /*DEL TEXT T4229000 EJECT T4229500 * T4230000 * C L O S E S Y S I N D A T A S E T T4230500 * T4231000 HC100 DS 0H T4231500 * T4232000 * C L O S E P R O C E S S - S Y S O U T T4232500 * T4233000 HC300 DS 0H T4233500 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T4234000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T4234500 TM SJBFLG1,SJB1XBM+SJB1XBWT IF EXEC BATCH MONITOR, T4235000 BM HCRET NEVER FREE BUFFERS. T4235500 L R1,SDBECB LOAD ECB R41 T4235700 HC305 LR R2,R1 RELOAD ECB R41 T4236000 LR R2,R1 RELOAD ECB R41 T4236100 N R2,=XL4'7F000000' RESET WAIT BIT R41 T4236200 CS R1,R2,SDBECB REPLACE ECB R41 T4236300 BNE HC305 TRY AGAIN IF UNSUCCESSFUL R41 T4236400 WAIT 1,ECB=SDBECB BE SURE I/O IS COMPLETE. T4236500 L RBUF,SDBPBF FREE ALL T4237000 BAL R5,HCFREBP PROTECTED BUFFERS. T4237500 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T4238000 MVC SDBTRK+5(3),BFRBA+5-BFD(RBUF) SAVE REC NUMBER. T4238500 BAL R5,HCFREBU FREE THE BUFFER. T4239000 L RBUF,SDBHBF FREE ALL T4239500 HC307 DS 0H @OZ41634 T4239600 BAL R5,HCFREBU UPDATE-HOLD BUFFERS. T4240000 LTR RBUF,RBUF END OF HBUF CHAIN ? @OZ41634 T4240100 BNZ HC307 NO, LOOP BACK @OZ41634 T4240200 SLR R0,R0 ZERO POINTERS TO T4240500 ST R0,SDBPBF PROTECTED, T4241000 ST R0,SDBUBF UNPROTECTED, AND T4241500 ST R0,SDBHBF HOLD BUFFERS. T4242000 B HC900 GO CONCLUDE CLOSE. T4242500 EJECT T4243000 * T4243500 * C L O S E S Y S O U T D A T A S E T T4244000 * T4244500 HC200 DS 0H T4245000 * T4245500 * 1. TRUNCATE AND WRITE BUFFER FOR CLOSE T4246000 * T4246500 CLI SDBCCW3+7,0 DATA SET ALREADY CLOSED... @G38ESBB T4246520 BE HCRET YES, GO RETURN NORMALLY @G38ESBB T4246540 TM SJBFLG1,SJB1XBM+SJB1XBWT IF XBM HAS NO JOB, T4246600 BO HC210 JUST FREE BUFFERS. T4246700 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T4247000 USING BFD,RBUF USE BUFFER DSECT. T4247500 L R1,BFLOC GET SPOT FOR NEXT RECORD. T4248000 CLI SDBCCW3+7,1 DON'T TEST FOR A NULL DS T4248100 BH HC205 IF TWO OR MORE OPENS. T4248200 LA R0,BFDAT IF SOME DATA IN BUFFER, T4248500 CLR R0,R1 NOT AN EMPTY DATA SET - T4248600 BNE HC205 PROCEED NORMALLY. T4248700 CLC SDBTRK,SDBTRKF IF NOT ORIGINAL TRACK, T4248800 BNE HC205 PROCEED NORMALLY. T4248900 L R2,SDBPDDB NULL DATA SET --- T4249000 OI PDBFLAG1-PDBDSECT(R2),PDB1NULL SHOW DS NULL. T4249100 L R1,SDBPIOT REWRITE T4249200 L R0,IOTTRACK-IOTDSECT(,R1) THE T4249300 NI IOTFLAG1-IOTDSECT(R1),255-IOT1CKPT DATASET'S T4249400 CALL HCBWR IOT. T4249500 MVI SDBCCW3+7,0 ZERO THE OPEN COUNT. T4249600 B HC210 THEN JUST FREE BUFFERS. T4249700 USING LRCDSECT,R1 NOT NULL. SET LRC BASE. T4249800 HC205 LA R5,BFIO GET ADDR OF @OZ29839 T4249900 AH R5,$SVBFSIZ END OF BUFFER. @OZ29839 T4249920 CR R5,R1 COMPARE BFLOC TO END. @OZ29839 T4249930 BNH HCERR ERROR IF BFLOC TOO BIG. @OZ29839 T4249940 CR RBUF,R1 COMPARE BFLOC TO START. @OZ29839 T4249950 BNL HCERR ERROR IF BFLOC TOO SMALL. @OZ29839 T4249960 MVI LRCTLENG,LRCBFEND SET END OF BUFFER. @OZ29839 T4249970 L R2,SSDADEBP POINT TO THE DEB. T4250000 USING DEBBASIC,R2 AND USE ITS DSECT. T4250100 LA R0,BFDAT GET START OF DATA ADDRESS @OZ30041 T4250200 CR R0,R1 IF NULL BUFFER, @OZ30041 T4250300 BE HC206 SKIP FIRST WRITE @OZ30041 T4250400 L R1,DEBDCBAD POINT TO THE ACB. T4250500 LA R1,0(,R1) ZERO HIGH-ORDER BYTE. T4251000 LNR R1,R1 SHOW SVC ARG IS ACB. T4251500 LA R0,HSVCEOBP SET PUT-END-OF-BLOCK CODE T4252000 SVC HAMSVC AND CALL HAMSVC. T4252500 L R1,SDBECB RESET THE WAIT BIT @OZ39533 T4252550 HC205A LR R15,R1 AND WAIT HERE FOR THE @OZ39533 T4252600 N R15,=XL4'7F000000' CEA REDRIVE LOOP @OZ39533 T4252650 CS R1,R15,SDBECB TO STOP, OR CEA MAY @OZ39533 T4252700 BNE HC205A NOT WRITE THE LAST @OZ39533 T4252750 WAIT 1,ECB=SDBECB BUFFER @OZ39533 T4252800 L R1,BFLOC GET SPOT FOR NEXT RECORD. T4253000 CR R5,R1 COMPARE BFLOC TO END. @OZ29839 T4253100 BNH HCERR ERROR IF BUFLOC TOO LARGE. @OZ29839 T4253200 CR RBUF,R1 COMPARE BFLOC TO START. @OZ29839 T4253300 BNL HCERR ERROR IF BFLOC TOO SMALL. @OZ29839 T4253400 MVI LRCTLENG,LRCBFEND TRUNCATE THE BUFFER. T4253500 HC206 DS 0H @OZ30041 T4253600 OI SDBFLG1,SDB1CLOS SHOW HAMSVC WE'RE CLOSING. T4254000 L R1,DEBDCBAD POINT TO THE ACB. T4254500 LA R1,0(,R1) ZERO HIGH-ORDER BYTE. T4255000 LNR R1,R1 SHOW SVC ARG IS ACB. T4255500 LA R0,HSVCEOBP SET PUT-END-OF-BLOCK CODE T4256000 SVC HAMSVC AND CALL HAMSVC. T4256500 NI SDBFLG1,255-SDB1CLOS RESET THE CLOSE FLAG. T4257000 DROP R1,R2 DROP LRC, DEB BASES. T4257500 * T4258000 * 2. WAIT TILL ALL BUFFERS ARE WRITTEN T4258500 * T4259000 HC208 DS 0H R4 T4259100 L R1,SDBECB LOAD ECB R41 T4259300 HC218 LR R2,R1 RELOAD ECB R41 T4259500 LR R2,R1 RELOAD ECB R41 T4259600 N R2,=XL4'7F000000' RESET WAIT BIT R41 T4259700 CS R1,R2,SDBECB REPLACE ECB R41 T4259800 BNE HC218 TRY AGAIN IF UNSUCCESSFUL R41 T4259900 WAIT 1,ECB=SDBECB WAIT FOR I/O TO COMPLETE. T4260000 TM SDBFLG1,SDB1BFXS CHN PGM ABORTED VIA SWAP-OUT... R4 T4260100 BZ HC209 BR IF NO R4 T4260200 ICM R1,15,SDBPBF ANY PBFS TO BE WRITTEN... R4 T4260300 BZ HC209 BR IF NO R4 T4260400 NI SDBFLG1,255-SDB1BFXS RESET EXCESSION ALLOWED R4 T4260500 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T4260600 EXCP SDBIOB ISSUE EXCP R4 T4260700 B HC208 WAIT FOR I/O TO COMPLETE R4 T4260800 * R4 T4260900 * LOWER OPEN COUNT. IF STILL OPEN FOR OTHERS, RETURN T4261000 * T4261500 HC209 DS 0H R4 T4261600 L R1,SDBCCW3+4 GET OPEN COUNT. T4262000 BCTR R1,0 DECREMENT IT. T4262500 ST R1,SDBCCW3+4 STORE OPEN COUNT. T4263000 LTR R1,R1 IF STILL OPEN FOR OTHERS, T4263500 BNZ HCRET MERELY RETURN. T4264000 * T4264500 * 3. FREE ALL BUFFERS T4265000 * T4265500 HC210 DS 0H T4272000 L RBUF,SDBPBF FREE ALL T4272500 BAL R5,HCFREBP PROTECTED BUFFERS. T4273000 L RBUF,SDBUBF FREE ALL T4273500 BAL R5,HCFREBU UNPROTECTED BUFFERS. T4274000 L RBUF,SDBHBF FREE ALL T4274500 HC212 DS 0H @OZ41634 T4274600 BAL R5,HCFREBU UPDATE-HOLD BUFFERS. T4275000 LTR RBUF,RBUF END OF HBUF CHAIN ? @OZ41634 T4275100 BNZ HC212 NO, LOOP BACK @OZ41634 T4275200 L RBUF,SDBFBF FREE ALL T4275500 BAL R5,HCFREBP CH END FREE BUFFERS. T4276000 SLR R0,R0 ZERO POINTERS TO T4276500 ST R0,SDBPBF PROTECTED, T4277000 ST R0,SDBUBF UNPROTECTED, T4277500 ST R0,SDBHBF HOLD, AND T4278000 ST R0,SDBFBF FREE BUFFERS. T4278500 STH R0,SDBPBFCT SHOW NO PROTECTED BUFFERS. T4279000 * T4279500 * 4. RETURN TO CALLER T4280000 * T4280500 L R1,SDBAIOT POINT TO ALLOCATION IOT. T4281000 TM IOTFLAG1-IOTDSECT(R1),IOT1CKPT CKPT REQUIRED... T4281500 BZ HC900 IF NOT, CONCLUDE CLOSE. T4282000 NI IOTFLAG1-IOTDSECT(R1),255-IOT1CKPT RESET FLAG. T4282500 L R0,IOTTRACK-IOTDSECT(,R1) R0=TRACK ADDRESS. T4283000 CALL HCBWR WRITE THE IOT. T4283500 B HC900 GO CONCLUDE CLOSE. T4284000 EJECT T4284500 SPACE 5 T4285000 * T4285500 * ADD OTHER DATA SET TYPES HERE T4286000 * T4286500 HC400 DS 0H T4287000 $MID 353 T4287500 WTO '&MID.CLOSE FAILED BECAUSE NOT SYSIN, SYSOUT, NOR PROCESCT4288000 S-SYSOUT',ROUTCDE=10,DESC=6 T4288500 B HCERR T4289000 DROP RBUF,RJFC,RSIB DROP BASES. T4289500 EJECT T4290000 * T4290500 * CONCLUDE CLOSE FOR ALL BUT INTRDR. T4291000 * T4291500 HC900 DS 0H T4292000 SLR R0,R0 ZERO OUT THE DEB T4292500 ST R0,SDBDEB POINTER IN THE SDB. T4293000 SPACE 3 T4293500 * T4294000 * RETURN NORMALLY TO CALLER T4294500 * T4295000 HCRET DS 0H T4295500 SLR R15,R15 SET RETURN CODE TO ZERO. T4296000 B HCEXIT GO RETURN. T4296500 SPACE 3 T4297000 * T4297500 * RETURN ABNORMALLY TO CALLER T4298000 * T4298500 HCERR DS 0H T4299000 LA R15,4 NOTE- RETURN CODES ARE NOT DEFINED. T4299500 SPACE 3 T4300000 HCEXIT DS 0H T4300500 LR R1,R13 POINT R1 TO SJB/USER SAVE. T4301000 LTR R12,R12 IF R1 POINTS TO USER SAVE, T4301500 BNM *+8 SKIP POINTING FROM SJB. T4302000 L R1,4(,R1) POINT TO USER SAVEAREA. T4302500 L R1,24(,R1) POINT TO SSOB. T4303000 USING SSOBEGIN,R1 SET BASE. T4303500 L R1,SSOBINDV POINT THENCE TO SSDA. T4304000 USING SSDABGN,R1 SET BASE. T4304500 L R1,SSDADEBP POINT THENCE TO DEB. T4305000 USING DEBBASIC,R1 SET BASE. T4305500 L R1,DEBDCBAD POINT THENCE TO ACB. T4306000 USING IFGACB,R1 SET BASE. T4306500 SLR R0,R0 ZERO OUT T4307000 ST R0,ACBINRTN ACCESS METHOD ADDRESS. T4307500 SPACE 1 T4308000 $EPILOG KEY=0 RETURN TO CALLER R4 T4308100 TITLE 'FAKE CLOSE FOR CONVERTER DATASETS' T4309000 * T4309500 * T4310000 * FAKE CLOSE FOR CONVERTER DATASETS T4310500 * T4311000 * T4311500 SSVCLSC DS 0H T4312000 STM R14,R12,12(R13) SAVE REGISTERS. T4312500 BALR R12,0 ESTABLISH T4313000 USING *,R12 ADDRESSABILITY. T4313500 MODESET EXTKEY=ZERO SET KEY ZERO FOR FAKE CLOSE. T4314000 USING PCEDSECT,R8 USE PCE DSECT. T4314500 LR R2,R13 SAVE USER SAVEAREA POINTER. T4315000 LR RSVT,R5 HOSCNVT PASSES SSVT IN R5. T4315500 L RSJB,JPCESJBP POINT TO CONVERTER SJB. T4316000 ST RSJB,8(,R2) POINT USER SAVEAREA TO NEXT. T4316500 ST R2,SJBSAVE+4 POINT SJB SAVEAREA TO USER'S. T4317000 L R0,=A(HAMNULL) GET NULL ADDRESS R4 T4317100 ST R0,SJBLACB+ACBINRTN-IFGACB NULLIFY JOB LOG R4 T4317200 * T4317500 * FOR EACH SDB, INVOKE FAKE CLOSE T4318000 * T4318500 L R7,PCEJCT POINT R7 TO THE JCT. T4319000 * THIS LINE DELETED BY APAR NUMBER @OZ26284 T4319500 SSVCC10 DS 0H T4320000 L RSDB,SJBSDB POINT TO AN SDB. T4320500 LTR RSDB,RSDB ARE WE THROUGH... T4321000 BZ SSVCC20 IF SO, GO CHECK FOR HOLDING. T4321500 CALL HFCLSUB NO. GO TO FAKE CLOSE. T4322000 CALL $SDBFREE FREE THE SDB. T4322500 B SSVCC10 THEN DO NEXT SDB. T4323000 * T4323500 * IF CONVERTER ERROR, PROCESS FOR HOLD T4324000 * T4324500 SSVCC20 DS 0H T4325000 TM JCTJOBFL-JCTDSECT(R7),JCTTSCAN TYPRUN = SCAN... R4 T4325100 BO SSVCC30 BR IF YES R4 T4325200 L R1,4(,R13) POINT TO CALLER'S SAVE AREA. T4325500 L R1,20(,R1) INSPECT CALLER'S REGISTER 0. T4326000 LTR R1,R1 IF IT WAS ZERO, T4326500 BZ SSVCC90 CONVERSION WAS SUCCESSFUL. T4327000 SSVCC30 DS 0H R4 T4327100 CALL HJEAHOLD ELSE PROCESS FOR HOLD. T4327500 * T4328000 * RETURN TO CALLER T4328500 * T4329000 SSVCC90 DS 0H T4329500 MODESET EXTKEY=HASP SET HASP KEY BEFORE RETURN. T4330000 L R13,4(,R13) POINT TO USER SAVEAREA. T4330500 LM R14,R12,12(R13) RESTORE REGISTERS. T4331000 BR R14 RETURN. T4331500 DROP R8 DROP PCE BASE. T4332000 TITLE 'FAKE CLOSE SUBROUTINE' T4332500 * T4333000 * T4333500 * FAKE CLOSE SUBROUTINE - INPUT AND OUTPUT DATASETS T4334000 * T4334500 * T4335000 HFCLSUB DS 0H L RSDB,THE SDB TO CLOSE T4335500 * L R7,THE JCT FOR JOB T4336000 * CALL HFCLSUB T4336500 STM R14,R12,12(R13) SAVE REGISTERS. T4337000 BALR R12,0 ESTABLISH T4337500 HFCLBASE DS 0H LOCAL T4338000 USING *,R12 ADDRESSABILITY. T4338500 HFCL00 DS 0H T4339000 TM SDBFLG1,SDB1GET IF INPUT DATA SET, T4339500 BO HFCL30 SKIP OUTPUT LOGIC. T4340000 L RBUF,SDBUBF ELSE POINT TO UBF. T4340500 LTR RBUF,RBUF IF NO UBF (ABNORMAL), T4341000 BZ HFCL30 SKIP OUTPUT ROUTINES. T4341500 USING BFD,RBUF USE BUFFER DSECT. T4342000 USING JCTDSECT,R7 USE JCT DSECT. T4342500 L R3,SDBPDDB GET PDDB ADDRESS FROM SDB. T4343000 USING PDBDSECT,R3 SET PDDB ADDRESSABILITY. T4343500 LA R8,BFDAT IF T4344000 CL R8,BFLOC DATASET T4344500 BNE HFCL05 OPENED T4345000 CLC SDBTRK,SDBTRKF BUT NOT T4345500 BNE HFCL05 WRITTEN TO, T4346000 OI PDBFLAG1,PDB1NULL INDICATE EMPTY T4346500 * T4348000 * OUTPUT - TEST FOR CONTINUATION TYPE T4348500 * T4349000 HFCL05 DS 0H T4349500 LA R8,JCTJLOGC ASSUME HASP JOB LOG R4 T4350000 CLI SDBDKEY+1,PDBOUHJL IF SO, T4350500 BE HFCL10 GO DO FIRST TRUNCATION. T4351000 LA R8,JCTMSGSC ASSUME SYSTEM MESSAGES R4 T4351500 CLI SDBDKEY+1,PDBOUMSG IF SO, T4352000 BE HFCL10 GO DO FIRST TRUNCATION. T4352500 B HFCL20 ELSE CLOSE IMMEDIATELY. T4353000 EJECT R4 T4353200 * T4353500 * IF HASP JOB LOG OR SYS MSGS, TRUNCATE HERE. T4354000 * T4354500 HFCL10 DS 0H T4355000 TM PDBFLAG1,PDB1NULL IF DATASET EMPTY, T4355500 BO *+8 DON'T TRUNCATE TWICE. T4356000 BAL R14,HFCLTRNC TRUNCATE BUFFER. T4356500 MVC 0(4,R8),SDBTRK+1 SAVE CONTINUE MTTR IN JCT R41 T4357000 CLI SDBDKEY+1,PDBOUHJL IF NOT JES2 JOB LOG, R4 T4357200 BNE HFCL20 BRANCH AROUND R4 T4357300 TM SJBFLG2,SJB2CONV IF NOT FAKE-CLOSE FOR R4 T4357400 BZ HFCL20 CONVERTER, BRANCH AROUND R4 T4357500 CLI JCTJOBID,C'J' IF NOT PLAIN VANILLA BATCH R41 T4357600 BNE HFCL20 JOB, BRANCH AROUND R41 T4357700 TM JCTJOBFL,JCTTSCAN IF 'TYPRUN=SCAN', R41 T4357800 BO HFCL20 BRANCH AROUND R41 T4357900 L R3,4(,R13) CHECK CONVERTER'S R4 T4358000 L R3,20(,R3) RETURN CODE -- R4 T4358100 LTR R3,R3 IF CONVERSION ERROR, R4 T4358200 BNZ HFCL20 BRANCH AROUND R4 T4358300 L R3,BFLOC PLACE 'JOB DELETED' BLURB IN JOB R4 T4358400 MVC 0(HFCMSGL,R3),HFCMSG LOG TERMINATOR BUFFER, TO BE R4 T4358500 LA R3,HFCMSGL(,R3) OVER-WRITTEN IF JOB GOES R4 T4358600 ST R3,BFLOC INTO EXECUTION R4 T4358700 OI SDBFLG2,SDB2EOD SET RECORD COUNT OFF @OZ43719 T4358750 * T4358800 * TRUNCATE & CLOSE ALL OUTPUT DATA SETS T4358900 * T4359000 HFCL20 DS 0H T4359100 CLC SDBTRK,SDBTRKF DON'T WAIT IF I/O HAS @OZ39533 T4359140 BE HFCL25 NEVER BEEN STARTED @OZ39533 T4359180 L R1,SDBECB RESET THE WAIT BIT @OZ39533 T4359220 HFCL22 LR R3,R1 AND WAIT HERE FOR THE @OZ39533 T4359260 N R3,=XL4'7F000000' CEA REDRIVE LOOP @OZ39533 T4359300 CS R1,R3,SDBECB TO STOP, OR CEA MAY @OZ39533 T4359340 BNE HFCL22 NOT WRITE THE LAST @OZ39533 T4359380 WAIT 1,ECB=SDBECB BUFFER @OZ39533 T4359420 HFCL25 DS 0H @OZ39533 T4359460 OI SDBFLG1,SDB1CLOS CAUSE DATA SET CLOSE. T4359500 BAL R14,HFCLTRNC TRUNCATE BUFFER. T4360000 NI SDBFLG1,255-SDB1CLOS RESET CLOSE FLAG. T4360500 NI SDBFLG2,255-SDB2EOD RESET RECORD COUNT OFF @OZ43719 T4360600 * T4361000 * BE SURE I/O IS COMPLETE T4361500 * T4362000 HFCL30 DS 0H T4362500 WAIT 1,ECB=SDBECB ELSE WAIT TILL I/O INACTIVE. T4363000 TM SDBFLG1,SDB1GET TEST FOR INPUT DATA SET R4 T4363100 BO HFCL50 BR IF YES R41 T4363200 TM SDBFLG1,SDB1BFXS CHN PGM ABORTED VIA SWAP-OUT... R4 T4363300 BZ HFCL40 BR IF NO R4 T4363400 ICM R1,15,SDBPBF ANY PBFS TO BE WRITTEN... R4 T4363500 BZ HFCL40 BR IF NO R4 T4363600 NI SDBFLG1,255-SDB1BFXS RESET EXCESSION ALLOWED R4 T4363700 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T4363800 EXCP SDBIOB ISSUE EXCP R4 T4363900 B HFCL30 WAIT FOR I/O TO COMPLETE R4 T4364000 EJECT R41 T4364100 HFCL40 L R3,SDBPDDB MOVE RECORD COUNT R41 T4364200 MVC PDBRECCT,SDBRECCT TO PDDB R41 T4364300 L R8,SDBPIOT FLAG IOT FOR R41 T4364400 OI IOTFLAG1-IOTDSECT(R8),IOT1CKPT CHECKPOINT R41 T4364500 SPACE 1 R41 T4364600 HFCL50 LM R14,R12,12(R13) RESTORE REGISTERS R41 T4364700 BR R14 RETURN TO CALLER. T4364800 SPACE 1 R41 T4364900 DROP R3,R7,R12 DROP BASES. T4365000 SPACE 3 R41 T4365100 * T4365500 * TRUNCATION SUBROUTINE T4366000 * T4366500 USING HFCLBASE,R12 T4367000 HFCLTRNC DS 0H T4367500 L R3,BFLOC POINT TO CURRENT UBF OFFSET. T4368000 USING LRCDSECT,R3 USE LOGICAL RECORD DSECT. T4368500 MVI LRCTLENG,LRCBFEND TRUNCATE THE BUFFER. T4369000 L R1,SDBDEB POINT TO DATA SET'S DEB. T4369500 USING DEBBASIC,R1 USE DEB DSECT. T4370000 L R1,DEBDCBAD POINT THENCE TO ACB. T4370500 LA R1,0(,R1) ZERO HIGH-ORDER BYTE. T4371000 LNR R1,R1 SHOW HAMSVC ARG IS ACB. T4371500 LA R0,HSVCEOBP SET HAMSVC FUNCTION CODE. T4372000 SVC HAMSVC USE HAMSVC TO WRITE. T4372500 BR R14 RETURN TO CALLER. T4373000 DROP R1,R3 DROP DEB, LRC BASES. T4373500 * R4 T4373600 * 'JOB DELETED' BLURB FOR JOB LOG TERMINATOR BUFFER R4 T4373700 * R4 T4373800 HFCMSG DC AL1(HFCMSGL-4,LRC1CCTL+LRC1TMCH,HFCMSGL-4,X'09') *T4373900 SET MACHINE CARRIAGE CNTRL @OZ44796 T4373950 DC C'******** JOB DELETED BY JES2 OR CANCELLED ' R4 T4374000 DC C'BY OPERATOR BEFORE EXECUTION ******** ' R4 T4374100 HFCMSGL EQU *-HFCMSG LENGTH FOR MOVE R4 T4374200 EJECT T4374300 SPACE 3 T4374500 * T4375000 * SUBROUTINES TO FREE BUFFERS T4375500 * T4376000 HCFREBP DS 0H T4376500 USING HOSCLOSB,R12 USE MAINLINE CLOSE BASE. T4377000 LTR R1,RBUF IF NO BUFFER TO FREE, T4377500 BZR R5 RETURN. T4378000 L RBUF,BFBF ELSE POINT TO NEXT BUFFER T4378500 $FREEBUF TYPE=PROT,A=(R1) AND FREE CURRENT. T4379000 B HCFREBP THEN REPEAT. T4379500 SPACE 1 T4380000 HCFREBU DS 0H T4380500 LTR R1,RBUF IF NO BUFFER TO FREE, T4381000 BZR R5 RETURN. T4381500 L RBUF,BFBF ELSE POINT TO NEXT BUFFER T4382000 $FREEBUF TYPE=UNPROT,A=(R1) AND FREE CURRENT. T4382500 BR R5 RETURN ON REG5 @OZ41634 T4383000 DROP , DROP ALL BASES. T4383500 TITLE 'HOSCKPT -- SUBSYSTEM DATASET CHECKPOINT FUNCTION' T4384000 HOSCKPT $PROLOG SSOBCKPT,SSDASIZE,LOCK=REQ T4384500 * T4385000 * T4385500 * CHECKPOINT A SUBSYSTEM DATA SET T4386000 * T4386500 * T4387000 * T4387500 * CHECKPOINT AREA IS USED AS FOLLOWS --- T4388000 * BYTE 0-3 JOB KEY, FROM SDBJKEY T4388500 * BYTE 4-5 DATA SET KEY, FROM SDBDKEY T4389000 * BYTE 6 FLAGS AS FOLLOW - T4389500 * BIT 0 INTRDR - NO REPOSITIONING T4390000 * BIT 1 SPIN - NO REPOSITIONING T4390500 * BIT 2 EOD - SHOW EOD AT RESTART T4391000 * BIT 3 I/O ERROR - SHOW I/O ERROR AT RESTART T4391500 * BIT 4 1=OPEN FOR INPUT AT RESTART T4392000 * BIT 5 RESERVED T4392500 * BIT 6 RESERVED T4393000 * BIT 7 RESERVED T4393500 * BYTE 7 RESERVED T4394000 * BYTE 8-15 STARTING RBA, FROM SDBTRKF T4394500 * BYTE 16-23 CURRENT RBA, FROM BFRBA FROM SDBUBF T4395000 * BYTE 24-27 NUMBER OF RECORD NEXT TO READ T4395500 * T4396000 * T4396500 * LOAD REGISTERS FROM SSOB EXTENSION T4397000 * T4397500 USING SSDABGN,RSOX USE SSOB EXTENSION DSECT. T4398000 L R7,SSDASSCM POINT TO DCT/SDB. T4398500 L R4,SSDABUFR POINT TO CHECKPOINT BUFFER. T4399000 XC 0(24,R4),0(R4) CLEAR PART OF BUFFER. T4399500 * T4400000 * IF INTERNAL READER, SET FLAG AND EXIT T4400500 * T4401000 USING DCTDSECT,R7 USE DCT DSECT. T4401500 CLC =C'INTRDR',DCTDEVN IS THIS AN INTERNAL READER... T4402000 BNE HCK100 BRANCH IF NOT. T4402500 OI 6(R4),X'80' YES. SET FLAG T4403000 B HCK900 AND RETURN. T4403500 * T4404000 * VERIFY SDB AND THAT IT'S OPEN T4404500 * T4405000 HCK100 DS 0H T4405500 USING SDBDSECT,R7 USE R7 AS SDB BASE. T4406000 CLC SDBID,=CL4'SDB' IS THIS REALLY AN SDB... T4406500 BNE HCK800 ERROR IF NOT. T4407000 L RIOT,SDBPIOT YES. POINT TO PDDB'S IOT T4407500 L RBUF,SDBUBF AND TO UNPROTECTED BUFFER. T4408000 L RSVT,SDBSVT AND POINT TO SSVT. @OZ29839 T4408100 LTR RBUF,RBUF IF NO UNPROTECTED BUFFER, T4408500 BZ HCK800 ERROR. T4409000 LTR RIOT,RIOT IF NO PDDB'S IOT, T4409500 BZ HCK800 ERROR. T4410000 * THIS LINE DELETED BY APAR ===> @OZ45546 T4410500 * THIS LINE DELETED BY APAR ===> @OZ45546 T4411000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T4411500 USING BFD,RBUF SET BUF ADDRESSABILITY. T4412000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY @OZ29839 T4412100 * T4412500 * SAVE JOB AND DATA SET KEY T4413000 * T4413500 MVC 0(6,R4),SDBJKEY SAVE JOB AND DATA SET KEYS. T4414000 * T4418000 * IF OUTPUT DATA SET, TRUNCATE & WRITE. T4418500 * T4419000 HCK150 DS 0H T4419500 TM SDBFLG1,SDB1PUT IF NOT OUTPUT, T4420000 BZ HCK200 BRANCH. T4420500 CLI SDBCCW3+7,0 IF DATA SET NOT OPENED, @OZ45546 T4420600 BE HCK800 ERROR. @OZ45546 T4420700 L R1,BFLOC POINT TO CURRENT BUFFER LOC. T4421000 LA R5,BFIO GET ADDRESS OF @OZ29839 T4421100 AH R5,$SVBFSIZ BUFFER END @OZ29839 T4421150 CR R5,R1 COMPARE BFLOC TO END. @OZ29839 T4421200 BNH HCK800 ERROR IF BFLOC TOO LARGE. @OZ29839 T4421250 CR RBUF,R1 COMPARE BFLOC TO START. @OZ29839 T4421300 BNL HCK800 ERROR IF BFLOC TOO SMALL. @OZ29839 T4421350 MVI 0(R1),LRCBFEND TRUNCATE THE BUFFER. T4421500 L R1,SSDADEBP FROM THE T4422000 USING DEBBASIC,R1 DEB, GET T4422500 L R1,DEBDCBAD ACB POINTER T4423000 DROP R1 FOR HAMSVC. T4423500 LA R1,0(,R1) ZERO HIGH BYTE. T4424000 LNR R1,R1 SHOW HAMSVC ARG IS ACB. T4424500 LR R2,R1 SAVE NEGATIVE OF ACB. T4425000 LA R0,HSVCEOBP SET FUNCTION REGISTER. T4425500 SVC HAMSVC TRUNCATE THE BUFFER. T4426000 LA R1,BFDAT PT TO BUF DATA START. T4426500 MVI 0(R1),LRCBFEND TRUNCATE EMPTY BUFFER. T4427000 L RIOT,SDBAIOT FLAG ALLOCATION IOT T4427500 OI IOTFLAG1,IOT1CKPT FOR CHECKPOINT BY HCEPUT. T4428000 LR R1,R2 SET NEGATIVE ACB ADDRESS. T4428500 LA R0,HSVCEOBP SET FUNCTION REGISTER. T4429000 SVC HAMSVC WRITE TRUNCATED BUFFER. T4429500 B HCK250 CONTINUE. T4430000 * T4430500 * INPUT DATA SET - SET OPEN-FOR-INPUT FLAG T4431000 * T4431500 HCK200 DS 0H T4432000 CLC SSDADEBP,SDBDEB IF DATA SET NOT OPENED, @OZ45546 T4432100 BNE HCK800 ERROR. @OZ45546 T4432200 OI 6(R4),X'08' INPUT - SET FLAG FOR INPUT. T4432500 L R1,BFRBA+4 GET NR OF NEXT RECORD T4433000 LA R1,0(,R1) HAMGET WILL READ. T4433500 AL R1,SDBRECCT ADD CT FROM PREV BUFFERS. T4434000 ST R1,24(,R4) SAVE CURRENT REC NR. T4434500 * T4435000 * IF INPUT IS AT EOD, SET EOD FLAG T4435500 * T4436000 TM SDBFLG2,SDB2EOD IF NOT AT END-OF-DATA-SET, T4436500 BZ HCK250 BRANCH. T4437000 TM BFFL1,BF1EOB TEST END-OF-BUFFER TOO. R4 T4437500 BZ HCK250 BRANCH IF NOT EOD. T4438000 OI 6(R4),X'20' ELSE SET EOD FLAG. T4438500 * T4439000 * INPUT AND OUTPUT - TEST I/O ERROR T4439500 * T4440000 HCK250 DS 0H T4440500 TM SDBFLG2,SDB2IOE IF DATA SET NOT AT I/O ERROR, T4441000 BZ HCK300 BRANCH. T4441500 OI 6(R4),X'10' ELSE SET I/O ERROR FLAG T4442000 B HCK900 AND RETURN. T4442500 * T4443000 * SAVE CURRENT RBA VALUES T4443500 * T4444000 HCK300 DS 0H T4444500 MVC 8(8,R4),SDBTRKF SAVE STARTING RBA. T4445000 MVC 16(8,R4),BFRBA SAVE CURRENT RBA. T4445500 B HCK900 RETURN TO CALLER. T4446000 * T4446500 * ERROR - SET ERROR CODE AND EXIT T4447000 * T4447500 HCK800 LA R15,4 SHOW RETURN CODE 4 T4448000 B HCK950 AND RETURN TO USER. T4448500 * T4449000 * RETURN TO USER VIA $EPILOG T4449500 * T4450000 HCK900 DS 0H T4450500 SLR R15,R15 SHOW NORMAL RETURN. T4451000 HCK950 DS 0H T4451500 $EPILOG , RETURN WITH CODE IN R15. T4452000 DROP , DROP ALL BASES. T4452500 TITLE 'HOSREST -- SUBSYSTEM DATA SET RESTART FUNCTION' T4453000 HOSREST $PROLOG SSOBREST,SSDASIZE,LOCK=SDB T4453500 HOSRESTB DS 0H RESTART BASE LABEL T4454000 * T4454500 * UNLESS INTERNAL READER, SET SDBTRK, SDBTRKF. T4455000 * T4455500 USING SSDABGN,RSOX USE SSOB EXTENSION DSECT. T4456000 L R4,SSDABUFR POINT TO RESTART INFO BUFFER. T4456500 TM 6(R4),X'80' IF INTERNAL READER, T4457000 BO HRS100 SKIP SDB LOGIC. T4457500 L R5,SSDASSCM POINT TO THE SDB. T4458000 USING SDBDSECT,R5 USE ITS DSECT. T4458500 CLC SDBID,=CL4'SDB' IF POINTER IS NOT TO T4459000 BNE HRS800 AN SDB, ERROR. T4459500 MVC SDBTRKF(16),8(R4) ELSE REFRESH 1ST, CURRENT RBA. T4460000 * T4460500 * UNLESS EOD OR I/O ERROR USE HOSOPEN T4461000 * T4461500 HRS100 DS 0H T4462000 TM 6(R4),X'30' IF EOD OR IOE, T4462500 BNZ HRS200 DON'T USE HOSOPEN. T4463000 SL R12,=A(HOSRESTB-HOSOPENB) ELSE SET OPEN T4463500 BR R12 ADDRESSABILITY AND ENTER IT. T4464000 * T4464500 * I/O ERROR OR EOD - FAKE RE-OPEN HERE T4465000 * T4465500 HRS200 DS 0H T4466000 $GETBUF TYPE=UNPROT GET UNPROTECTED BUFFER. T4466500 BNZ HRS800 ERROR IF NONE. T4467000 LR RBUF,R1 SET BUFFER ADDRESSABILITY. T4467500 USING BFD,RBUF USE BUFFER DSECT. T4468000 MVI BFID,C'U' SHOW BUF IS UNPROTECTED. T4468500 ST RBUF,SDBUBF SAVE ITS ADDRESS IN SDB. T4469000 OI BFFL1,BF1EOB SHOW BUF AT END-OF-BUFFER. R4 T4469500 MVC SDBDEB,SSDADEBP SET DEB PTR IN SDB T4469800 OI SDBFLG2,SDB2EOD ASSUME SDB AT EOD. T4470000 L R4,SSDABUFR RE-POINT TO RESTART BUFFER. T4470500 TM 6(R4),X'20' IF EOD, SKIP. T4471000 BO *+8 ELSE RESET EOD T4471500 XI SDBFLG2,SDB2EOD+SDB2IOE AND SET I/O ERROR. T4472000 * T4472500 * SET SDB1PUT OR SDB1GET. IF SDB1GET GET A PBF. T4473000 * T4473500 OI SDBFLG1,SDB1PUT ASSUME OUTPUT DATA SET. T4474000 TM 6(R4),X'08' IF CORRECT, T4474500 BZ HRS900 RETURN. T4475000 XI SDBFLG1,SDB1PUT+SDB1GET ELSE SET INPUT DATA SET. T4475500 $GETBUF TYPE=PROT INPUT NEEDS A PROTECTED BUFFER. T4476000 BNZ HRS800 ERROR IF CAN'T GET. T4476500 LR RBUF,R1 SET BUFFER ADDRESSABILITY. T4477000 MVI BFID,C'P' SHOW BUFFER IS PROTECTED. T4477500 ST RBUF,SDBPBF SAVE ITS ADDRESS IN SDB. T4478000 B HRS900 RETURN TO CALLER. T4478500 * T4479000 * ERROR DURING DATA SET RESTART T4479500 * T4480000 HRS800 DS 0H T4480500 LA R15,4 SET R15=4 FOR ERROR T4481000 B HRS950 AND RETURN TO CALLER. T4481500 * T4482000 * RESTART COMPLETE. HERE ONLY IF EOD OR IOE. T4482500 * T4483000 HRS900 DS 0H T4483500 SLR R15,R15 SET R15=0 FOR NORMAL. T4484000 HRS950 DS 0H T4484500 $EPILOG , RETURN TO CALLER. T4485000 SPACE 1 T4485500 DROP , DROP ALL ADDRESSABILITY. T4486000 TITLE 'LITERAL POOL FOR OPEN/CLOSE' T4486500 LTORG T4487000 TITLE 'HASP ACCESS METHOD SVC CODES' T4487500 HAMSVC EQU 111 T4488000 * T4488500 SPACE 3 T4489000 * T4489500 * HAMSVC OPERATION CODES T4490000 * T4490500 SPACE 3 T4491000 HSVCEOBG EQU 0 END-OF-BLOCK ON A GET OPERATION T4491500 * - IF DATA AWAITS IN A PROTECTED T4492000 * BUFFER, HAMSVC WILL MOVE IT TO THE T4492500 * UNPROTECTED BUFFER, LINITIALIZING T4493000 * FIELDS. IF NOT, HAMSVC WILL SET T4493500 * ONE OF THE FLAGS DDT1IOA, DDT1IOE, T4494000 * OR DDT1EOD AND RETURN. IF BY THE T4494500 * NEXT GET THE CE APDG HASN'T RESET T4495000 * DDT1IOA, THE GET ROUTINE WILL WAIT T4495500 * UPON DDTECB. T4496000 SPACE 1 T4496500 HSVCEOBP EQU 4 END-OF-BLOCK ON A PUT OPERA- T4497000 * TION. HAMSVC GETS A PROTECTED T4497500 * BUFFER, MOVES TO IT THE UNPROTECTED T4498000 * BUFFER, CALLS $TRACK TO FIND ADDRESS T4498500 * OF NEXT BUFFER, CHAINS THIS BUFFER T4499000 * ON CHAIN OF BUFFERS TO BE WRITTTEN, T4499500 * AND ISSUES EXCP IF NECESSARY. IT T4500000 * RE-INITIALIZES THE UNPROTECTED T4500500 * BUFFER, RESETS UBFRBA, AND RETURNS T4501000 * TO CALLER. T4501500 SPACE 1 T4502000 HSVCIRD EQU 8 INTERNAL READER PUT OPERATION. T4502500 * HAMSVC MOVES DATA TO INTERNAL READER T4503000 * CONTROL AREA, $POSTS ASSOCIATED T4503500 * INTERNAL READER CONTROL AREA'S PCE, T4504000 * XMPOSTS HASP, AND WAITS. WHEN HASP T4504500 * XMPOSTS, HAMSVC RETURNS TO ISSUER. T4505000 SPACE 1 T4505500 HSVCPNT EQU 12 POINT OPERATION WAS ISSUED. T4506000 * HAMSVC STARTS WITH THE BLOCK ADDRES- T4506500 * SED BY THE MTTR PORTION OF THE RPLRB T4507000 * AR AND SCANS, READING MORE BLOCKS T4507500 * IF NECESSARY, UNTIL THE RECORD- T4508000 * NUMBER PORTION OF THE RBA HAS BEEN T4508500 * SATISFIED. UPON RETURN THE DDT AND T4509000 * UNPROTECTED BUFFER ARE SET SO THAT A T4509500 * GET WILL RETRIEVE THE POINTED-TO T4510000 * RECORD. T4510500 SPACE 1 T4511000 HSVCENDR EQU 20 ENDREQ OPERATION WAS ISSUED. T4511500 * HAMSVC TRUNCATES AND MOVES TO A T4512000 * PROTECTED BUFFER TO BE WRITTEN THE T4512500 * CURRENT UNPROTECTED BUFFER. T4513000 SPACE 1 T4513500 HSVCOUTL EQU 24 OUTPUT LIMIT IS EXCEEDED. T4514000 SPACE 1 T4514500 HSVCGUPD EQU 32 GET-UPDATE OPERATION. T4515000 SPACE 1 T4515500 HSVCPUPD EQU 36 PUT-UPDATE OPERATION. T4516000 SPACE 1 T4516500 HSVCXBM EQU 40 EXECUTION BATCH MONITOR - T4517000 * TERMINATE CURRENT USER JOB T4517500 * UNDER EXECUTION BATCH MONITOR T4518000 * AND CALL HASPXEQ TO GET T4518500 * ANOTHER USER JOB OR TO TERMINA- T4519000 * TE THE BATCH MONITOR T4519500 TITLE 'HASPAM - INTERFACE ROUTINE FOR HASP ACCESS METHODS' T4520000 RBUF EQU R6 T4520500 RRPL EQU R7 T4521000 RPBF EQU R7 T4521500 RACB EQU R8 T4522000 RSDB EQU R10 T4522500 RIOT EQU R5 T4523000 * THIS LOCATION IS POINTED TO BY T4523500 * ACBINRTN, IN THE ACB. T4524000 * LINKAGE IS --- T4524500 * L R15,ACBINRTN T4525000 * LA R1,RPL T4525500 * BALR R14,R15 T4526000 SPACE 3 T4526500 HAMNULL DS 0H CLOSED HASP JOB LOG ACB RTN. T4527000 SR R15,R15 ZERO THE RETURN CODE R4 T4527500 BR R14 AND RETURN. T4528000 SPACE 3 T4528500 HASPAM DS 0F T4529000 USING *,R15 T4529500 B *+8 BRANCH AROUND ADCON. T4530000 DC A(SVCHAM) ADCON FOR SVC 111. T4530500 STM R14,R12,12(R13) SAVE REGISTERS. T4531000 LR R12,R15 SET HAM LOCAL BASE REGISTER. T4531500 HAMBASE EQU HASPAM DEFINE HAM BASE LOCATION. T4532000 USING HAMBASE,R12 SET HAM ADDRESSABILITY. T4532500 DROP R15 DROP TEMPORARY BASE. T4533000 USING RPLDSECT,R1 USE RPL DSECT. T4533500 * VALIDITY CHECKING - T4534000 * RPLREQ MUST BE .LE. 5, ELSE RETURN T4534500 * ERROR CODE RPLINVP - INVALID PROCES- T4535000 * SING OPTIONS. T4535500 * T4536000 CL R0,=A(RPLERASE) IS OPTION VALID... T4536500 BH HERINVP IF NOT, RETURN. T4537000 * T4537500 * PUT OTHER VALIDITY CHECING HERE T4538000 * T4538500 EJECT T4539000 * SET UP REGISTERS FOR HASP ACCESS METHODS. T4539500 * REGISTER CONVENTIONS ARE --- T4540000 * R0, R1, R15 - WORK REGISTERS AND USED AS ARGUMENTS TO T4540500 * HAMSVC. T4541000 * R2 - R5 - WORK REGISTERS AND USED WITH MVCL AS FOLLOWS-- T4541500 * R2 - HAM BUFFER ADDRESS T4542000 * R3 - HAM DATA LENGTH T4542500 * R4 - USER BUFFER ADDRESS T4543000 * R5 - USER BUFFER LENGTH T4543500 * RBUF R6 - ADDRESS OF CURRENT HASP BUFFER T4544000 * RRPL R7 - ADDRESS OF RPL T4544500 * RPBF R7 - ADDRESS OF PBF T4545000 * RACB R8 - ADDRESS OF ACB T4545500 * R9 - RESERVED FOR USER MODIFICATIONS T4546000 * RDDT RA - ADDRESS OF DDT T4546500 * RB - SUBROUTINE BASE T4547000 * RC - MAIN ROUTINE BASE T4547500 * RD - ADDRESS OF USER SAVE AREA T4548000 * RE - LINKAGE REGISTER T4548500 SPACE 3 T4549000 HAMREDO LR RRPL,R1 SET RPL BASE. @OZ44947 T4549500 USING RPLDSECT,RRPL USE RPL DSECT. T4550000 STC R0,RPLREQ SAVE REQUEST TYPE IN RPL. T4550500 DROP R1 DROP OLD RPL BASE. T4551000 L RACB,RPLDACB POINT TO ACB FROM RPL. T4551500 USING ACBDSECT,RACB USE ACB DSECT. T4552000 CLI ACBID,ACBIDVAL IF ACB DOESN'T LOOK RIGHT, T4552500 BNE HERBLKER SHOW CONTROL BLOCK ERROR. T4553000 * TEST FOR ACBOPEN FLAG IS UNNECESSARY T4553500 L RSDB,ACBDEB-1 POINT TO DEB FROM ACB. T4554000 USING DEBBASIC,RSDB USE DEB DSECT. T4554500 L RSDB,DEBIRBAD POINT TO SDB FROM DEB. T4555000 TM ACBINRTN,ACBINR IS DATA SET AN INTERNAL RDR... T4555500 BZ HAM010 IF NOT, PROCESS SDB. T4556000 * T4556500 * INTERNAL READER INITIALIZATION T4557000 * T4557500 USING DCTDSECT,RSDB SET INTRDR ADDRESSABILITY. T4558000 L RSVT,RIDSSVT POINT TO SUBSYS VECTOR TABLE. T4558500 CLI RPLREQ,RPLPUT IS THIS A PUT REQUEST... T4559500 BE HPIRDR BRANCH IF SO. T4560000 CLI RPLREQ,RPLENDRE IS THIS AN END REQUEST... T4560500 BE HENDI BRANCH IF SO. T4561000 B HERINVP OTHERWISE INVALID REQUEST. T4561500 EJECT T4562000 * T4562500 * NORMAL SUBSYSTEM DATA SET INITIALIZATION T4563000 * T4563500 HAM010 DS 0H T4564000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T4564500 L RSVT,SDBSVT POINT TO SUBSYS VECTOR TABLE. T4565000 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T4565500 USING BFD,RBUF SET BUFFER ADDRESSABILITY. T4566000 USING $SVDSECT,RSVT SET SSVT ADDRESSABILITY. R4 T4566300 USING LRCDSECT,R1 SET LOGICAL RECORD ADDR'TY. T4566500 * T4567000 * SELECT FUNCTION FROM RPL. T4567500 * T4568000 * FUNCTIONS ARE --- T4568500 * 0 GET T4569000 * 1 PUT T4569500 * 2 CHECK T4570000 * 3 POINT T4570500 * 4 ENDREQ T4571000 * 5 ERASE T4571500 * T4572000 SPACE 3 T4572500 LR R15,R0 GET REQUEST NUMBER. T4573000 AR R15,R15 MULTIPLY T4573500 AR R15,R15 BY 4. T4574000 B *+4(R15) BRANCH ACCORDING TO R15 --- T4574500 B HAMGET GET T4575000 B HAMPUT PUT T4575500 B HAMCHECK CHECK T4576000 B HAMPOINT POINT T4576500 B HAMENDRE ENDREQ T4577000 B HAMERASE ERASE T4577500 EJECT T4578000 * T4578500 * THE FOLLOWING FUNCTIONS RESULT IN AN T4579000 * IMMEDIATE NORMAL RETURN TO THE USER. T4579500 * T4580000 * HAMCHECK SINCE RPLECB HAS ALREADY BEEN POSTED T4580500 * COMPLETE IN GET AND PUT. T4581000 * HAMERASE FUNCTION IS NOT SUPPORTED FOR T4581500 * JES DATA SETS. T4582000 SPACE 3 T4582500 HAMCHECK DS 0H T4583000 L R15,RPLFDBK-1 FOR CHECK, RETURN T4583500 LA R0,0(,R15) TO USER THE CONTENTS T4584000 B HRPLEXIT OF RPLFDBK. T4584500 HAMERASE DS 0H T4585000 SR R0,R0 SET ZERO RETURN CODE. T4585500 B HRPLEXIT RETURN TO CALLER. T4586000 TITLE '''GET'' ACCESS METHOD ROUTINE' T4586500 * T4587000 * T4587500 * HASP 'GET' ACCESS METHOD ROUTINE T4588000 * T4588500 * T4589000 HAMGET DS 0H T4589500 * T4590000 * PROCESS SEQUENTIAL NON-UPDATE GET T4590500 * T4591000 TM RPLOPT2,RPLUPD IS THIS AN UPDATE REQUEST... T4591500 BO HG100 BRANCH IF SO. T4592000 SPACE 1 T4592500 TM SDBFLG1,SDB1GET DOES DATA SET ALLOW GET... T4593000 BZ HERINVP ERROR IF NOT. T4593500 TM BFFL1,BF1EOB EOB ON PREVIOUS GET... R4 T4593600 LA R14,HG010 SET RETURN R4 T4593700 BO HGSPEC BR IF YES (EOB) R4 T4593800 SPACE 1 T4594000 HG010 DS 0H T4594500 L R1,BFLOC POINT TO CURR LOGICAL RECORD. T4595000 BAL R14,HGMOVE MOVE IT TO USER BUFFER. T4595500 LA R14,HG010 IF NEXT BUFFER NEEDED, T4596000 BC 1,HGSPEC BRANCH FOR SPECIAL PROCESSING. T4596500 LM R0,R1,BFRBA ELSE GET CURRENT RBA. T4597000 STM R0,R1,RPLRBAR RETURN IT TO USER IN RPL. T4597500 AL R1,=F'1' INCREMENT IT BY ONE T4598000 ST R1,BFRBA+4 AND SAVE FOR NEXT TIME. T4598500 B HERNORML RETURN NORMALLY. T4599000 EJECT T4599500 * T4600000 * PROCESS UPDATE-FORM GET T4600500 * T4601000 HG100 DS 0H T4601500 L R2,RPLARG POINT TO RBA TO LOCATE AND T4602000 LM R2,R3,0(R2) LOAD IT INTO R2 AND R3. T4602500 CLM R3,7,=F'0' IF LLL IS ZERO, T4603000 BZ HERINRBA BAD RBA. T4603500 CALL HFINDRBA TRY TO FIND RBA IN UBF. T4604000 BNZ HG110 BRANCH IF NOT FOUND. T4604500 * R1 IS SET BY HFINDRBA T4605000 BAL R14,HGMOVE MOVE RECORD TO USER. T4605500 BC 1,HERRDERD SHOW PHYS READ ERR IF CC+3. T4606000 SLR R0,R0 SHOW NORMAL COMPLETION T4606500 B HRPLEXIT AND RETURN TO CALLER. T4607000 * T4607500 * RECORD IS SPANNED OR NOT IN BUFFER T4608000 * T4608500 HG110 LA R1,BFDAT IF UNPROTECTED BUFFER T4609000 CL R1,BFLOC HAS NOTHING IN IT, T4609500 BE HG115 CONTINUE. T4610000 L R1,BFLOC ELSE TRUNCATE T4610500 MVI LRCTLENG,LRCBFEND AND WRITE T4611000 LA R0,HSVCEOBP THE T4611500 LR R1,RRPL UNPROTECTED BUFFER. T4612000 SVC HAMSVC BUFFER. T4612500 MVI BFDAT,LRCBFEND SHOW NO DATA IN IT. T4613000 HG115 LA R0,HSVCGUPD SET HAMSVC FUNCTION REGISTER. T4613500 LR R1,RRPL SET HAMSVC ARGUMENT REGISTER. T4614000 SVC HAMSVC ISSUE HAMSVC FOR GET-UPDATE. T4614500 LTR R0,R15 IF HAMSVC FOUND AN ERROR, T4615000 BNZR R15 RETURN TO USER. T4615500 * T4616000 * RECORD TO UPDATE NOW RESIDES IN ONE OR MORE HBFS T4616500 * T4617000 L RBUF,SDBHBF POINT TO FIRST HBF. T4617500 HG120 DS 0H T4618000 LTR RBUF,RBUF IF BUFFER POINTER ZERO, T4618500 BZ HERRDERD SHOW PHYS READ ERROR. T4619000 L R1,SDBHBF GET FIRST HBF @OZ43706 T4619010 CR R1,RBUF IS IT FIRST BUF... @OZ43706 T4619020 BE HG1203 BRANCH IF YES @OZ43706 T4619030 HG1202 CLM RBUF,7,BFBF+1-BFD(R1) FROM THIS ONE @OZ43706 T4619040 BE HG1201 YES @OZ43706 T4619050 L R1,BFBF-BFD(R1) GET NEXT BUF @OZ43706 T4619060 B HG1202 AND LOOP @OZ43706 T4619070 HG1201 EQU * @OZ43706 T4619080 MVC BFFL1,BFFL1-BFD(R1) MOVE FLAG @OZ43706 T4619090 NI BFFL1-BFD(R1),255-BF1GSG RESET IN OLD @OZ43706 T4619100 HG1203 EQU * @OZ43706 T4619110 L R1,BFLOC POINT TO CORRECT RECORD. T4619500 BAL R14,HGMOVE GO MOVE IT TO CALLER. T4620000 LA R0,0 SET R0 FOR NORMAL COMPLETION. T4620500 L RBUF,BFBF GET POINTER TO NEXT HBF. T4621000 BC 1,HG120 IF HGMOVE CC=3,CONTINUE. T4621500 CLR R0,RBUF ELSE NEXT BUF PTR MUST BE 0. T4622000 BNE HERRDERD SHOW PHYS READ ERROR IF NOT. T4622500 B HRPLEXIT ELSE RETURN NORMALLY. T4623000 EJECT T4623500 * T4624000 * SPECIAL PROCESSING FOR HAMGET T4624500 * T4625000 HGSPEC DS 0H T4625500 * T4626000 * IF I/O IS ACTIVE, WAIT FOR IT TO COMPLETE T4626500 * T4627000 TM SDBFLG2,SDB2IOA IS I/O ACTIVE... T4627500 BZ HGS020 BRANCH IF NOT @OZ30886 T4628000 TM SDBFLG2,SDB2IOE IO ERR DETECTED BY HENDRD. @OZ30886 T4628100 BO HGS030 YES, GO PROCESS IO ERROR @OZ30886 T4628200 TM BFECB,X'40' ELSE CHECK ECB. T4628500 BO HGS010 IF ALREADY POSTED, SKIP WAIT. T4629000 TM BFFL2,BF2IOC HAS CEA LOOP DRIED UP... @OZ30886 T4629160 BO HGS020 BRANCH IF YES @OZ30886 T4629320 WAIT 1,ECB=BFECB WAIT FOR I/O COMPLETION. T4629500 HGS010 SLR R0,R0 ZERO OUT T4630000 ST R0,BFECB THE ECB. T4630500 TM BFFL1,BF1EOB IF UBF NOT YET FILLED, R4 T4630600 BO HGSPEC GO WAIT AGAIN @OZ30886 T4630700 TM SDBFLG2,SDB2EOD END OF DATA DETECTED... @OZ30886 T4630750 BZR R14 NO, RETURN @OZ30886 T4630800 OI BFFL2,BF2IOC SET IOC FOR NEXT TIME @OZ30886 T4630850 BR R14 RETURN TO CALLER. T4631000 * T4631500 * IF END-OF-BUFFER & I/O INACTIVE, ISSUE SVC T4632000 * T4632500 HGS020 DS 0H T4633000 NI BFFL2,255-BF2IOC RESET IO STOPPED IND. @OZ30886 T4633125 TM BFFL1,BF1EOB HAS CEA PRIMED BUFFER... @OZ30886 T4633250 BZ HGS010 RETURN TO USER IF YES @OZ30886 T4633375 TM SDBFLG2,SDB2IOE+SDB2EOD IF EXCEPTIONAL T4633500 BNZ HGS030 CONDITION, BRANCH. T4634000 * THIS LINE DELETED BY APAR NUMBER @OZ30886 T4634160 * THIS LINE DELETED BY APAR NUMBER @OZ30886 T4634320 LA R0,HSVCEOBG SET HAMSVC FUNCTION REGISTER. T4634500 LR R1,RRPL SET HAMSVC ARGUMENT REGISTER. T4635000 SVC HAMSVC ISSUE HAMSVC. T4635500 LTR R0,R15 IF HAMSVC FOUND NO ERROR, T4636000 BNZ HERRDERD INDICATE ERROR @OZ30886 T4636500 TM SDBFLG2,SDB2EOD DID EOD OCCUR... @OZ30886 T4637000 BZR R14 NO, RETURN @OZ30886 T4637100 OI BFFL2,BF2IOC SET IOC FOR NEXT TIME @OZ30886 T4637200 BR R14 RETURN @OZ30886 T4637300 * T4637500 * TREAT EXCEPTIONAL CONDITIONS HERE T4638000 * T4638500 HGS030 DS 0H T4639000 TM SDBFLG2,SDB2EOD IF NOT END-OF-DATA-SET, T4639500 BZ HERRDERD SHOW USER A READ ERROR. T4640000 TM SDBFLG2,SDB2XBIN IF NOT XBM BATCH INPUT, T4640500 BZ HERNOEOD SHOW USER END-OF-DATA. T4641000 * T4641500 * END EXEC BATCH MON USER JOB HERE T4642000 * T4642500 LR R1,RRPL POINT R1 TO THE RPL T4643000 LA R0,HSVCXBM AND SET FUNC CODE IN R0. T4643500 SVC HAMSVC CALL HAMSVC TO END JOB. T4644000 B *+4(R15) BRANCH ACC TO R15. T4644500 B HG010 +0 - CONTINUE WITH NEW INPUT. T4645000 HGS035 MVI BFECB,0 +4 - END BATCH MONITOR - @OZ35973 T4645500 WAIT ECB=BFECB FAKE WAIT @OZ35973 T4646000 B HGS035 SHOULD NEVER BE POSTED @OZ35973 T4646200 TITLE 'HGMOVE - HAM GET SUBROUTINE' T4646500 * T4647000 * HAM SUBROUTINE TO MOVE RECORD TO USER T4647500 * T4648000 HGMOVE DS 0H T4648500 LR R4,R1 SET R4 FOR IF END-OF-BUFFER. T4649000 TM BFFL1,BF1GSG IF RE-ENTRY FOR SEGMENT, T4649500 BO HGM100 BRANCH TO RE-ENTRY POINT. T4650000 * T4650500 * INITIALIZE TO MOVE ANY RECORD T4651000 * T4651500 TM BFFL1,BF1EOB IF END-OF-BUFFER OR ERROR, R4 T4652000 BOR R14 RETURN CC=3 TO HANDLE. T4652500 TM LRCTLENG,LRCBFEND IF NOT END-OF-BUFFER, T4653000 BNO HGM005 CONTINUE. T4653500 OI BFFL1,BF1EOB OTHERWISE SET EOB FLAG, R4 T4654000 TM *+1,X'FF' SET CONDITION CODE 3, T4654500 BR R14 AND RETURN. T4655000 HGM005 DS 0H T4655500 L R2,RPLAREA POINT TO USER BUFFER. T4656000 * T4656500 * MOVE SIMPLE RECORD TO USER T4657000 * T4657500 SLR R5,R5 ZERO SOURCE LENGTH REG. T4658000 SLR R3,R3 ZERO SINK LENGTH REG. T4658500 TM SDBFLG1,SDB1PSO IF DATA SET IS FOR PSO, T4659000 BO HGM040 GO PROCESS CARRIAGE CTRL. T4659500 TM LRCFLAG1,LRC1CCTL+LRC1SPAN+LRC1INUL BRANCH IF T4660000 BNZ HGM040 NOT A SIMPLE RECORD. T4660500 LA R4,LRCTEXT POINT TO SIMPLE TEXT START T4661000 HGM010 DS 0H ENTRY FROM CARRIAGE-CONTROL. T4661500 IC R5,LRCTLENG GET LENGTH TO MOVE. T4662000 ICM R5,8,=C' ' SET BLANK PAD. T4662500 IC R3,LRCLRECL GET LENGTH OF RECORD. T4663000 HGM020 DS 0H ENTRY FROM SINGLE-SEGMENT SPANNED. T4663500 ST R3,RPLRLEN RETURN REC LENG TO USER. T4664000 LR R1,R3 SAVE RECORD LENGTH. T4664500 L R3,RPLBUFL GET BUFFER LENGTH. T4665000 HGM030 DS 0H ENTRY FROM PSO CARRIAGE CONTROL T4665500 SLR R1,R3 COMPUTE (REC LENG)-(BUF LENG). T4666000 MVCL R2,R4 MOVE RECORD TO BUFFER. T4666500 LTR R1,R1 IF REC LENG .GT. BUF LENG, T4667000 BP HERINBUF ERROR - INVALID BUF SIZE. T4667500 TM SDBFLG2,SDB2XBIN IF NOT XBM BATCH INPUT, T4668000 BZ HGMEND GO TO EXIT CODE. T4668500 L R2,RPLAREA POINT TO DATA JUST MOVED. T4669000 CLC =CL2'$$',0(R2) IF NOT '$$', T4669500 BNE HGMEND GO TO EXIT CODE. T4670000 LA R14,HERNOEOD ELSE FORCE EXIT TO T4670500 B HGMEND RETURN TO END-OF-FILE. T4671000 SPACE 3 T4671500 * T4672000 * MOVE CARRIAGE-CONTROL RECORD TO USER T4672500 * T4673000 HGM040 DS 0H T4673500 TM LRCFLAG1,LRC1SPAN BUT IF SPANNED, GO TO T4674000 BO HGM050 THE SPANNED-RECORD ROUTINE. T4674500 TM LRCFLAG1,LRC1INUL AND IF NULL ON INPUT, T4675000 BO HGM070 SKIP OVER IT. T4675500 TM SDBFLG1,SDB1PSO IF DATA SET IS NOT PSO, T4676000 LA R4,LRCSOUT SKIP CARR CTRL CHARACTER T4676500 BZ HGM010 AND GO GIVE USER RECORD. T4677000 * PSO CARRIAGE CONTROL PROCESSING T4677500 TM LRCFLAG1,LRC1CCTL IF CARR CTRL CHAR PRESENT, T4678000 IC R5,LRCCCTL GET IT INTO REGISTER 5 T4678500 BO HGM045 AND GO STORE IT IF REQ'D. T4679000 LA R4,LRCTEXT OTHERWISE RESET TEXT PTR. T4679500 LA R5,X'40' SET ASA SPACE-1-&-PRINT. T4680000 TM ACBCCTYP,ACBCCMCH IF NOT MACHINE, T4680500 BZ HGM045 MUST BE ASA OR NONE. T4681000 LA R5,X'09' SET MCH PRINT-&-SPACE-1. T4681500 HGM045 DS 0H T4682000 TM ACBCCTYP,ACBCCMCH+ACBCCASA IF USER WANTS NOT, T4682500 BZ HGM010 BRANCH. T4683000 STC R5,0(,R2) ELSE SET CARR CTRL FOR USER. T4683500 LA R2,1(,R2) POINT TO NEXT USER AREA BYTE. T4684000 IC R3,LRCLRECL GET LOGICAL RECORD LENGTH T4684500 LA R0,1(,R3) & ADD 1 FOR CARR CTRL. T4685000 ST R0,RPLRLEN RETURN LENGTH TO USER. T4685500 IC R5,LRCTLENG GET TRUNCATED LENGTH. T4686000 ICM R5,8,=C' ' SET BLANK PADDING. T4686500 LR R1,R3 SET R1=RPLRLEN-1 FOR HGM030. T4687000 L R3,RPLBUFL GET USER AREA LENGTH T4687500 S R3,=F'1' (MINUS 1 FOR CARR CTRL) T4688000 BP HGM030 AND GO MOVE THE RECORD. T4688500 B HERINBUF ERROR - USER AREA TOO SMALL. T4689000 SPACE 3 T4689500 * T4690000 * MOVE SINGLE-SEGMENT SPANNED RECORD TO USER T4690500 * T4691000 HGM050 DS 0H T4691500 TM LRCFLAG1,LRC1SBGN IF NOT FIRST SEGMENT, T4692000 BZ HERRDERD SHOW PHYSICAL READ ERROR. T4692500 LA R4,LRCSFTXT ELSE POINT TO THE TEXT T4693000 LH R5,LRCSEGL AND GET SEGMENT LENGTH. T4693500 LR R3,R5 SET SINK LENGTH REGISTER. T4694000 TM LRCFLAG1,LRC1SEND IF SINGLE-SEGMENT, T4694500 BO HGM020 GO MOVE IT. T4695000 * T4695500 * MULTI-SEGMENT - MOVE FIRST SEGMENT TO USER T4696000 * T4696500 LH R0,LRCSRECL GET TOTAL RECORD LENGTH. T4697000 ST R0,RPLRLEN RETURN IT TO THE USER. T4697500 CL R0,RPLBUFL IF BUFFER NOT LARGE ENOUGH, T4698000 BH HERINBUF RETURN ERROR CODE. T4698500 OI BFFL1,BF1GSG ELSE SET RE-ENTRY FLAG. T4699000 HGM060 DS 0H ENTRY FROM RE-ENTRY CODE T4699500 LR R3,R5 SET SINK LENGTH TO SOURCE. T4700000 MVCL R2,R4 MOVE THIS SEGMENT TO USER. T4700500 B HGMEND GO CHECK FOR EOB. T4701000 SPACE 3 T4701500 * T4702000 * SKIP OVER NULL-ON-INPUT RECORD T4702500 * T4703000 HGM070 DS 0H T4703500 IC R5,LRCTLENG GET TEXT LENGTH, POINT TO T4704000 LA R0,LRCSOUT(R5) NEXT RECORD ASSUMING CCTL. T4704500 TM LRCFLAG1,LRC1CCTL DOES RECORD CONTAIN CCTL... T4705000 BO *+8 SKIP IF SO. T4705500 LA R0,LRCTEXT(R5) POINT TO NEXT NON-CCTL RECORD. T4706000 LR R1,R0 SET REGISTER ONE T4706500 B HGMOVE AND RE-ENTER HGMOVE. T4707000 SPACE 3 T4707500 * T4708000 * MOVE NOT-FIRST SEGMENT TO USER T4708500 * T4709000 HGM100 DS 0H T4709500 CLI LRCTLENG,0 IF INVALID SPANNED FORMAT, T4710000 BNE HERRDERD SHOW PHYS READ ERROR. T4710500 TM LRCFLAG1,LRC1SPAN IF SPAN FLAG IS NOT ON, T4711000 BZ HERRDERD SHOW PHYS READ ERROR. T4711500 LA R4,LRCSTEXT POINT TO SEGMENT'S TEXT T4712000 LH R5,LRCSEGL AND GET SEGMENT LENGTH. T4712500 TM LRCFLAG1,LRC1SEND IF THIS SEGMENT IS NOT LAST, T4713000 BZ HGM060 GO MOVE & CHECK END-BUFFER. T4713500 NI BFFL1,255-BF1GSG ELSE RESET RE-ENTRY SWITCH T4714000 LR R3,R5 SET SINK LENGTH REGISTER. T4714500 MVCL R2,R4 MOVE LAST SEGMENT. T4715000 HGMEND DS 0H T4715500 TM RPLOPT2,RPLUPD IF GET-UPDATE, T4716000 BO HGMEND1 JUST RETURN. T4716500 ST R4,BFLOC SAVE NEXT RECORD ADDRESS. T4717000 CLI 0(R4),LRCBFEND IF IT'S NOT END OF BUF, T4717500 BNE HGMEND1 JUST RETURN. T4718000 OI BFFL1,BF1EOB SET END-OF-BUFFER FLAG. R4 T4718500 HGMEND1 DS 0H T4719000 TM BFFL1,BF1GSG SET CC=3 IF MORE SEGMENTS. T4719500 BR R14 RETURN. T4720000 TITLE '''PUT'' ACCESS METHOD ROUTINE' T4720500 * T4721000 * T4721500 * HASP 'PUT' ACCESS METHOD T4722000 * T4722500 * T4723000 HAMPUT DS 0H T4723500 NI BFFL1,255-BF1PSG-BF1PMV RESET ENTRY FLAGS T4723800 * T4724000 * PROCESS SEQUENTIAL NON-UPDATE PUT T4724500 * T4725000 TM RPLOPT2,RPLUPD IS THIS AN UPDATE REQUEST... T4725500 BO HP100 BRANCH IF SO. T4726000 SPACE 1 T4726500 TM SDBFLG1,SDB1PUT IS PUT VALID ON DATA SET... T4727000 BZ HERINVP ERROR IF NOT. T4727500 SPACE 1 T4728000 L R6,SDBUBF POINT TO UNPROTECTED BUFFER. T4728500 BAL R14,HPMOVE LET HPMOVE DO THE WORK. T4729000 ST R1,BFLOC SAVE ADR OF NEXT AVL BYTE. T4729500 BC 8,HP020 RETURN TO USER @OZ43719 T4730000 * T4730500 * HPMOVE REQUIRES ANOTHER BUFFER TO COMPLETE RECORD T4731000 * T4731500 TM SDBFLG2,SDB2IOE IF I/O ERROR, T4732000 BO HERWTERD RETURN ERROR TO USER. T4732500 MVI LRCTLENG,LRCBFEND TRUNCATE CURRENT BUFFER. T4733000 LA R0,HSVCEOBP SET HAMSVC FUNCTION REGISTER. T4733500 LR R1,RRPL SET HAMSVC ARGUMENT REGISTER. T4734000 SVC HAMSVC ISSUE HAMSVC. T4734500 LTR R15,R15 UNLESS SVC HAD AN ERROR, T4735000 BZ HPMOVE TRY AGAIN TO MOVE DATA. T4735500 BR R15 ERROR - TELL IT TO THE USER. T4736000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4736500 PRINT OFF @OZ43719 T4737000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4737500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4738000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4738500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4739000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4739500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4740000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4740500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4741000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4741500 PRINT ON @OZ43719 T4742000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T4742500 * T4743000 * RETURN RBA TO USER T4743500 * T4744000 HP020 DS 0H T4744500 L R3,BFRBA+4 GET RIGHT HALF OF RBA. T4745000 AL R3,=F'1' INCREMENT IT BY 1 T4745500 ST R3,BFRBA+4 AND SAVE NEW RBA IN UBF. T4746000 * T4746500 * COMPUTE SPACE LEFT IN UBF T4747000 * T4747500 L R2,BFLOC GET PTR TO NEXT AVAIL BYTE. T4748000 LA R3,BFIO-1 COMPUTE R4 T4748500 AH R3,$SVBFSIZ SPACE AVAILABLE R4 T4749000 SLR R3,R2 IN UBF. R4 T4749500 ST R3,BFLEN SAVE SPACE AVAIL IN UBF. T4750000 * T4750500 * RETURN TO USER T4751000 * T4751500 B HERNORML RETURN TO USER. T4752000 EJECT T4752500 * T4753000 * PROCESS PUT-UPDATE REQUEST T4753500 * T4754000 HP100 DS 0H T4754500 L R2,RPLARG POINT TO RBA TO LOCATE AND T4755000 LM R2,R3,0(R2) LOAD IT INTO R2 AND R3. T4755500 CALL HFINDRBA SEE IF CURRENT UBF HAS THE RBA. T4756000 BNZ HP110 IF NOT, TRY HBFS. T4756500 * T4757000 * MOVE RECORD INTO CURRENT UBF T4757500 * T4758000 BAL R14,HP190 CHECK LENGTH. T4758500 L R15,BFLOC SAVE CURRENT BUF OFFSET IN R15. T4759000 ST R1,BFLOC SET UPDATE LOCN IN BFLOC T4759500 BAL R14,HPMOVE AND USE HPMOVE TO MOVE RECORD. T4760000 ST R15,BFLOC RESTORE CURRENT BUFFER OFFSET. T4760500 LA R0,0 SHOW NORMAL COMPLETION. T4761000 BC 8,HRPLEXIT RETURN TO USER. T4761500 * T4762000 * MOVE RECORD INTO HOLD BUFFERS T4762500 * T4763000 HP110 DS 0H T4763500 L RBUF,SDBHBF POINT TO FIRST HOLD BUFFER. T4764000 LTR RBUF,RBUF IF NO HOLD BUFFERS, ERROR - T4764500 BZ HERINUPD PUT-UPDATE BEFORE GET-UPDATE. T4765000 L R1,BFLOC POINT TO UPDATING RECORD. T4765500 BAL R14,HP190 VERIFY LENGTH IS CORRECT. T4766000 HP120 BAL R14,HPMOVE MOVE DATA FROM USER @OZ16677 T4766500 LR R1,RBUF SAVE RBUF @OZ43706 T4766510 L RBUF,BFBF POINT TO NEXT HBF. T4767000 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T4767500 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T4768000 BC 2,HP1201 REPEAT IF REQUIRED @OZ43706 T4768010 LA R0,HSVCPUPD SET HAMSVC FUNCTION REGISTER. T4768500 LR R1,RRPL SET HAMSVC ARGUMENT REGISTER. T4769000 SVC HAMSVC ISSUE HAMSVC. T4769500 LTR R0,R15 TRANSFER RETURN CODE TO R0 T4770000 B HRPLEXIT AND RETURN TO USER. T4770500 HP1201 EQU * @OZ43706 T4770510 MVC BFFL1,BFFL1-BFD(R1) MOVE FLAG @OZ43706 T4770520 NI BFFL1-BFD(R1),255-BF1PSG-BF1PMV RESET IN OLDBF @OZ43706 T4770530 L R1,BFLOC POINT TO NEXT SEG @OZ43706 T4770540 B HP120 AND LOOP @OZ43706 T4770550 SPACE 3 T4771000 * T4771500 * SUBROUTINE TO VERIFY UPDATE LENGTH T4772000 * T4772500 HP190 DS 0H T4773000 SLR R0,R0 ZERO R0 FOR RECORD ELNGTH. T4773500 IC R0,LRCTLENG ASSUME NON-SPAN, GET LENGTH. T4774000 TM LRCFLAG1,LRC1SPAN IS RECORD SPANNED... T4774500 BZ *+8 IF NOT-, LENGTH OKAY. T4775000 LH R0,LRCSRECL GET SPANNED-RECORD LENGTH. T4775500 CL R0,RPLRLEN IS USER LENGTH CORRECT... T4776000 BER R14 RETURN IF SO. T4776500 B HERDLCER OTHERWISE DATA LENGTH ERROR. T4777000 TITLE 'PUT/ENDREQ FOR INTERNAL READER' T4777500 * T4778000 * ENTRY FOR PUT FOR INTRDR T4778500 * T4779000 HPIRDR DS 0H T4779500 USING DCTDSECT,RSDB ESTABLISH DCT ADDRESSABILITY. T4780000 * T4780500 * SET REQUEST TYPE FLAGS T4781000 * T4781500 * THIS LINE DELETED BY APAR NUMBER @OZ24894 T4782500 L R2,RPLAREA GET POINTER TO USER RECORD T4783000 LA R2,0(,R2) CLEAR HI-ORDER BYTE R4 T4783100 L R3,RPLRLEN AND GET ITS LENGTH. T4783500 CL R3,=F'5' IF LENGTH LESS THAN 5, T4784000 BL HPI030 CAN'T BE /*EOF OR /*DEL. T4784500 SLR R0,R0 ZERO REGISTER TO HOLD FLAGS. T4785000 CLC =C'/*EOF',0(R2) IS IT /*EOF... T4785500 BNE HPI010 SKIP IF NOT. T4786000 LA R0,RIDEOF YES. SET FLAG IN R0. T4786500 HPI010 CLC =C'/*DEL',0(R2) IS IT /*DEL... T4787000 BE HPI015 BR IF YES R41 T4787200 CLC =C'/*PURGE',0(R2) IS IT /*PURGE... R41 T4787300 BNE HPI020 SKIP IF NOT. T4787500 HPI015 LA R0,RIDDEL SET DEL/PURGE FLAG IN R0 R41 T4788000 HPI020 SLL R0,24 SHIFT FLAG TO HIGH BYTE T4788500 OR R2,R0 AND ADD IT TO REG 2. T4789000 HPI030 BAL R14,HINTRDR CALL GENERALIZED INTRDR T4789500 B HRPLEXIT SUBROUTINE AND RETURN. T4790000 SPACE 3 T4790500 * T4791000 * ENTRY FOR ENDREQ FOR INTRDR T4791500 * T4792000 HENDI DS 0H T4792500 * THIS LINE DELETED BY APAR ===> @OZ41586 T4792800 LM R2,R3,HENDIAD GET DATA START, LENG, FLAGS T4794000 BAL R14,HINTRDR AND CALL INTRDR SUBROUTINE. T4794500 MVC RPLRBAR,RIDJOBID RETURN JOB ID TO USER IN RPL. T4795000 B HRPLEXIT RETURN TO CALLER. T4795500 SPACE 2 T4796000 HENDIAD DS 0F T4796500 DC AL1(RIDERQ) FLAGS - ENDREQ T4797000 DC AL3(*+7) DATA ADDRESS T4797500 DC A(5) DATA LENGTH T4798000 DC C'/*EOF' DATA T4798500 TITLE 'INTRDR ACCESS METHOD ROUTINE' T4799000 * T4799500 * GENERALIZED INTRDR SUBROUTINE T4800000 * T4800500 HINTRDR DS 0H T4801000 RIDEOF EQU X'08' PUT REQUEST FOR /*EOF T4801500 RIDDEL EQU X'04' PUT REQUEST FOR /*DEL OR /*PURGE R41 T4802000 RIDERQ EQU X'02' ENDREQ REQUEST T4802500 RIDCLS EQU X'01' CLOSE REQUEST T4803000 * T4803500 * IF NO INTRDR BUFFERS, GET THEM T4804000 * T4804500 L RBUF,RIDUBF POINT TO BUFFER. T4805000 LTR RBUF,RBUF DOES IT EXIST... T4805500 BNZ HIR010 IF SO, CONTINUE. T4806000 L R0,HIRCLS NO BUFFER. IS THIS T4806500 NR R0,R2 A CALL FROM CLOSE... T4807000 BNZ HIREND IF SO, RETURN. T4807500 BAL R4,HIRSVC CALL HAMSVC TO GET BUFFERS. T4808000 L RBUF,RIDUBF POINT TO UNPROTECTED BUFFER. T4808500 * T4809000 * IF RECORD WON'T FIT, ISSUE HAMSVC T4809500 * T4810000 HIR010 DS 0H T4810500 STCM R2,8,BFFL1 SAVE ENTRY FLAGS IN BFFL1. T4811000 CL R3,=F'254' IS RECORD TOO LONG... T4811500 BH HIRERR1 IF SO, ERROR. T4812000 LTR R3,R3 IF NOT ZERO-LENGTH, T4812500 BNZ *+16 SKIP. T4813000 LA R2,=C' ' ELSE SET ONE BLANK, T4813500 ICM R2,8,BFFL1 INTRDR FLAGS, T4814000 LA R3,1 AND LENGTH OF ONE. T4814500 LA R5,LRCTEXT-LRCDSECT(,R3) COMPUTE REAL REC LENGTH T4815000 CL R5,BFLEN AND SEE IF IT WILL FIT. T4815500 BNH HIR020 IF IT WILL, GO MOVE IT. T4816000 MVI BFFL1,0 ZERO FLAGS BEFORE USING SVC. T4816500 BAL R4,HIRSVC IF IT WON'T, ISSUE SVC. T4817000 STCM R2,8,BFFL1 RESTORE FLAGS AFTER SVC. T4817500 * T4818000 * MOVE RECORD TO BUFFER T4818500 * T4819000 HIR020 DS 0H T4819500 L R1,BFLOC GET LOCATION IN BUFFER. T4820000 LA R4,BFDAT GET ADDR OF END @OZ29839 T4820100 AL R4,=A(RIDBUFSZ-(BFDAT-BFD)) OF BUFFER. @OZ29839 T4820150 CR R4,R1 COMPARE BFLOC TO END. @OZ29839 T4820200 BNH HERBLKER ABEND1FA,BUFLOC TOO LARGE. @OZ29839 T4820250 CR RBUF,R1 COMPARE BFLOC TO START. @OZ29839 T4820300 BNL HERBLKER ABEND1FA,BFLOC TOO SMALL. @OZ29839 T4820350 STC R3,LRCTLENG SET TEXT LENGTH. T4820500 STC R3,LRCLRECL SET ORIGINAL RECORD LENGTH. T4821000 MVI LRCFLAG1,0 SET FLAGS TO ZERO. T4821500 LA R4,LRCTEXT POINT R4 TO LRCTEXT FOR MVCL. T4822000 LCR R5,R5 COMPLEMENT REAL LENGTH. T4822500 AL R5,BFLEN COMPUTE NEW REMAINING LENGTH T4823000 ST R5,BFLEN AND SAVE FOR NEXT TIME. T4823500 LR R5,R3 SET SINK LENGTH TO SOURCE. T4824000 MVCL R4,R2 MOVE RECORD TO BUFFER. T4824500 ST R4,BFLOC SAVE NEW BUF LOC FOR NEXT TIME. T4825000 EJECT R41 T4825200 * T4825500 * IF /*EOF /*DEL /*PURGE ENDREQ OR CLOSE, ISSUE HAMSVC R41 T4826000 * T4826500 TM BFFL1,RIDEOF+RIDDEL+RIDERQ+RIDCLS IF ALL OFF, T4827000 BZ HIREND RETURN TO CALLER. T4827500 BAL R4,HIRSVC ELSE CALL SVC. T4828000 * T4828500 * NORMAL EXIT T4829000 * T4829500 HIREND DS 0H T4830000 SLR R0,R0 SHOW NORMAL COMPLETION. T4830500 BR R14 RETURN TO CALLER. T4831000 * T4831500 * ERROR EXIT - RECORD TOO LONG T4832000 * T4832500 HIRERR1 L R0,=A(RPLINLEN+65536*RPLLOGER) SET CODE T4833000 BR R14 AND RETURN TO CALLER. T4833500 * T4834000 * SUBROUTINE TO ISSUE HAMSVC FOR INTRDR T4834500 * T4835000 HIRSVC DS 0H T4835500 LA R0,HSVCIRD SET HAMSVC FUNCTION REGISTER T4836000 LCR R1,RACB AND HAMSVC ARGUMENT REGISTER. T4836500 SVC HAMSVC ISSUE HAMSVC. T4837000 LTR R0,R15 IF NORMAL RETURN FROM SVC, T4837500 BZR R4 RETURN TO USER. T4838000 BR R14 ELSE RETURN CODE TO CALLER. T4838500 * T4839000 * CONSTANTS T4839500 * T4840000 HIRCLS DC 0A(0),AL1(RIDCLS),AL3(0) CONSTANT TO TEST CLOSE T4840500 USING SDBDSECT,RSDB RE-ESTABLISH SDB BASE. T4841000 TITLE 'HPMOVE - HAM PUT SUBROUTINE' T4841500 * T4842000 * HAM SUBROUTINE TO MOVE RECORD FROM USER T4842500 * T4843000 CNOP 4,8 T4843500 HPMOVE DS 0H T4844000 TM BFFL1,BF1PSG+BF1PMV TEST FOR RE-ENTRY. T4844500 BO HPM200 BRANCH IF RE-ENTRY FOR SEGMENT. T4845000 BM HPM020 BRANCH IF RE-ENTRY FOR RECORD. T4845500 L R2,RPLAREA POINT R2 TO USER DATA AREA AND T4846000 LA R2,0(,R2) CLEAR HI-ORDER BYTE R4 T4846100 LH R3,RPLRLEN+2 SET R3 TO USER DATA LENGTH. T4846500 LTR R3,R3 TEST USER DATA LENGTH. T4847000 BM HERRECLN ERROR IF NEGATIVE. T4847500 BP *+12 OKAY IF POSITIVE. T4848000 LA R2,=C' ' IF ZERO LENGTH, MAKE T4848500 LA R3,1 THE TEXT ONE BLANK. T4849000 * T4849500 * SHOW INITIAL ENTRY. CHECK SPAN REQUIREMENTS. T4850000 * T4850500 OI BFFL1,BF1PMV SHOW INITIAL ENTRY. T4851000 CL R3,=F'254' DOES RECORD REQUIRE SPANNING... T4851500 BH HPM100 BRANCH IF SO. T4852000 * T4852500 * TRUNCATE TRAILING BLANKS IF REQUIRED. T4853000 * T4853500 TM SDBFLG1,SDB1OUT IF DATA SET NOT MARKED SYSOUT, T4854000 BZ HPM010 NO TRUNCATION REQUIRED. T4854500 LA R1,0(R2,R3) R1 = END OF DATA PLUS 1. T4855000 BCTR R1,0 BACK UP 1 CHARACTER. T4855500 CLI 0(R1),C' ' TEST LAST CHARACTER FOR BLANK. T4856000 BNE HPM010 BR IF NO. T4856500 LA R4,7 SET R4 TO VALUE 7. T4857000 CLR R3,R4 TEST ORIGINAL COUNT. T4857500 BNH HPM004 BR IF LESS THAN 8 CHARACTERS. T4858000 NR R4,R1 R4 = BYTES BEYOND LAST DBL-WORD T4858500 SLR R1,R4 R1 = LAST DBL-WORD WITHIN DATA. T4859000 EX R4,HPMBLTST TEST FOR BLANKS AT END OF LINE. T4859500 BNE HPM010 BR IF NO. T4860000 L R4,=F'-8' 'INCREMENT' FOR FOLLOWING LOOP. T4860500 LR R5,R2 R5 = ADDRESS OF FIRST DATA BYTE T4861000 SPACE 1 T4861500 BXLE R1,R4,HPM006 BACK UP 1 DOUBLE-WORD. T4862000 CLC 0(8,R1),HPMBLNKS TEST FOR DOUBLE-WORD OF BLANKS. T4862500 BE *-10 BR IF SO. T4863000 B HPM008 ELSE BR TO GET LINE LENGTH. T4863500 * T4864000 * CONSTANTS USED BY BLANK TRUNCATION ROUTINE. T4864500 * T4865000 HPMBLTST CLC 0(*-*,R1),HPMBLNKS *** EXECUTE ONLY *** T4865500 HPMBLNKS DC 0D'0',CL8' ' DOUBLE-WORD OF BLANKS T4866000 * T4866500 * TRUNCATE BLANKS FROM 'SHORT' LINE. T4867000 * T4867500 HPM002 BCTR R1,0 BACK UP 1 CHARACTER. T4868000 CLI 0(R1),C' ' TEST FOR BLANK. T4868500 BNE HPM010 BR IF NO. T4869000 HPM004 BCT R3,HPM002 REDUCE COUNT BY 1. T4869500 * T4870000 * SET COUNT FOR ALL-BLANK LINE. T4870500 * T4871000 HPM005 LA R3,1 SET COUNT FOR ALL-BLANK LINE. T4871500 B HPM010 BR TO MOVE LINE. T4872000 * T4872500 * TEST FOR ALL-BLANK LINE. T4873000 * T4873500 CNOP 0,8 T4874000 HPM006 CLC 0(8,R5),HPMBLNKS TEST FOR ALL-BLANK LINE. T4874500 BE HPM005 BR IF SO. T4875000 * T4875500 * COMPUTE LENGTH OF NON-BLANK LINE. T4876000 * T4876500 HPM008 LA R3,8(,R1) LAST KNOWN BLANK CHARACTER. T4877000 SLR R3,R5 REMAINING CHARACTERS IN RECORD. T4877500 * T4878000 * COMPUTE TOTAL LRC LENGTH REQUIRED T4878500 * T4879000 HPM010 LA R4,LRCSOUT-LRCDSECT(,R3) ASSUME CONTROL CHAR. T4879500 L R5,RPLCCHAR IF RPLCCHAR DOES NOT T4880000 LTR R5,R5 POINT TO ZERO, T4880500 BNZ HPM020 TEXT STARTS AT LRCSOUT. T4881000 LA R4,LRCTEXT-LRCDSECT(,R3) TEXT STARTS AT LRCTEXT. T4881500 * T4882000 * SEE IF RECORD WILL FIT (RE-ENTER HERE) T4882500 * T4883000 HPM020 L R1,BFLOC POINT TO FIRST AVAILABLE BYTE. T4883500 TM RPLOPT2,RPLUPD IF PUT-UPDATE, T4884000 BO HPM025 DO NOT CHECK LENGTH. T4884500 C R4,BFLEN IS SPACE LARGE ENOUGH... T4885000 BHR R14 IF NOT, RETURN CC=2. T4885500 * T4886000 * COMPUTE FLAG BYTE AND SET LRCCCTL T4886500 * T4887000 HPM025 DS 0H T4887500 LTR R5,R5 IF NO CARRIAGE CONTROL, T4888000 BZ HPM040 FLAG BYTE IS ZERO. T4888500 MVC LRCCCTL,0(R5) ELSE SET LRCCCTL FROM USER DATA T4889000 LA R5,LRC1CCTL AND FLAG BYTE AS LRC1CCTL. T4889500 TM ACBCCTYP,ACBCCMCH IF ACB SPECIFIES T4890000 BZ HPM030 MACHINE CONTROL CHARACTERS, T4890500 LA R5,LRC1TMCH(,R5) SPECIFY ALSO IN FLAG BYTE. T4891000 TM LRCCCTL,2 TEST FOR 'IMMEDIATE' COMMAND. T4891500 BZ HPM040 BR IF NO. T4892000 SLR R3,R3 ELSE SET DATA LENGTH TO ZERO T4892500 LA R4,LRCSOUT-LRCDSECT AND RESET TOTAL LRC LENGTH. T4893000 B HPM040 THEN BR TO MOVE DATA. T4893500 * T4894000 * TEST FOR ASA CONTROL CHARACTERS. T4894500 * T4895000 HPM030 TM ACBCCTYP,ACBCCASA IF ACB SPECIFIES T4895500 BZ *+8 ASA CONTROL CHARACTERS, T4896000 LA R5,LRC1TASA(,R5) SPECIFY ALSO IN FLAG BYTE. T4896500 * T4897000 * SET LENGTH AND FLAGS, AND MOVE RECORD T4897500 * T4898000 HPM040 STC R3,LRCTLENG SET TEXT LENGTH IN LRC. T4898500 IC R0,RPLRLEN+3 GET ORIGINAL RECORD LENGTH T4899000 STC R0,LRCLRECL AND SAVE IT IN RECORD. T4899500 STC R5,LRCFLAG1 SET FLAGS IN LRC. T4900000 SLR R4,R3 COMPUTE LRC HEADER LENGTH. T4900500 ALR R4,R1 COMPUTE TEXT ADDRESS. T4901000 LR R5,R3 SET LENGTHS EQUAL, T4901500 NI BFFL1,255-BF1PSG-BF1PMV RESET ENTRY FLAGS, AND T4902000 MVCL R4,R2 MOVE USER TEXT INTO LRC. T4902500 TM RPLOPT2,RPLUPD UNLESS THIS IS T4903000 BO *+10 PUT-UPDATE, T4903500 MVC RPLRBAR,BFRBA RETURN RBA TO CALLER. T4904000 LR R1,R4 RETURN NEXT AVAILABLE BYTE AND T4904500 SR R0,R0 CONDITION CODE ZERO T4905000 BR R14 TO CALLER. T4905500 SPACE 3 T4906000 * T4906500 * FIRST-SEGMENT SPANNED-RECORD PROCESSING T4907000 * T4907500 HPM100 DS 0H T4908000 OI BFFL1,BF1PSG SHOW FIRST SEGMENT PROCESSED. T4908500 TM RPLOPT2,RPLUPD IF PUT-UPDATE, T4909000 BO HPM110 DO NOT CHECK LENGTH. T4909500 LA R0,255+LRCSFTXT-LRCDSECT REQUIRE REASONABLE MINIMUM R4 T4910000 CL R0,BFLEN FOR FIRST SEGMENT. T4910500 BL HPM110 BRANCH IF MIN AVAILABLE. T4911000 NI BFFL1,255-BF1PSG-BF1PMV ELSE RESET FLAGS, T4911500 L R1,BFLOC SET BFLOC IN R1 FOR CALLER, T4912000 SLR R0,R0 SET CC = 2, T4912500 BR R14 AND RETURN TO CALLER. T4913000 * T4913500 * CREATE FIRST SEGMENT T4914000 * T4914500 HPM110 DS 0H T4915000 L R1,BFLOC POINT TO FIRST AVAIL LRC BYTE. T4915500 MVI LRCTLENG,0 SET ZERO NON-SPAN LENGTH. T4916000 L R5,BFLEN GET LENGTH AVAILABLE. T4916500 SL R5,=A(LRCSFTXT-LRCDSECT) DECR BY 1ST-SEG HDR LENG. T4917000 MVI LRCFLAG1,LRC1SPAN+LRC1SBGN SET FLAGS. T4917500 STH R3,LRCSRECL SET TOTAL RECORD LENGTH IN LRC. T4918000 LA R4,LRCSFTXT POINT TO FIRST-SEG TEXT START. T4918500 TM RPLOPT2,RPLUPD IS THIS PUT OR PUT UPDATE @OZ16677 T4918550 BNO HPM113 BRANCH IF PUT @OZ16677 T4918600 LH R5,LRCSEGL LOAD SEGMENT LENGTH @OZ16677 T4918650 CLR R3,R5 IS THIS THE ONLY SEGMENT @OZ16677 T4918700 BE HPM120 BRANCH IF YES @OZ16677 T4918750 B HPM117 MOVE FIRST SEGMENT @OZ16677 T4918800 HPM113 DS 0H @OZ16677 T4918850 CLR R3,R5 WILL WHOLE REC FIT IN SPACE... T4919000 BNH HPM120 BRANCH IF SO. T4919500 STH R5,LRCSEGL NO. SET FIRST SEGMENT LENGTH. T4920000 HPM117 DS 0H @OZ16677 T4920300 MVCL R4,R2 MOVE FIRST SEGMENT TO LRC. T4920500 TM RPLOPT2,RPLUPD UNLESS THIS IS T4921000 BO *+10 PUT-UPDATE, T4921500 MVC RPLRBAR,BFRBA RETURN RBA TO CALLER. T4922000 LR R1,R4 RETURN NEXT BYTE ADR IN R1. T4922500 SLR R0,R0 SET CC = 2 T4923000 BR R14 AND RETURN TO CALLER. T4923500 * T4924000 * CREATE FIRST AND ONLY SEGMENT T4924500 * T4925000 HPM120 DS 0H T4925500 MVI LRCFLAG1,LRC1SPAN+LRC1SBGN+LRC1SMID+LRC1SEND FLAG T4926000 NI BFFL1,255-BF1PSG-BF1PMV RESET ENTRY FLAGS. T4926500 STH R3,LRCSEGL SET SEGMENT LENGTH. T4927000 LR R5,R3 SET SINK LENGTH TO SOURCE LENG. T4927500 MVCL R4,R2 MOVE ENTIRE RECORD TO LRC. T4928000 TM RPLOPT2,RPLUPD TEST FOR PUT UPDATE R4 T4928100 BO SKIP410 BR IF YES R4 T4928200 MVC RPLRBAR,BFRBA RETURN RBA TO CALLER R4 T4928300 SKIP410 LR R1,R4 RETURN NEXT BYTE ADDRESS IN R1 R4 T4928500 SR R0,R0 SET CC = 0 R4 T4928700 BR R14 RETURN TO CALLER R4 T4929000 SPACE 3 T4929500 * T4930000 * CREATE SUBSEQUENT SEGMENT (RE-ENTER HERE) T4930500 * T4931000 HPM200 DS 0H T4931500 L R1,BFLOC POINT TO FIRST BYTE AVAILABLE. T4932000 MVI LRCTLENG,0 SET ZERO NON-SPAN LENGTH. T4932500 LH R5,LRCSEGL LOAD R5 FOR PUT-UPDATE @OZ16677 T4932600 TM RPLOPT2,RPLUPD IS THIS PUT, OR PUTUPDATE @OZ16677 T4932700 BO HPM205 BRANCH IF UPDATING @OZ16677 T4932800 L R5,BFLEN GET AVAIL LENG AND DECREMENT T4933000 SL R5,=A(LRCSTEXT-LRCDSECT) BY NOT-1ST-SEG HDR LENG. T4933500 HPM205 DS 0H @OZ16677 T4933800 LA R4,LRCSTEXT POINT TO NOT-1ST-SEG TEXT. T4934000 MVI LRCFLAG1,LRC1SPAN+LRC1SMID SET MIDDLE SEG FLAGS. T4934500 CLR R3,R5 WILL REST OF RECORD FIT... T4935000 BNH HPM210 IF SO, BRANCH TO LAST SEG. T4935500 STH R5,LRCSEGL SET MIDDLE SEGMENT LENGTH. T4936000 MVCL R4,R2 MOVE TEXT TO MIDDLE SEGMENT. T4936500 LR R1,R4 RETURN NEXT BYTE ADR IN R1. T4937000 SLR R0,R0 SET CC = 2 T4937500 BR R14 AND RETURN TO CALLER. T4938000 * T4938500 * CREATE LAST SEGMENT T4939000 * T4939500 HPM210 DS 0H T4940000 STH R3,LRCSEGL SHOW REMAINING LENG THIS SEG. T4940500 LR R5,R3 SET SINK LENGTH TO SOURCE LENG. T4941000 XI LRCFLAG1,LRC1SMID+LRC1SEND SHOW END SEGMENT. T4941500 NI BFFL1,255-BF1PSG-BF1PMV RESET ENTRY FLAGS. T4942000 MVCL R4,R2 MOVE TEXT TO LAST SEGMENT. T4942500 LR R1,R4 RETURN TO CALLER WITH R1 = NEXT T4943000 BR R14 BYTE AND CC=0 (FROM MVCL). T4943500 TITLE 'HAM ''POINT'' ACCESS METHOD' T4944000 * T4944500 * T4945000 * HASP 'POINT' ACCESS METHOD T4945500 * T4946000 * T4946500 HAMPOINT DS 0H T4947000 * T4947500 * SEE IF UNPROTECTED BUFFER ALREADY CONTAINS RECORD T4948000 * T4948500 HT00 DS 0H T4949000 L R1,RPLARG POINT TO RBA TO POINT TO. T4949500 MVC BFRBA,0(R1) MOVE ARG RBA TO BFRBA. T4950000 LA R0,1 GET CONSTANT 1. T4950500 CLM R0,7,BFRBA+5 IF LOGICAL RECORD NUMBER T4951000 BNH *+8 IS ZERO, T4951500 STCM R0,7,BFRBA+5 MAKE IT ONE. T4952000 CLC BFRBA+1(4),=XL4'0' IF MTTR PORTION NOT ZERO, T4952500 BNE HT10 CONTINUE. T4953000 MVC BFRBA+1(4),SDBTRKF+1 ELSE SET TO START OF DS. T4953500 HT10 DS 0H T4954000 * T4954500 * USE HAMSVC TO READ IN THE CORRECT BLOCK T4955000 * T4955500 LA R0,HSVCPNT SET HAMSVC FUNCTION REGISTER. T4956000 LR R1,RRPL SET HAMSVC ARGUMENT REGISTER. T4956500 SVC HAMSVC ISSUE HAMSVC. T4957000 LTR R0,R15 TRANSFER RETURN CODE TO R0 T4957500 BNZR R15 ERROR EXIT IF POINT FAILED. T4958000 B HRPLEXIT AND EXIT. T4958500 TITLE 'HAM ''ENDREQ'' ACCESS METHOD' T4959000 * T4959500 * T4960000 * HASP 'ENDREQ' ACCESS METHOD T4960500 * T4961000 * T4961500 HAMENDRE DS 0H T4962000 LR R1,RRPL SET RPL REGISTER. T4962500 LA R0,HSVCENDR SET FUNCTION REGISTER. T4963000 SVC HAMSVC ISSUE SVC FOR ENDREQ. T4963500 LTR R0,R15 IF R15 CONTAINS A POINTER, T4964000 BNZR R15 ERROR - TAKE EXIT. T4964500 SPACE 1 @OZ44947 T4965000 L R1,SDBSJB TEST FOR SYSMSG DATASET @OZ44947 T4965100 LA RSDB,SJBMACB-SJBDSECT(,R1) BY COMPARING @OZ44947 T4965200 CLM RSDB,7,RPLDACB+1 ACB ADDRESS @OZ44947 T4965300 BNE HRPLEXIT BR IF NOT SYSMSG DS @OZ44947 T4965400 SPACE 1 @OZ44947 T4965500 LA R1,SJBLRPL-SJBDSECT(,R1) PT. TO RPL FOR JL DS @OZ44947 T4965600 LA R0,RPLENDRE RESET FUNCTION REGISTER @OZ44947 T4965700 B HAMREDO AND ISSUE ENDREQ FOR IT @OZ44947 T4965800 TITLE 'HAM -- RPL RETURN PROCESSING' @OZ44947 T4965900 * T4966000 * T4966500 * RPL ERROR RETURNS -- LOGICAL T4967000 * T4967500 * T4968000 SPACE 1 T4968500 HERNOEOD LA R0,RPLEODER END-OF-DATA OCCURRED. T4969000 B HERLOGER T4969500 HERSPACE LA R0,RPLNOEXT NO SPOOL SPACE IS LEFT. T4970000 B HERLOGER T4970500 HERINRBA LA R0,RPLINRBA BAD RBA - POINT, GET-UPD. T4971000 B HERLOGER T4971500 HERSTOR LA R0,RPLNOVRT GETMAIN FAILED. T4972000 B HERLOGER T4972500 HERINBUF LA R0,RPLINBUF NO ROOM IN USER BUF - GET. T4973000 B HERLOGER T4973500 HERINVP LA R0,RPLINACC E.G., GET ON OUTPUT DATA SET. T4974000 B HERLOGER T4974500 HERINUPD LA R0,RPLINUPD PUT-UPD BEFORE GET-UPD. T4975000 B HERLOGER T4975500 HERDLCER LA R0,RPLDLCER PUT-UPD WOULD CHANGE LENGTH. T4976000 B HERLOGER T4976500 HERRECLN LA R0,RPLINLEN E.G., SYSOUT LENGTH GREATER THAN 254 T4977000 B HERLOGER T4977500 SPACE 1 T4978000 HERLOGER AL R0,=A(RPLLOGER*65536) SET LOGICAL ERROR. T4978500 B HRPLEXIT START RETURNING TO USER. T4979000 SPACE 3 T4979500 * T4980000 * T4980500 * RPL ERROR RETURNS -- PHYSICAL T4981000 * T4981500 * T4982000 SPACE 1 T4982500 HERRDERD LA R0,RPLRDERD PHYS RD ERR OR KEY MISMATCH. T4983000 B HERPHYER T4983500 HERWTERD LA R0,RPLWTERD PHYSICAL WRITE ERROR. T4984000 SPACE 1 T4984500 HERPHYER AL R0,=A(RPLPHYER*65536) SET PHYSICAL ERROR. T4985000 B HRPLEXIT START RETURNING TO USER. T4985500 SPACE 3 T4986000 * T4986500 * T4987000 * RPL ERROR RETURNS -- CONTROL BLOCK T4987500 * T4988000 * T4988500 HERBLKER ABEND X'1FA',DUMP,,SYSTEM CONTROL BLOCK ERROR. T4989000 SPACE 3 T4989500 * T4990000 * RPL NORMAL RETURN - NO ERROR T4990500 * T4991000 HERNORML SLR R0,R0 SHOW NO ERROR AT ALL. T4991500 EJECT T4992000 * T4992500 * HRPLEXIT - RETURN CODE (IN R0) TO CALLER T4993000 * T4993500 HRPLEXIT DS 0H T4994000 STCM R0,7,RPLFDBK SET COMPLETION CODE IN RPL. T4994500 MVI RPLCMPON,2 SET COMPONENT ID. T4995000 SRL R0,16 RIGHT-JUSTIFY RPLRTNCD & T4995500 ST R0,16(,R13) SET IT IN R15 SLOT. T4996000 * POST CALLER'S ECB T4996500 LA R1,RPLECB ASSUME INTERNAL ECB. T4997000 TM RPLOPT1,RPLECBSW IF INTERNAL ECB, T4997500 BZ *+8 SKIP. T4998000 L R1,RPLECB POINT TO EXTERNAL ECB. T4998500 MVI 0(R1),X'40' POST THE ECB. T4999000 LTR R0,R0 IF NO ERROR INDICATED, T4999500 BZ HEX200 GO RETURN TO CALLER. T5000000 * T5000500 * ERROR INDICATED - SEE IF USER EXIT APPLIES T5001000 * T5001500 L R4,ACBEXLST POINT TO ACB'S EXIT LIST. T5002000 CL R4,=F'1' IF POINTER IS 0 OR 1, T5002500 BNH HEX200 THERE'S NO EXIT LIST. T5003000 USING IFGEXLST,R4 SET EXLST ADDRESSABILITY. T5003500 CLI EXLID,EXLIDD IS IDENTIFIER OKAY... T5004000 BNE HEX200 IF NOT, IGNORE EXIT LIST. T5004500 * ASSUME END-OF-FILE EXIT T5005000 LA R2,EXLEODF POINT TO EOD ENTRY. T5005500 LA R3,EXLEODL GET MIN LENGTH FOR IT. T5006000 CLI RPLRTNCD,RPLLOGER IF NOT LOGICAL ERROR, T5006500 BNE HEX020 IT MUST BE PHYSICAL ERROR. T5007000 CLI RPLERRCD,RPLEODER LOGICAL. IF EOD, T5007500 BE HEX100 GO TAKE USER EXIT. T5008000 * ASSUME OTHER LOGICAL ERROR THAN END-OF-FILE T5008500 LA R2,EXLLERF POINT TO LOGICAL ERROR ENTRY. T5009000 LA R3,EXLLERL GET MIN LENGTH FOR IT. T5009500 B HEX100 GO TAKE USER EXIT. T5010000 * ASSUME PHYSICAL ERROR T5010500 HEX020 DS 0H T5011000 LA R2,EXLSYNF POINT TO PHYSICAL ERROR ENTRY. T5011500 LA R3,EXLSYNL GET MIN LENGTH FOR IT. T5012000 * T5012500 * IF THE APPROPRIATE EXIT ROUTINE EXISTS, ENTER IT T5013000 * T5013500 HEX100 DS 0H T5014000 CH R3,EXLLEN IS EXIT LIST LONG ENOUGH... T5014500 BH HEX200 IF NOT, NO USER EXIT. T5015000 USING IFGEXLEF,R2 SET ENTRY ADDRESSABILITY. T5015500 TM EXLFLAG,EXLPRES+EXLACTV IF ENTRY NOT PRESENT & T5016000 BNO HEX200 ACTIVE, NO USER EXIT. T5016500 $ALGN L,R0,EXLEXITP GET ENTRY'S ADDRESS. T5017000 TM EXLFLAG,EXLLINK IF IT POINTS TO EXIT CODE, T5017500 BZ HEX150 GO TAKE USER EXIT. T5018000 LOAD EPLOC=(0) ELSE LOAD USER EXIT ROUTINE. T5018500 $ALGN ST,R0,EXLEXITP SAVE ADDRESS IN EXLST ENTRY. T5019000 NI EXLFLAG,255-EXLLINK SHOW ENTRY POINTS TO CODE. T5019500 HEX150 DS 0H T5020000 LM R1,R12,24(R13) RESTORE R1 THROUGH R12. T5020500 LR R15,R0 SET R15 = USER EXIT ENTRY PT. T5021000 BALR R14,R15 TAKE USER EXIT. T5021500 HEX200 DS 0H IF USER EXIT RETURNS, T5022000 LM R14,R12,12(R13) RESTORE ALL REGISTERS T5022500 BR R14 AND RETURN TO CALLER. T5023000 SPACE 3 T5023500 DROP , DROP ALL ADDRESSABILITY. T5024000 TITLE 'HAM SUBROUTINE TO FIND RBA IN UBF' T5024500 * T5025000 * T5025500 * HAM SUBROUTINE TO FIND RBA IN UBF T5026000 * T5026500 * T5027000 HFINDRBA DS 0H T5027500 USING SDBDSECT,RSDB T5028000 USING BFD,RBUF T5028500 USING LRCDSECT,R1 T5029000 USING *,R15 SET LOCAL ADDRESSABILITY. T5029500 SR R0,R0 ZERO OUT LRC LENGTH REGISTER. T5030000 SLDL R2,8 R2 = MTTR T5030500 SRL R3,8 R3 = LOGICAL RECORD NR. T5031000 $ALGN S,R2,BFRBA+1 IS THE MTTR CORRECT... T5031500 BNZR R14 IF NOT, RETURN NONZERO CC & R2. T5032000 LA R1,BFDAT POINT TO FIRST LOGICAL RECORD. T5032500 HFR010 DS 0H T5033000 ALR R1,R0 POINT TO NEXT LOGICAL RECORD. T5033500 TM LRCTLENG,LRCBFEND IF IT'S END-OF-BUFFER, T5034000 BOR R14 RETURN NONZERO CC. T5034500 SPACE 1 T5035000 SR R5,R5 ZERO R5 FOR IC. T5035500 IC R5,LRCTLENG GET TEXT LENGTH IN R5. T5036000 TM LRCFLAG1,LRC1CCTL+LRC1SPAN IS IT NOT SYSOUT NOR SPAN... T5036500 LA R4,LRCTEXT SET NORMAL TEXT START T5037000 LA R0,LRCTEXT-LRCDSECT(,R5) AND OFFSET TO NEXT LR. T5037500 BZ HFR020 BRANCH IF NORMAL RECORD. T5038000 TM LRCFLAG1,LRC1CCTL IS IT SYSOUT... T5038500 LA R4,LRCSOUT SET SYSOUT TEXT START T5039000 LA R0,LRCSOUT-LRCDSECT(,R5) AND OFFSET TO NEXT LR. T5039500 BO HFR020 BRANCH IF SYSOUT RECORD. T5040000 LA R4,LRCSFTXT GET SPANNED-RECORD START T5040500 LH R5,LRCSEGL AND LENGTH T5041000 LA R0,LRCSFTXT-LRCDSECT(,R5) AND OFFSET TO NEXT LR. T5041500 TM LRCFLAG1,LRC1SBGN IF FIRST SEGMENT, T5042000 BO HFR020 COUNT RECORD & CONTINUE. T5042500 LA R0,LRCSTEXT-LRCDSECT(,R5) IF NOT FIRST SEGMENT, T5043000 B HFR010 DO NOT COUNT RECORD. T5043500 HFR020 BCT R3,HFR010 COUNT A RECORD. T5044000 SR R0,R0 REQUESTED RECORD IS FOUND. T5044500 BR R14 RETURN ZERO CC. T5045000 DROP , DROP ALL BASES. T5045500 TITLE 'HAM LITERAL POOL' T5046000 LTORG T5046500 TITLE 'HAMSVC --- ENTERED FROM SVC 111' T5047000 * T5047500 * T5048000 * HASP ACCESS METHOD SUPERVISOR CALL T5048500 * T5049000 * T5049500 SVCHAM DS 0H T5050000 BALR R12,0 ESTABLISH T5050500 SVCHBASE DS 0H LOCAL ADDRESSABILITY. T5051000 USING *,R12 T5051500 USING DEBBASIC,R2 USE THE DEB DSECT. T5052000 LR RRPL,R1 SET RPL BASE REGISTER. T5052500 USING IFGRPL,RRPL USE RPL ADDRESSABILITY. T5053000 L RSDB,DEBIRBAD POINT TO THE SDB. T5053500 LTR R3,R1 IF R1 IS ACB COMPLEMENT, T5054000 BM *+8 SKIP ACB POINTER LOAD. T5054500 L R3,RPLDACB POINT TO ACB FROM RPL. T5055000 LPR R3,R3 MAKE ACB POINTER POSITIVE. T5055500 USING IFGACB,R3 SET ACB ADDRESSABILITY. T5056000 TM ACBINRTN,ACBINR IS ACB FOR INTERNAL READER... T5056500 BZ SVCH10 IF NOT, PROCESS SDB. T5057000 DROP R3 DROP ACB ADDRESSABILITY. T5057500 * T5058000 * INTERNAL READER INITIALIZATION T5058500 * T5059000 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY @OZ41431 T5059500 CLC SDBID,=CL4'SDB ' IS THIS BLOCK A SDB ? @OZ41431 T5059600 BE SVCERRET YES, SET ERROR RETURN @OZ41431 T5059700 USING DCTDSECT,RSDB SET DCT ADDRESSABILITY @OZ41431 T5059800 L RSVT,RIDSSVT POINT TO SUBSYS VECTOR TABLE. T5060000 B SVCIRD GO PROCESS INTRDR REQUEST. T5060500 * T5061000 * NORMAL SUBSYSTEM DATA SET INITIALIZATION T5061500 * T5062000 SVCH10 DS 0H T5062500 USING SDBDSECT,RSDB SET SDB ADDRESSABILITY. T5063000 CLC SDBID,=CL4'SDB ' IS THIS BLOCK A SDB ? @OZ41431 T5063100 BNE SVCERRET NO, SET ERROR RETURN. @OZ41431 T5063200 L RSVT,SDBSVT POINT TO SUBSYS VECTOR TABLE. T5063500 USING $SVDSECT,RSVT USE THE SSVT DSECT. T5064000 L RSJB,SDBSJB POINT TO THE SJB AND T5064100 USING SJBDSECT,RSJB SET ADDRESSABILITY. T5064200 TM SJBFLG1,SJB1XBWT IF NOT XBM-WITHOUT-JOB, T5064300 BZ SVCH20 CONTINUE. T5064400 L RBUF,SDBUBF FOR XBM WITHOUT JOB, T5064500 LTR RBUF,RBUF FIRST VERIFY THAT T5064600 BZ SVCNORML UNPROTECTED BUFFER EXISTS. T5064700 USING BFD,RBUF THEN T5064800 LA R0,BFDAT RE-INITIALIZE T5064900 ST R0,BFLOC BFDAT T5065000 LH R0,$SVBFSIZ AND R4 T5065100 SL R0,=A(BFDAT+1-BFIO) ALSO R4 T5065200 ST R0,BFLEN BFLEN T5065300 B SVCNORML AND RETURN NORMALLY. T5065400 DROP RSJB,RBUF DROP SJB,BUF BASES. T5065500 SVCH20 CL R0,=A(SVCHEND-SVCH30) TEST R0 R4 T5065600 BNL SVCERRET BR IF ILLEGAL TO ERROR RETURN R4 T5065700 LR R15,R0 RELOAD R0 R4 T5065800 N R0,=A(X'FF000003') IF R0 POSITIVE MULTIPLE OF 4, R4 T5065900 BZ SVCH30(R15) BR TO PROCESS REQUEST R4 T5066000 B SVCERRET ELSE BR TO ERROR RETURN R4 T5066100 SVCH30 DS 0H START OF BRANCH TABLE R4 T5066200 B SVCGET EOB FOR GET T5066300 B SVCPUT EOB FOR PUT T5066400 B SVCIRD INTERNAL READER PROCESSING T5066500 B SVCPNT POINT PROCESSING T5067000 NOP 0 HSVCENDI (16) OBSOLETE T5067500 B SVCENDR ENDREQ PROCESSING T5068000 B SVCUSO OUTPUT LIMIT PROCESSING T5068500 NOP 0 HSVCCLSI (28) OBSOLETE T5069000 B SVCGUP GET-UPDATE PROCESSING T5069500 B SVCPUP PUT-UPDATE PROCESSING T5070000 B SVCXBM EXECUTION BATCH MONITOR T5070500 SVCHEND DS 0H END OF BRANCH TABLE R4 T5070600 DROP R2 T5071000 EJECT T5071500 * T5072000 * T5072500 * HAMSVC - END-OF-BLOCK PROCESSING FOR GET T5073000 * T5073500 * T5074000 SVCGET DS 0H T5074500 L RBUF,SDBUBF POINT TO UNPROTECTED BUFFER. T5075000 USING BFD,RBUF USE BUFFER DSECT. T5075500 TM SDBFLG1,SDB1BFXS IF PBF IS NOT REFILLED R4 T5075600 BZ SVCGET10 BECAUSE OF A PURGE-QUIESCE R4 T5075700 NI SDBFLG1,255-SDB1BFXS DETECTED AT HCRETURN, R4 T5075800 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T5075900 EXCP SDBIOB ISSUE EXCP TO REFILL PBF R4 T5076000 WAIT 1,ECB=SDBECB WAIT FOR I/O TO COMPLETE R4 T5076100 B SVCNORML RETURN WITH UBF REFILLED R4 T5076200 SVCGET10 CALL HENDREAD YES. INSPECT COMPLETION. T5076300 TM SDBFLG2,SDB2IOE DID I/O ERROR OCCUR... T5076500 BO SVCNORML IF SO, RETURN. T5077000 CALL HMOVEPU ELSE MOVE PROT TO UNPROT BUF ETC. T5077500 TM SDBFLG2,SDB2EOD IS THIS THE LAST OF INPUT... T5078000 BO SVCNORML IF SO, RETURN. T5078500 CALL HCNVFDAD ELSE SET NEW FDAD IN IOB, T5079000 TM SDBFLG2,SDB2IOA IF I/O NOT ACTIVE @OZ30886 T5079080 BZ SVCGET20 CONTINUE @OZ30886 T5079160 WAIT 1,ECB=SDBECB ELSE, WAIT @OZ30886 T5079240 SVCGET20 SLR R0,R0 ZERO R0 @OZ30886 T5079320 ST R0,SDBECB STORE ZERO IN ECB @OZ30886 T5079400 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T5079500 LA R0,1 INCREMENT T5080000 A R0,SDBXCPCT EXCP T5080500 ST R0,SDBXCPCT COUNTER, T5081000 EXCP SDBIOB AND START UP I/O. T5081500 B SVCNORML THEN RETURN NORMALLY. T5082000 EJECT T5082500 * T5083000 * T5083500 * HAMSVC - UPDATE PROCESSING FOR GET T5084000 * T5084500 * T5085000 SVCGUP DS 0H T5085500 * T5086000 * QUIESCE I/O T5086500 * T5087000 LR R8,RRPL SAVE RPL ADDRESS. T5087500 WAIT 1,ECB=SDBECB WAIT FOR I/O TO COMPLETE. T5088000 * T5088500 * FREE BUFFERS ON THE I/O COMPLETE CHAIN T5089000 * T5089500 BAL R5,HSPFBFRE GO FREE ALL BUT ONE FBF. T5090000 LTR R1,R1 IS THERE A BUFFER LEFT... T5090500 BNZ SGU020 BRANCH IF SO. T5091000 * T5091500 * GET FIRST PROTECTED BUFFER FOR GET-UPDATE T5092000 * T5092500 $GETBUF TYPE=PROT GET A PROTECTED BUFFER. T5093000 BNZ SGUSTOR BRANCH IF NO STORAGE. T5093500 LA R0,1 ELSE INCREMENT T5094000 AH R0,SDBPBFCT PROTECTED-BUFFER T5094500 STH R0,SDBPBFCT COUNT. T5095000 * T5095500 * INITIALIZE THE PROTECTED BUFFER T5096000 * T5096500 SGU020 LR RBUF,R1 SET BUFFER BASE REGISTER. T5097000 MVI BFID,C'G' SET ID TO 'GBF'. T5097500 SLR R0,R0 ZERO T5098000 ST R0,BFBF NEXT-BUFFER POINTER. T5098500 ST RBUF,SDBGBF POINT TO BUFFER FROM SDBGBF. T5099000 * T5099500 * FREE ALL HOLD BUFFERS BUT ONE T5100000 * T5100500 L RBUF,SDBHBF POINT TO FIRST HBF. T5101000 SGU030 LTR R1,RBUF DOES IT EXIST... T5101500 BZ SGU040 BRANCH IF NOT. T5102000 L RBUF,BFBF GET POINTER TO NEXT HBF. T5102500 LTR RBUF,RBUF IF R1 POINTS TO LAST HBF, T5103000 BZ SGU050 BRANCH. T5103500 $FREMAIN BU,A=(R1),LV=4096,SP=229,KEY=1 ELSE FREE THIS HBF R4 T5104000 B SGU030 AND EXAMINE NEXT HBF. T5104500 * T5105000 * GET A HOLD BUFFER IF REQUIRED T5105500 * T5106000 SGU040 $GETMAIN BC,LV=4096,SP=229,KEY=1 GET KEY-1 BUFFER. R4 T5106500 BNZ SGUSTOR BRANCH IF NO STORAGE. T5107000 SGU050 LR RBUF,R1 SET BUFFER ADDRESSABILITY. T5107500 MVI BFID,C'H' SET ID TO 'HBF'. T5108000 SLR R0,R0 ZERO T5108500 ST R0,BFBF NEXT-BUFFER POINTER. T5109000 ST RBUF,SDBHBF SAVE HOLD BUFFER ADDRESS. T5109500 * T5110000 * CONVERT ARGUMENT ADDRESS TO ABSOLUTE T5110500 * T5111000 LR RRPL,R8 RESTORE RPL ADDRESS. T5111500 L R1,RPLARG POINT TO UPDATE ARGUMENT RBA. T5112000 MVC SDBUPRBA,0(R1) SAVE IT IN SDB FOR HCEGUP. T5112500 L R5,SDBMTTR SAVE SDBMTTR IN R5. T5113000 MVC SDBMTTR,1(R1) SET SDBMTTR FROM RBA. T5113500 CALL HCNVFDAD CONVERT TO FDAD FORMAT. T5114000 * T5114500 * SET UP FOR EXCP, ISSUE IT, AND WAIT T5115000 * T5115500 L R4,SDBCCW4 SAVE SDBCCW4. T5116000 IC R3,SDBCHEND SAVE VALUE OF SDBCHEND. T5116500 L RBUF,SDBGBF POINT TO UPDATE PROTECTED BUF. T5117000 MVC BFRBA,SDBUPRBA SET CURRENT RBA IN BUFFER. T5117500 MVC BFECB,SDBHBF POINT IT TO UPDATE UNPROT BUF. T5118000 MVC BFTRK,SDBMTTR SET UPDATE MTTR IN IT. T5118500 LA R1,BFIO POINT TO I/O AREA IN BUF T5119000 ST R1,SDBCCW4 AND SET READ-DATA CCW. T5119500 MVI SDBCCW4,6 SET READ-DATA COMMAND. T5120000 MVI SDBCHEND,SDBCEGUP ASK FOR HCEGUP. T5120500 SLR R0,R0 ZERO OUT T5121000 ST R0,SDBSAVE CHANNEL-END ERROR WORD. T5121500 EXCP SDBIOB START THE READ. T5122000 WAIT 1,ECB=SDBECB WAIT TILL HCEGUP IS DONE. T5122500 * T5123000 * RESTORE SDB TO STATUS QUO ANTE BELLUM T5123500 * T5124000 STC R3,SDBCHEND RESTORE SDBCHEND VALUE. T5124500 ST R4,SDBCCW4 RESTORE SDBCCW4. T5125000 ST R5,SDBMTTR RESTORE SDBMTTR. T5125500 * T5126000 * RETURN FROM HAMSVC T5126500 L R15,SDBSAVE GET CHAN-END ERROR WORD. T5127000 B SVCEXIT RETURN IT TO HG100. T5127500 * STORAGE UNAVAILABLE FOR BUFFERS T5128000 SGUSTOR B SVCSTOR RETURN ADR OF HERSTOR. T5128500 EJECT T5129000 * T5129500 * T5130000 * HAMSVC - EXECUTION BATCH MONITOR END-OF-JOB T5130500 * T5131000 * T5131500 SVCXBM DS 0H T5132000 * T5132500 * T5133000 * VALIDIFY XBM END-JOB REQUEST T5133500 * T5134000 * T5134500 L RSJB,SDBSJB POINT TO SJB FOR THIS JOB. T5135000 USING SJBDSECT,RSJB SET SJB ADDRESSABILITY. T5135500 CLM RSDB,7,SJBXBSDB+1 IS THIS THE BATCH-INPUT UNIT... T5136000 BNE SX800 ERROR IF NOT. T5136500 * T5137000 * T5137500 * LOCK THE SJB. ERROR IF ALREADY LOCKED. T5138000 * T5138500 * T5139000 SLR R0,R0 ZERO R0 AND R1 TO COMPARE WITH T5139500 LR R1,R0 CURRENT CONTENTS OF SJBLOCKH. T5140000 L R2,PSATOLD-PSA POINT R2 TO CURRENT TCB. T5140500 LNR R3,R2 SET R3 TO ARBITRARY NEG VALUE. T5141000 CDS R0,R2,SJBLOCKH IF SJB IS UNLOCKED, TAKE LOCK. T5141500 BNE SX800 IF SJB IS LOCKED, ERROR. T5142000 OI SJBFLG1,SJB1XBMC SHOW XBM CONTINUATION R41 T5142100 O R12,=X'80000000' SHOW SJB LOCK OBTAINED. T5142500 * T5143000 * T5143500 * TERMINATE THE CURRENT JOB T5144000 * T5144500 * T5145000 SL R12,=A(SVCHBASE-HJEBASE) SET JOB TERM ADDRESSAB. T5146000 USING HJEBASE,R12 TELL THE ASSEMBLER. T5146500 B HJEXBM USE JOB TERMINATE. T5147000 USING SVCHBASE,R12 RESTORE SVC ADDRESSABILITY. T5147500 * T5148000 * T5148500 * RETURN TO HERE FROM JOB TERMINATE/SELECT T5149000 * T5149500 * T5150000 SX100 DS 0H T5150500 * T5151000 * T5151500 * UNLOCK THE SJB. ERROR IF ANY WAITERS. T5152000 * T5152500 * T5153000 SLR R0,R0 ZERO R0 AND R1 TO SET INTO T5153500 LR R1,R0 SJBLOCKH. T5154000 L R2,PSATOLD-PSA POINT R2 AND R3 TO WHAT SHOULD T5154500 LNR R3,R2 BE IN SJBLOCKH. T5155000 CDS R2,R0,SJBLOCKH IF OKAY, UNLOCK THE SJB. T5155500 BNE SX800 IF SJB IS NOT OKAY, ERROR. T5156000 * T5156500 * T5157000 * SET REGISTER 15 ACCORDING TO FLAG SJB1XBWT T5157500 * AND RETURN TO HAMGET. T5158000 * T5158500 * T5159000 NI SJBFLG1,255-SJB1XBMC SHOW NEW JOB SELECTED. T5159500 SLR R15,R15 ASSUME JOB SELECTED. T5160000 TM SJBFLG1,SJB1XBWT IF JOB SELECTED, T5160500 BZ SVCNORML RETURN FROM SVC. T5161000 L R4,SJBCSCB ESTABLISH ADDRESSABILITY @OZ35973 T5161050 USING CSCDSECT,R4 TO COMMAND SCHED CB @OZ35973 T5161100 MODESET EXTKEY=ZERO,SAVEKEY=(2) GET KEY ZERO @OZ35973 T5161150 OI CHACT,CHCLD TELL OS TO CANCEL JOB @OZ35973 T5161200 LA R1,CHCECB POINT TO CANCEL ECB @OZ35973 T5161250 POST (1),X'222' CANCEL WITHOUT DUMP @OZ35973 T5161300 MODESET KEYADDR=(2) RETURN TO CALLERS KEY @OZ35973 T5161350 DROP R4 @OZ35973 T5161400 B SVCERRET ELSE CAUSE HAMGET TO EXIT. T5161500 * T5162000 * T5162500 * ABEND IF PROCESSING ERROR T5163000 * T5163500 * T5164000 SX800 DS 0H T5164500 ABEND X'56F',DUMP,STEP,SYSTEM KILL THE BATCH MONITOR. T5165000 EJECT T5165500 * T5166000 * HAMSVC - END-OF-BLOCK PROCESSING FOR PUT T5166500 * T5167000 * T5167500 SVCPUT DS 0H T5168000 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168010 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168020 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168030 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168040 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168050 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168060 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168070 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168080 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168090 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5168095 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168100 PRINT OFF @OZ43719 T5168200 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168300 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168400 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168600 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168700 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168800 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5168900 PRINT ON @OZ43719 T5169000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5169100 * T5169200 * GET A TRACK FOR NEXT BUFFER IF NECESSARY T5169300 * T5169500 SLR R1,R1 ZERO R1 FOR CASE OF CLOSE. T5170000 TM SDBFLG1,SDB1CLOS IS DATA SET BEING CLOSED... T5170500 BO SVCP10 BRANCH IF SO. T5171000 LA R13,SDBSAVE PROVIDE SAVE AREA FOR $TRACK. T5171500 LA R1,SDBTAB A(MAJOR/MINOR TAB) R4 T5174100 CALL $STRAK GET A CHAINING TRACK. T5175000 SVCP10 LR R8,R1 SAVE TRACK ADDRESS OR 0 IN R8. T5179500 ST R3,SDBSAVE+32 SAVE ACB ADDRESS @OZ43719 T5179600 * T5180000 * IF ANY PBFS EXIST FOR WHICH I/O IS COMPLETE, T5180500 * FREE ALL BUT ONE OF THEM. T5181000 * T5181500 SVCP20 BAL R5,HSPFBFRE GO FREE ALL BUT ONE BUF. T5182000 LTR R1,R1 DO WE HAVE A PBF TO USE... T5182500 BNZ SVCP60 BRANCH IF SO. T5183000 * T5183500 * GET A NEW PROTECTED BUFFER T5184000 * T5184500 LH R5,SDBPBFCT GET CURRENT PBF COUNT. T5185000 TM SDBFLG1,SDB1BFXS IF EXCESSION ALLOWED, T5185100 BO SVCP25 DON'T TEST MAXIMUM. T5185200 CH R5,SDBPBFLM IS IT AT MAXIMUM... T5185500 BNL SVCP30 IF SO, GO WAIT. T5186000 SVCP25 $GETBUF TYPE=PROT GET A NEW BUFFER. T5186500 BE SVCP50 BRANCH IF SUCCESSFUL. T5187000 * T5187500 * IF STORAGE UNAVAILABLE OR BUFFER COUNT IS T5188000 * AT MAXIMUM, WAIT T5188500 * T5189000 SVCP30 DS 0H T5189500 * GETMAIN AN 8-BYTE WAIT ELEMENT OF THE FOLLOWING FORMAT.. @OZ37582 T5189600 * +0 ECB @OZ37582 T5189700 * +4 POINTER TO THE NEXT WAITER @OZ37582 T5189800 $GETMAIN RU,SP=254,LV=8,KEY=0 GET WAIT ELEMENT @OZ37582 T5190000 LR R4,R1 SAVE WAIT ELEMENT ADDRESS @OZ37582 T5190100 XC 0(4,R4),0(R4) CLEAR ECB @OZ37582 T5190200 L R0,SDBWAITQ GET WAIT QUEUE HEAD @OZ37582 T5190300 SVCP32 ST R0,4(,R4) CHAIN WAITERS BEHIND US @OZ37582 T5190400 CS R0,R4,SDBWAITQ PUT OUR ELEMENT ON QUEUE @OZ37582 T5190500 BNE SVCP32 REPEAT IF IT CHANGED. @OZ37582 T5190600 TM SDBFLG2,SDB2IOA IF I/O IS ACTIVE, T5191000 BO SVCP40 WAIT FOR EARLY POST. T5191500 TM 0(R4),X'40' ELSE SEE IF POST WAS DONE @OZ37582 T5192000 * IF POST WAS NOT DONE, THE CHANNEL-END LOOP DRIED UP @OZ37582 T5192100 * BEFORE WE GOT ON THE CHAIN OF WAITERS. THE WAIT ELEMENT @OZ37582 T5192200 * CANNOT BE FREED IN THIS CASE, AS OTHER ELEMENTS MIGHT @OZ37582 T5192300 * HAVE BEEN ADDED TO THE QUEUE AHEAD OF US. @OZ37582 T5192400 BZ SVCP35 NO POST, CHECK FOR BUFFERS @OZ37582 T5192500 B SVCP45 POSTED, FREE AND TRY AGAIN @OZ37582 T5192600 SVCP35 L RBUF,SDBFBF SEE IF BUFFER... @OZ37582 T5192700 LTR RBUF,RBUF WAS FREED BY HCEPUT. T5193000 BNZ SVCP20 YES. GO GET IT. T5193500 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5193600 B SVCSTOR NO. STORAGE UNAVAILABLE. T5194000 SVCP40 DS 0H T5194500 WAIT 1,ECB=(R4) WAIT FOR EARLY POST @OZ37582 T5195000 SVCP45 $FREMAIN RU,A=(R4),SP=254,LV=8,KEY=0 FREE ELEMENT @OZ37582 T5195100 B SVCP20 THEN TRY AGAIN. T5195500 * T5196000 * INCREMENT PROTECTED BUFFER COUNTER T5196500 * T5197000 SVCP50 LA R5,1(,R5) IF GETMAIN USED, ADD ONE T5197500 STH R5,SDBPBFCT TO PROTECTED-BUFFER COUNTER. T5198000 * T5198500 * INITIALIZE BUFFER T5199000 * T5199500 SVCP60 LR RBUF,R1 SET UP BUFFER BASE REGISTER. T5200000 MVI BFID,C'P' SHOW PROTECTED BUFFER. T5200500 MVC BFTRK,SDBTRK+1 SET TRACK TO WRITE BUFFER ON. T5201000 MVC BFKEY,SDBKEY SET JOB AND DS KEY. T5201500 ST R8,BFNXT SET CHAINING TRACK. T5202000 MVI BFFL1,0 SHOW BUFFER NOT YET WRITTEN. T5202500 NI SDBFLG1,255-SDB1BFXS RESET EXCESSION-ALLOWED. T5202800 * T5203000 * MOVE DATA FROM UNPROTECTED TO PROTECTED BUFFER T5203500 * T5204000 L R2,SDBUBF POINT TO USER RECORDS T5204500 LA R2,BFDAT-BFD(,R2) IN UNPROTECTED BUFFER. T5205000 LH R3,$SVBFSIZ SET MAXIMUM R4 T5205500 SL R3,=A(BFDAT-BFIO) SOURCE LENGTH. R4 T5205800 LA R4,BFDAT POINT TO SINK AREA. T5206000 LR R5,R3 SET SINK LENGTH. T5206500 MVCL R4,R2 MOVE UNPROTECTED DATA TO PBF. T5207000 USING LRCDSECT,R4 @OZ43719 T5207010 LA R4,BFDAT POINT TO BUFFER DATA @OZ43719 T5207020 SR R5,R5 ZERO COUNT REG @OZ43719 T5207030 LR R2,R4 POINT TO BUFFER DATA @OZ43719 T5207040 AH R2,$SVBFSIZ POINT TO END OF BUFFER @OZ43719 T5207050 SVCP61 DS 0H @OZ43719 T5207060 CR R4,R2 PAST END OF BUFFER @OZ43719 T5207070 BNL SVCP64 BRANCH IF YES @OZ43719 T5207080 CLI LRCTLENG,255 END OF BUFFER @OZ43719 T5207090 BE SVCP64 BRANCH IF YES @OZ43719 T5207100 TM LRCFLAG1,LRC1SPAN SPANNED RECORD @OZ43719 T5207110 BZ SVCP63A BRANCH IF NO @OZ43719 T5207120 * * @OZ43719 T5207130 * THIS ROUTINE INCREMENTS RECORD COUNT FOR * @OZ43719 T5207140 * SPANNED RECORDS * @OZ43719 T5207150 * * @OZ43719 T5207160 SR R1,R1 CLEAR REG1 @OZ43719 T5207170 ICM R1,3,LRCSEGL GET SEGMENT LENGTH @OZ43719 T5207180 BZ SVCP63 BRANCH NO DATA IN RECORD @OZ43719 T5207190 TM LRCFLAG1,LRC1SEND LAST SEGMENT @OZ43719 T5207200 BZ SVCP63 NO, DON'T COUNT @OZ43719 T5207210 LA R5,1(,R5) INCREMENT RECORD COUNT @OZ43719 T5207220 * THIS LINE DELETED BY APAR OZ57882 @OZ57882 T5207230 * THIS LINE DELETED BY APAR OZ57882 @OZ57882 T5207235 SVCP63 DS 0H @OZ43719 T5207240 LA R3,LRCSTEXT SKIP LRCB @OZ43719 T5207250 TM LRCFLAG1,LRC1SBGN FIRST SEGMENT... @OZ43719 T5207252 BZ SVCP63C BRANCH NO @OZ43719 T5207254 LA R3,LRCSFTXT INCREMENT PAST FIRST LRCB @OZ57882 T5207256 B SVCP63C SKIP RECORD TEXT @OZ43719 T5207260 * * @OZ43719 T5207270 * THIS ROUTINE INCREMENTS RECORD COUNT FOR * @OZ43719 T5207280 * NON-SPANNED RECORDS * @OZ43719 T5207290 * * @OZ43719 T5207300 SVCP63A DS 0H @OZ43719 T5207310 LA R3,LRCTEXT SKIP LRCB @OZ43719 T5207320 SR R1,R1 CLEAR REG1 @OZ43719 T5207330 ICM R1,1,LRCTLENG ANY DATA IN RECORD @OZ43719 T5207340 BZ SVCP63B DON'T INCREMENT COUNT @OZ43719 T5207350 LA R5,1(,R5) INCREMENT RECORD COUNT @OZ43719 T5207360 SVCP63B DS 0H @OZ43719 T5207370 TM LRCFLAG1,LRC1CCTL CARRIAGE CONTROL @OZ43719 T5207380 BZ SVCP63C NO, DON'T SKIP CC CHAR @OZ43719 T5207390 LA R3,1(,R3) SKIP CC CHARACTER @OZ43719 T5207400 SVCP63C DS 0H @OZ43719 T5207410 AR R3,R1 BUMP TO NEXT LRCB @OZ43719 T5207420 LR R4,R3 ESTABLISH LRCB BASE @OZ43719 T5207430 L R3,SDBRECCT GET CURRENT TOTAL LINES @OZ43719 T5207440 ALR R3,R5 GET CURRENT TOTAL @OZ43719 T5207450 CL R3,SDBOUTLM TOTAL EXCEED OUTLIM @OZ43719 T5207460 BNH SVCP61 NO, CONTINUE @OZ43719 T5207470 TM SDBFLG1,SDB1CLOS XBM USER TERMINATING... @OZ52438 T5207471 BO SVCP61 YES, DO NOT TRUNCATE @OZ52438 T5207472 LA R0,HSVCOUTL SET SVCHAM FUNCTION @OZ52438 T5207473 LNR R0,R0 FORCE DEBCHK IN SVCHAM @OZ52438 T5207474 L R1,SDBSAVE+32 GET ACB ADDRESS @OZ52438 T5207475 LNR R1,R1 INDICATE ACB ADDRESS @OZ52438 T5207476 SVC HAMSVC ISSUE HAMSVC @OZ52438 T5207477 CL R3,SDBOUTLM WAS OUTLIM INCREASED... @OZ52438 T5207478 BNH SVCP61 YES,CONTINUE @OZ52438 T5207479 MVI LRCTLENG,255 SET EOB HERE @OZ43719 T5207480 SVCP64 DS 0H @OZ43719 T5207490 ST R5,SDBSAVE+40 SAVE BUFFER RECORD COUNT @OZ43719 T5207500 DROP R4 @OZ43719 T5207510 * ADD PROTECTED BUFFER TO SDBPBFX CHAIN T5208000 * T5208500 L R1,SDBPBFX QUEUE THIS NEW PBF, T5209000 ST R1,BFBF LAST-IN-FIRST-OUT, T5209500 CS R1,RBUF,SDBPBFX ON CHAIN SDBPBFX. T5210000 BNE *-8 HCEPUT WILL DO THE REST. T5210500 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5210600 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5210700 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5210800 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5210900 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5211000 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5211100 * T5211200 * IF I/O IS INACTIVE, ISSUE EXCP T5211500 * T5212000 * THIS LINE DELETED BY APAR OZ43310 @OZ43310 T5212100 TM SDBFLG2,SDB2IOA IF I/O IS NOT ACTIVE, @OZ47054 T5212500 BZ SVCP67A GO TO REISSUE EXCP. @OZ47054 T5213000 CLI SDBICMP,X'48' IF NOT PURGED HALT I/O, @OZ47054 T5213050 BNE SVCP70 ...HCEPUT WILL REDRIVE @OZ47054 T5213100 MVI SDBECB,0 IF PURGED, CLEAR THE ECB.. @OZ47054 T5213150 EXCP SDBIOB REDRIVE PURGED I/O, AND @OZ47054 T5213200 B SVCP70 BR TO CONTINUE PROCESSING. @OZ47054 T5213250 SPACE 1 @OZ47054 T5213300 SVCP67A DS 0H @OZ47054 T5213350 TM BFFL1,BF1IOC IS I/O ALREADY COMPLETE... T5213500 BO SVCP70 IF SO, SKIP EXCP. T5214000 SVCP67 L R0,BFBF IF RBUF POINTS TO R4 T5214100 LTR R0,R0 THE LEAST RECENT BUFFER ON R4 T5214200 BZ SVCP68 SDBPBFX CHAIN, CONTINUE R4 T5214300 LR RBUF,R0 ELSE POINT RBUF TO THE LESS R4 T5214400 B SVCP67 RECENT BUFFER AND TRY AGAIN R4 T5214500 SVCP68 DS 0H R4 T5214600 L R1,SDBPBF IF CHAN END APPENDAGE T5214700 LTR R1,R1 BECAME A VICTIM OF T5214800 BZ *+6 PURGE-QUIESCE, RESTART WHERE T5214900 LR RBUF,R1 IT WOULD HAVE RESTARTED. T5215000 MVC SDBMTTR,BFTRK SET TRACK TO WRITE AND T5215100 CALL HCNVFDAD CONVERT IT TO ABSOLUTE. T5215200 LA R0,1 INCREMENT T5215500 AL R0,SDBXCPCT THE EXCP T5216000 ST R0,SDBXCPCT COUNT. T5216500 * THIS LINE DELETED BY APAR NUMBER @OZ41000 T5217000 LA R0,BFIO SET PTR TO DATA TO WRITE T5217500 STCM R0,7,SDBCCW4+1 INTO WRITE-DATA CCW. T5218000 MVI SDBCHEND,SDBCEPUT SET UP FOR CHANNEL END. T5218500 EXCP SDBIOB ISSUE EXCP. T5219000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5219500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5220000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5220500 SVCP70 DS 0H T5221000 L RBUF,SDBUBF POINT TO UNPROTECTED BUF @OZ43719 T5221500 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5222000 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5222500 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5223000 LTR R0,R8 IF DATA SET IS CLOSING @OZ46541 T5223500 BZ SVCP80 DON'T CHANGE SDBTTR @OZ46541 T5224000 LA R1,256 GET 0010 IN R1 @OZ46541 T5224500 SRDL R0,8 SHIFT FOR 0MTTR001 @OZ46541 T5225000 STM R0,R1,BFRBA SET NEW RBA IN UBUF @OZ46541 T5225500 STM R0,R1,SDBTRK AND IN SDBTRK @OZ46541 T5226000 STM R0,R1,SDBTRKL AND IN SDBTRKL @OZ46541 T5226500 ST R8,BFTRK SET TRACK TO WRITE NEXT @OZ46541 T5227000 SVCP80 DS 0H @OZ46541 T5227500 LA R0,BFDAT SET POINTER IN UBUF @OZ46541 T5228000 ST R0,BFLOC FOR FIRST LOGICAL RECORD @OZ46541 T5228500 LH R0,$SVBFSIZ SET LENGTH @OZ46541 T5229000 SL R0,=A(BFDAT+1-BFIO) IN UBUF @OZ46541 T5229300 ST R0,BFLEN OF LOGICAL RECORD AREA @OZ46541 T5229500 EJECT T5230000 PUSH USING SAVE REGISTER STATUS. T5230500 DROP RSJB DROP SJB BASE. T5231000 * T5231500 * T5232000 * INCREMENT RECORD COUNT, TEST FOR EXCESSION T5232500 * T5233000 * T5233500 TM SDBFLG1,SDB1OUT IF INTERNAL DATA SET, T5234000 BZ SVCP140 DON'T COUNT ANYTHING. T5234500 TM SDBFLG2,SDB2EOD COUNT RECORDS @OZ43719 T5234600 BO SVCP140 NO, DON'T COUNT @OZ43719 T5234700 SPACE 1 T5235000 L R0,SDBRECCT UP CURRENT DATA SET'S T5235500 AL R0,SDBSAVE+40 RECORD COUNT BY NUMBER @OZ43719 T5236000 ST R0,SDBRECCT OF RECORDS IN THIS BUFFER. T5236500 SPACE 1 T5237000 L R14,SDBSJB GET SJB BASE @OZ43719 T5237500 USING SJBDSECT,R14 SET SJB ADDRESSABILITY @OZ43719 T5238000 L R7,SJBJCT POINT TO THE JCT FROM SJB. T5238500 USING JCTDSECT,R7 SET JCT ADDRESSABILITY. T5239000 SPACE 1 T5239500 L R0,JCTXOUT UP OVERALL JOB'S T5240000 LR R1,R0 OUTPUT COUNT T5240500 AL R1,SDBSAVE+40 (INCLUDES PRINT & PUNCH) @OZ43719 T5241000 CS R0,R1,JCTXOUT BY NUMBER OF RECORDS T5241500 BNE *-10 IN THIS BUFFER. T5242000 SPACE 1 T5242500 LA R2,JCTLINES ASSUME PRINTED OUTPUT T5243000 LA R3,JCTESTLN AND GET POINTERS TO T5243500 LA R4,SJBESTLN CURRENT COUNT, USER ESTIMATE, T5244000 LA R5,=C'LINE' CURRENT ESTIMATE, AND CAPTION. T5244500 L R15,SDBPDDB POINT TO THE PDDB T5245000 USING PDBDSECT,R15 AND GET ADDRESSABILITY. T5245500 SLR R1,R1 ZERO R1 FOR IC. T5246000 IC R1,PDBCLASS GET CLASS AND INDEX T5246500 LA R1,$SVSCAT(R1) SYSOUT CLASS ATTRIBUTES. T5247000 USING SCADSECT,R1 SET SCAT ADDRESSABILITY. T5247500 TM SCATFLAG,SCATPNCH IF NOT PUNCH TYPE, T5248000 BZ SVCP100 IT MUST BE PRINT. T5248500 LA R2,JCTPUNCH IT'S A PUNCH DATA SET. T5249000 LA R3,JCTESTPU GET POINTERS TO T5249500 LA R4,SJBESTPU CURRENT COUNT, USER ESTIMATE, T5250000 LA R5,=C'CARD' CURRENT ESTIMATE, AND CAPTION. T5250500 SPACE 1 T5251000 SVCP100 DS 0H T5251500 L R0,0(,R2) UPDATE CURRENT COUNT T5252000 LR R1,R0 (JCTLINES OR JCTCARDS) T5252500 AL R1,SDBSAVE+40 BY NUMBER @OZ43719 T5253000 CS R0,R1,0(R2) OF RECORDS T5253500 BNE *-10 IN THIS BUFFER. T5254000 SPACE 1 T5254500 CL R1,0(,R4) IF CURRENT COUNT IS LESS T5255000 BNH SVCP140 THAN CURRENT ESTIMATE, BRANCH. T5255500 TM SDBFLG1,SDB1FOPN IS IT JOB LOG,MSGS OR JCLI @OZ17756 T5255600 BO SVCP140 BR IF YES, DON'T WARN @OZ17756 T5255700 TM SJBFLG1,SJB1XBM+SJB1XBMC IS XBM TO CONTINUE. @OZ47091 T5255800 BO SVCP140 IF YES, DO NOT WARN. @OZ47091 T5255900 SPACE 1 T5256000 MVC SPWMSG,SPWTO SET WTO MESSAGE AND T5256500 MVC SPWMV,0(R5) CAPTION INTO UBF FOR WTO. T5257000 SPACE 1 T5257500 L R5,$SVOUTXS GET INTO REGISTER 5 T5258000 LA R5,0(,R5) THE OUTPUT EXCESSION INCREMENT. T5258500 L R0,0(,R4) UPDATE CURRENT ESTIMATE T5259000 LR R1,R0 (SJBESTLN OR SJBESTPU) T5259500 ALR R1,R5 BY THE OUTPUT EXCESSION T5260000 CS R0,R1,0(R4) INCREMENT R4 T5260100 BNE SVCP140 IF INTERFERENCE, SOMEONE ELSE T5261000 * WROTE THE MESSAGE. T5261500 S R0,0(,R3) TAKE USER ESTIMATE FROM OLD T5262000 * CURRENT ESTIMATE. T5262500 MVC SPWME,SPWEDIT SET EDIT MASK. T5263000 CVD R0,SDBUPRBA CONVERT EXCESSION AMOUNT T5263500 * THIS LINE DELETED BY APAR NUMBER @OZ47806 T5264000 ED SPWME,SDBUPRBA+3 AND EDIT NINE DIGITS. @OZ47806 T5264500 CLC =F'1',0(R3) SEE IF ESTIMATE IS '1', R41 T5264600 BNE SVCP110 BRANCH IF NOT R41 T5264700 MVC SPWPLURL,SPWPLURL+1 CHANGE PLURAL TO SINGULAR R41 T5264800 MVI SPWBLNK,C' ' APPEND TRAILING BLANK R41 T5264900 SPACE 1 R41 T5265000 SVCP110 DS 0H R41 T5265100 LTR R0,R0 IF OLD CUR EST .GT. USER EST, T5265200 BP SVCP120 WRITE LONG MESSAGE. T5265500 MVI SPWMSGL,SPWML1 SET SHORT MESSAGE LENGTH. T5266000 MVC SPWD1,SPWD2 SHIFT DESC & ROUTCDE. T5266500 SPACE 1 T5267000 SVCP120 DS 0H T5267500 WTO MF=(E,SPWMSG) WRITE SHORT OR LONG MESSAGE. T5268000 L R1,PSATOLD-PSA POINT TO CURRENT TCB. T5268500 USING TCB,R1 SET TCB ADDRESSABILITY. T5269000 TM TCBFBYT1,TCBRTM2 IF RTM2 IS IN CONTROL, T5269500 BO SVCP140 DO NOT INSPECT &OUTPOPT. T5270000 TM TCBTCTGF,TCBSMFGF IF INITIATOR IN CONTROL, R4 T5270100 BNO SVCP140 DO NOT ABEND R4 T5270200 TM SJBFLG2,SJB2CONV IF CONVERTER IS RUNNING, T5271500 BO SVCP140 DO NOT ABEND. T5272000 CLI $SVOUTOP,1 TEST VALUE OF &OUTPOPT. T5272500 BL SVCP140 0 - DO NOT TERMINATE. T5273000 SLR R0,R0 ZERO OUT UNPROTECTED- @OZ32378 T5273025 ST R0,BFRCT BUFFER RECORD COUNT @OZ32378 T5273050 NI BFFL1,255-BF1EOB SHOW NOT END-OF-BUFFER @OZ45753 T5273075 L R2,PSAAOLD-PSA POINT TO ASCB @OZ41586 T5273100 L R2,ASCBTSB-ASCB(,R2) IS THIS TSO @OZ41586 T5273125 LTR R2,R2 LOGON... @OZ41586 T5273150 BNZ SVCP130 ...IF SO, CALL S.I.C. @OZ41586 T5273175 L R3,PSATOLD-PSA POINT TO TCB, @OZ41586 T5273200 L R3,TCBJSTCB-TCB(,R3) THEN JOB STEP TCB @OZ41586 T5273250 L R2,PSAAOLD-PSA GET CURRENT ASCB @OZ24437 T5273300 LH R2,ASCBASID-ASCB(,R2) GET ASID NUMBER @OZ24437 T5273350 LA R13,SDBSAVE POINT TO SAVE AREA FOR RTM @OZ24437 T5273400 CLI $SVOUTOP,1 RE-ESTABLISH COND CODE @OZ24437 T5273450 BE SVCP160 1 - TERMINATE WITHOUT DUMP. T5273500 B SVCP180 2 - TERMINATE WITH DUMP. T5274000 SPACE 1 T5274500 * @OZ41586 T5274525 * CALL SYSTEM INITIATED CANCEL (S.I.C.) IF TSO LOGON @OZ41586 T5274550 * @OZ41586 T5274575 SVCP130 DS 0H @OZ41586 T5274600 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,REGS=USE, @OZ41586*T5274625 RELATED=SVCP130 @OZ41586 T5274650 SETLOCK OBTAIN,TYPE=CMS,MODE=UNCOND,REGS=USE, @OZ41586*T5274675 RELATED=SVCP130 @OZ41586 T5274700 LA R0,X'722' SET ABEND CODE @OZ41586 T5274725 L R1,PSAAOLD-PSA ADDR OF ASCB TO BE CAN. @OZ41586 T5274750 LA R13,SDBSAVE POINT TO SAVE AREA FOR SIC @OZ41586 T5274775 L R15,CVTPTR GET CVT ADDRESS @OZ41586 T5274800 L R15,CVTSIC-CVT(,R15) GET ADDR OF SIC ROUTINE @OZ41586 T5274825 BALR R14,R15 CALL S.I.C. @OZ41586 T5274850 SETLOCK RELEASE,TYPE=CMS,REGS=USE,RELATED=SVCP130 @OZ41586 T5274875 SETLOCK RELEASE,TYPE=LOCAL,REGS=USE,RELATED=SVCP130 @OZ41586 T5274900 B SVCERROR GIVE UP CONTROL @OZ45753 T5274925 SPACE 1 @OZ41586 T5274950 SVCP140 DS 0H T5275000 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275030 PRINT OFF @OZ46541 T5275040 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275050 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275060 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275070 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275080 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275090 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275100 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275110 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275120 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275130 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275140 PRINT ON @OZ46541 T5275150 * THIS LINE DELETED BY APAR OZ46541 @OZ46541 T5275160 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5275500 * THIS LINE DELETED BY APAR OZ43719 @OZ43719 T5276000 * THIS LINE DELETED BY APAR NUMBER @OZ17756 T5276250 NI BFFL1,255-BF1EOB SHOW NOT END-OF-BUFFER. R4 T5276500 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5276600 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5276700 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5276800 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5276900 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5277000 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5277200 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5277300 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5277400 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5277500 * THIS LINE DELETED BY APAR NUMBER * @OZ52438 T5277600 B SVCNORML RETURN @OZ43719 T5277700 * T5278000 * EXCESSION MESSAGE T5278500 * T5279000 $MID 375 SET HASP MESSAGE ID. T5279500 SPWTO WTO '&MID.ESTIMATED ****S EXCEEDED BY NNNNNNNNN', @OZ47806CT5280000 ROUTCDE=2,DESC=6,MF=L T5280500 SPACE 1 T5281000 SPWTOL EQU *-SPWTO LENGTH OF WTO MACRO. T5281500 SPWEDIT DC X'40202020202020202120' EDIT MASK. @OZ47806 T5282000 * T5282500 * MESSAGE SINK DESCRIPTION T5283000 * T5283500 SPWMSG EQU BFDAT,SPWTOL MESSAGE SINK AREA. T5284000 SPWMSGL EQU SPWMSG+1,1 MESSAGE LENGTH AREA. T5284500 SPWML1 EQU SPWTOL-4-13 SHORT MESSAGE LENGTH. @OZ47806 T5285000 SPWMV EQU SPWMSG+4+9+10,4 CAPTION PORTION R4 T5285500 SPWPLURL EQU SPWMV+4,22 END OF '****S' @OZ47806 T5285600 SPWBLNK EQU SPWPLURL+L'SPWPLURL,1 SPACE FOR BLANK R41 T5285700 SPWME EQU SPWMSG+SPWTOL-4-10,10 EDIT PORTION. @OZ47806 T5286000 SPWD1 EQU SPWMSG+SPWTOL-4-13,4 SHORT ROUTCDE & DESC. @OZ47806 T5286500 SPWD2 EQU SPWMSG+SPWTOL-4,4 LONG ROUTCDE & DESC. T5287000 * T5287500 * &OUTPOPT=1 - TERMINATE JOB WITHOUT DUMP T5288000 * T5288500 SVCP160 CALLRTM TYPE=ABTERM,COMPCOD=X'722',ASID=(2),TCB=(3), @OZ24437CT5289000 DUMP=NO @OZ24437 T5289100 B SVCERROR GIVE UP CONTROL @OZ45753 T5289200 * T5289500 * &OUTPOPT=2 - TERMINATE JOB WITH DUMP T5290000 * T5290500 SVCP180 CALLRTM TYPE=ABTERM,COMPCOD=X'722',ASID=(2),TCB=(3) @OZ24437 T5291000 B SVCERROR GIVE UP CONTROL @OZ45753 T5291250 POP USING RESTORE REGISTER STATUS. T5291500 SPACE 1 R41 T5291600 DROP RSJB DROP SJB ADDRESSABILITY R41 T5291700 EJECT T5292000 * T5292500 * HAMSVC - USER SYSOUT LIMIT PROCESSOR T5293000 * T5293500 SVCUSO DS 0H T5294000 L R15,$SVSMFSO POINT TO IEFUSO. T5294500 CLC =X'1FFF07FE',0(R15) IF IT'S THE DEFAULT, T5295000 BE SVCUSOAB DO AN ABEND 722. T5295500 L R4,PSATOLD-PSA POINT TO CURRENT TCB. T5296000 USING TCB,R4 SET TCB ADDRESSABILITY. T5296500 L R5,TCBTCT POINT TO THE TCT. T5297000 LTR R5,R5 IF NO TCT, T5297500 BZ SVCUSOAB DO AN ABEND 722. T5298000 USING SMFTCT,R5 SET TCT ADDRESSABILITY. T5298500 L R6,TCTJMR POINT TO THE JMR. T5299000 LTR R6,R6 IF NO JMR, T5299500 BZ SVCUSOAB DO AN ABEND 722. T5300000 L R1,SDBSJB POINT TO THE SJB FROM SDB. T5300500 USING SJBDSECT,R1 GET ADDRESSABILITY. T5301000 L R1,SJBJCT POINT TO THE JCT FROM SJB. T5301500 USING JCTDSECT,R1 GET ADDRESSABILITY. T5302000 TM JCTSMFLG,JCTNOUSO IF IEFUSO EXIT NOT TO BE T5302500 BO SVCUSOAB TAKEN, DO ABEND 722. T5303000 DROP R1 DROP JCT ADDRESSABILITY. T5303500 * T5304000 * SET UP FOR AND CALL IEFUSO T5304500 * T5305000 * THIS LINE DELETED BY APAR NUMBER ===> @OZ42340 T5305500 GETMAIN R,LV=80,SP=230 GET WORK AREA. T5306000 L R15,$SVSMFSO POINT AGAIN TO IEFUSO. T5306500 LR R13,R1 POINT R13 TO SAVE AREA. T5307000 ST R6,72(,R13) SET JMR ADDRESS AS ARGUMENT. T5307500 MVI 72(R13),X'80' SHOW IT'S THE LAST ARGUMENT. T5308000 SLR R0,R0 SET DCB ADDRESS TO T5308500 ST R0,76(,R13) ZERO JUST IN CASE. T5309000 LA R1,72(,R13) POINT R1 TO ARGUMENTS. T5309500 BALR R14,R15 CALL IEFUSO. T5310000 LR R2,R15 SAVE RETURNED REGISTER 15. T5310500 LR R3,R1 SAVE RETURNED REGISTER 1. T5311000 FREEMAIN R,LV=80,SP=230,A=(R13) FREE WORK AREA. T5311500 * THIS LINE DELETED BY APAR NUMBER ===> @OZ42340 T5312000 LTR R2,R2 IF R15 WAS ZERO, T5312500 BZ SVCUSOAB DO AN ABEND 722. T5313000 CL R2,=F'4' IF R15 WAS NOT FOUR, T5313500 BNE SVCUSOAB DO AN ABEND 722. T5314000 AL R3,SDBOUTLM ELSE INCREASE OUTPUT T5314500 ST R3,SDBOUTLM LIMIT BY CONTENTS OF R1. T5315000 B SVCNORML THEN RETURN NORMALLY. T5315500 * T5316000 * ABEND THE CALLER - OUTPUT LIMIT EXCEEDED T5316500 * T5317000 SVCUSOAB DS 0H @OZ43719 T5317100 TM SDBFLG2,SDB2EOD RECORD COUNT OFF @OZ43719 T5317200 BO SVCNORML YES, EXIT NORMALLY @OZ43719 T5317300 OI SDBFLG2,SDB2EOD SET RECORD COUNT OFF @OZ43719 T5317400 L R3,PSATOLD-PSA GET CURRENT TASK @OZ43719 T5317500 L R3,TCBJSTCB-TCB(,R3) GET JOB STEP TASK @OZ24437 T5317550 L R2,PSAAOLD-PSA POINT TO ASCB @OZ41586 T5317560 L R2,ASCBTSB-ASCB(,R2) IS THIS TSO @OZ41586 T5317570 LTR R2,R2 LOGON... @OZ41586 T5317580 BNZ SVCP130 ...IF SO, CALL S.I.C. @OZ41586 T5317590 L R2,PSAAOLD-PSA GET CURRENT ASCB @OZ24437 T5317600 LH R2,ASCBASID-ASCB(,R2) GET ASID NUMBER @OZ24437 T5317650 LA R13,SDBSAVE POINT TO SAVE AREA FOR RTM @OZ24437 T5317700 CALLRTM TYPE=ABTERM,COMPCOD=X'722',ASID=(2),TCB=(3) @OZ24437 T5317750 B SVCERROR GIVE UP CONTROL @OZ45753 T5317800 EJECT T5318000 * T5318500 * T5319000 * SUBROUTINE TO FREE SDBFBF BUFFERS T5319500 * T5320000 * T5320500 HSPFBFRE DS 0H T5321000 L RBUF,SDBFBF DEQUEUE ENTIRE T5321500 SLR R0,R0 CHAIN OF T5322000 CS RBUF,R0,SDBFBF TO-BE-FREED BUFFERS T5322500 BNE *-4 FROM HEADER SDBFBF. T5323000 LTR R1,RBUF IF NO BUFFERS TO FREE, T5323500 BZR R5 RETURN WITH R1=0. T5324000 L RBUF,BFBF IF ONLY ONE BUFFER T5324500 LTR RBUF,RBUF ON TO-BE-FREED CHAIN, T5325000 BZR R5 RETURN WITH R1=BUFFER. T5325500 ST R1,0(,RSDB) SAVE MOST-RECENT BUFFER ADR. T5326000 HSPF010 DS 0H T5326500 LTR R1,RBUF IS THERE A BUFFER TO FREE... T5327000 L RBUF,BFBF (GET PTR TO NEXT BUFFER.) T5327500 BNZ HSPF020 IF SO, GO FREE IT. T5328000 L R1,0(,RSDB) ELSE RESTORE BUFFER ADDRESS T5328500 BR R5 AND RETURN TO CALLER. T5329000 HSPF020 DS 0H T5329500 $FREEBUF TYPE=PROT,A=(R1) FREE THE BUFFER. T5330000 LH R0,SDBPBFCT DECREMENT T5330500 BCTR R0,0 PROTECTED-BUFFER T5331000 STH R0,SDBPBFCT COUNTER. T5331500 B HSPF010 GO CHECK FOR MORE BUFFERS. T5332000 EJECT T5332500 * T5333000 * T5333500 * HAMSVC - UPDATE PROCESSING FOR PUT T5334000 * T5334500 * T5335000 SVCPUP DS 0H T5335500 * T5336000 * MOVE EACH HBF TO ITS GBF AND FREE IT T5336500 * T5337000 L RBUF,SDBGBF POINT TO FIRST PROTECTED BUFFER T5337500 SPU010 LTR RBUF,RBUF IF WE'RE AT THE END, T5338000 BZ SPU020 BRANCH. T5338500 LA R2,BFDAT POINT TO PROT BUF DATA AREA. T5339000 LH R3,$SVBFSIZ GET DATA R4 T5339500 SL R3,=A(BFDAT-BFIO) LENGTH. R4 T5339800 L R1,BFECB POINT TO CORRESP UNPROT BUF. T5340000 LA R4,BFDAT-BFD(,R1) POINT TO UNPROT BUF DATA AREA. T5340500 LR R5,R3 SET SOURCE LENGTH. T5341000 MVCL R2,R4 MOVE UNPROT DATA TO PROT. T5341500 $FREMAIN BU,A=(R1),LV=4096,SP=229,KEY=1 R4 T5342000 L RBUF,BFBF POINT TO NEXT PROTECTED BUFFER. T5342500 B SPU010 LOOP TO TRANSFER IT TO PROT BUF T5343000 * T5343500 * WRITE OUT THE UPDATE-PROTECTED BUFFERS T5344000 * T5344500 SPU020 DS 0H T5345000 SLR R0,R0 ZERO POINTER TO T5345500 ST R0,SDBHBF UPDATE-UNPROTECTED BUFFERS. T5346000 L RBUF,SDBGBF POINT TO FIRST UPDATE-PROT BUF. T5346500 MVC SDBGBF,SDBPBF SAVE NON-UPD PROT BUF POINTER. T5347000 ST RBUF,SDBPBF POINT SDBPBF TO UPD-PROT CHAIN. T5347500 L R5,SDBMTTR SAVE CURRENT SDBMTTR. T5348000 MVC SDBMTTR,BFTRK SET SDBMTTR FROM 1ST T5348500 CALL HCNVFDAD UPD-PROT BUF AND CONVERT IT. T5349000 IC R3,SDBCHEND SAVE VALUE OF SDBCHEND. T5349500 L R4,SDBCCW4 SAVE SDBCCW4. T5350000 LA R0,BFIO POINT TO I/O AREA IN BUFFER. T5350500 ST R0,SDBCCW4 SET ADDRESS IN WRITE-DATA CCW. T5351000 MVI SDBCCW4,5 SET WRITE-DATA COMMAND. T5351500 MVI SDBCHEND,SDBCEPUT ASK FOR HCEPUT. T5352000 EXCP SDBIOB START THE WRITE. T5352500 WAIT 1,ECB=SDBECB WAIT FOR COMPLETION. T5353000 STC R3,SDBCHEND RESTORE SDBCHEND VALUE. T5353500 ST R4,SDBCCW4 RESTORE SDBCCW4. T5354000 ST R5,SDBMTTR RESTORE SDBMTTR. T5354500 MVC SDBPBF,SDBGBF RESTORE SDBPBF. T5355000 SLR R0,R0 ZERO T5355500 ST R0,SDBGBF THE UPDATE-PROT BUF PTR. T5356000 B SVCNORML RETURN NORMALLY. T5356500 EJECT T5357000 * T5357500 * T5358000 * HAMSVC - POINT PROCESSING T5358500 * T5359000 * T5359500 SVCPNT DS 0H T5360000 L RBUF,SDBUBF SET POINT RBA T5360500 MVC SDBUPRBA,BFRBA FROM UBF'S BFRBA. T5361000 * QUIESCE INPUT/OUTPUT OPERATIONS T5361500 WAIT 1,ECB=SDBECB WAIT FOR I/O COMPLETION. T5362000 SPACE 2 T5362500 * IF OUTPUT - GET & INITIALIZE A PBF, SET SDBCCW4 TO READ, T5363000 * AND SET SDBCHEND TO SDBCEGET. T5363500 TM SDBFLG1,SDB1PUT IF NOT OUTPUT DATA SET, T5364000 BZ SVT060 BRANCH. T5364500 $GETBUF TYPE=PROT GET A PROTECTED BUFFER. T5365000 BNZ SVCSTOR ERROR - STORAGE UNAVAILABLE. T5365500 LR RBUF,R1 SET BUFFER REGISTER. T5366000 MVI BFID,C'P' SET BUFFER ID. T5366500 ST RBUF,SDBPBF SAVE BUFFER ADDRESS. T5367000 LA R0,BFIO SET BUFFER I/O ADDRESS T5367500 ST R0,SDBCCW4 IN READ-DATA CCW. T5368000 MVI SDBCCW4,X'06' SET COMMAND TO READ. T5368500 SPACE 2 T5369000 SVT060 DS 0H T5369500 * INITIATE A READ FOR THE CORRECT RECORD T5370000 MVC SDBMTTR,SDBUPRBA+1 SET MTTR AND T5370500 CALL HCNVFDAD CONVERT DISK ADDRESS. T5371000 NI SDBFLG2,255-SDB2EOD-SDB2IOE RESET ERROR FLAGS. T5371500 MVI SDBCHEND,SDBCEPNT SET POINT CH END APDG. T5372000 SVT065 DS 0H @OZ35141 T5372250 EXCP SDBIOB START I/O FOR POINT. T5372500 L R1,SDBECB LOAD ECB @OZ35141 T5372550 SVT067 LR R2,R1 RELOAD ECB @OZ35141 T5372600 N R2,=XL4'7F000000' RESET WAIT BIT @OZ35141 T5372650 CS R1,R2,SDBECB REPLACE ECB @OZ35141 T5372700 BNE SVT067 TRY AGAIN IF UNSUCCESSFUL @OZ35141 T5372750 WAIT 1,ECB=SDBECB WAIT TILL DONE. T5373000 TM SDBFLG1,SDB1BFXS WERE WE QUIESCED @OZ35141 T5373100 BZ SVT070 CONTINUE IF NOT @OZ35141 T5373200 NI SDBFLG1,255-SDB1BFXS RESET QUIESCE INDICATOR @OZ35141 T5373300 B SVT065 REDRIVE POINT OPERATION @OZ35141 T5373400 SVT070 MVI SDBCHEND,SDBCEGET SET GET CH END APDG @OZ35141 T5373500 SPACE 2 T5374000 * IF OUTPUT - FREE THE PBF AND RESTORE SDBCCW4,SDBCHEND T5374500 TM SDBFLG1,SDB1PUT IF NOT OUTPUT DATA SET, T5375000 BZ SVT080 BRANCH. T5375500 $FREEBUF TYPE=PROT,A=SDBPBF ELSE FREE THE PBF T5376000 SLR R0,R0 ZERO OUT T5376500 ST R0,SDBPBF PROTECTED BUFFER POINTER. T5377000 MVI SDBCCW4,X'05' SET WRITE COMMAND. T5377500 MVI SDBCHEND,SDBCEPUT SET CHANNEL END APDG TO PUT. T5378000 LA R13,SDBSAVE YES, SET UP SAVE AREA. @OZ35029 T5378100 ICM R0,15,SDBTRK+1 GET NEW RESUME MTTR. @OZ35029 T5378200 CALL HJSRETAB REBUILD TRACK ALLOC. BLK. @OZ35029 T5378300 SPACE 2 T5378500 SVT080 DS 0H T5379000 L R15,SDBSAVE PASS HCEPNT RETURN CODE T5379500 B SVCEXIT BACK TO HAMPOINT. T5380000 EJECT T5380500 * T5381000 * T5381500 * HAMSVC - EXITS AND CONSTANTS T5382000 * T5382500 * T5383000 SPACE 3 T5383500 SVCNORML DS 0H T5384000 SR R15,R15 NORMAL EXIT - T5384500 B SVCEXIT RETURN ON CVTEXPRO. T5385000 SPACE 3 T5385500 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5385600 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5385700 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5385800 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5385850 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5385900 * THIS LINE DELETED BY APAR NUMBER @OZ37582 T5385950 SVCERRET DS 0H LOGICAL ERROR EXIT - T5386000 LA R15,4 RETURN CODE OF 4. T5386500 B SVCEXIT RETURN. T5387000 SPACE 2 T5387500 SVCSTOR DS 0H NO MAIN STORAGE AVAILABLE T5388000 L R15,=A(HERSTOR) T5388500 B SVCEXIT T5389000 SPACE 2 T5389500 SVCEOD DS 0H T5390000 L R15,=A(HERNOEOD) POINT FOUND END-OF-FILE T5390500 B SVCEXIT T5391000 SPACE 3 T5391500 SVCEXIT DS 0H T5392000 L R14,CVTPTR POINT TO THE CVT. T5392500 USING CVT,R14 SET CVT ADDRESSABILITY. T5393000 L R14,CVTEXPRO POINT TO EXIT PROLOGUE. T5393500 DROP R14 DROP CVT ADDRESSABILITY. T5394000 BR R14 BRANCH TO EXIT PROLOGUE. T5394500 SVCERROR DS 0H @OZ45753 T5394600 MVI SDBSAVE,0 CLEAR PSEUDO-ECB WAIT/POST @OZ45753 T5394700 LA R1,SDBSAVE SET TO WAIT FOREVER @OZ45753 T5394800 WAIT 1,ECB=(R1) SO RTM CAN RUN @OZ45753 T5394900 * THIS LINE DELETED BY APAR ===> @OZ45753 T5395000 * THIS LINE DELETED BY APAR ===> @OZ45753 T5395100 LTORG T5395500 EJECT T5396000 * T5396500 * T5397000 * HAMSVC - ENDREQ PROCESSING T5397500 * T5398000 * T5398500 SVCENDR DS 0H T5399000 * IF DATA SET NOT OUTPUT, MERELY RETURN T5399500 TM SDBFLG1,SDB1PUT IF NOT OUTPUT DATA SET, T5400000 BZ SVCNORML RETURN NORMALLY. T5400500 * TRUNCATE UNPROTECTED BUFFER T5401000 L RBUF,SDBUBF POINT TO UBF FROM SDB. T5401500 L R1,BFLOC POINT TO CURRENT LOCATION. T5402000 LA R5,BFIO GET ADDRESS OF @OZ29839 T5402050 AH R5,$SVBFSIZ BUFFER END. @OZ29839 T5402100 CR R5,R1 COMPARE BFLOC TO END. @OZ29839 T5402150 BNH SVCENDRA ERROR IF BFLOC TOO LARGE. @OZ29839 T5402200 CR RBUF,R1 COMPARE BFLOC TO START. @OZ29839 T5402250 BL SVCENDR0 NO ERROR IF BFLOC IN RANGE @OZ29839 T5402300 SVCENDRA L R15,=A(HERBLKER) SET UP FOR 1FA ABEND. @OZ29839 T5402350 B SVCEXIT RETURN TO HAMENDR. @OZ29839 T5402400 SVCENDR0 DS 0H BUFLOC WITHIN RANGE. @OZ29839 T5402450 MVI 0(R1),LRCBFEND TRUNCATE THE BUFFER. T5402500 * SAVE BFLOC AND BFLEN FOR AFTER SVCPUT RESETS THEM T5403000 LM R2,R3,BFLOC SAVE BFLOC, BFLEN T5403500 * SET CLOSE FLAG SO DATA SET WILL APPEAR AT END-OF-FILE T5404000 OI SDBFLG1,SDB1CLOS CAUSE CLOSE PROCESSING. T5404500 * FLAG ALLOCATION IOT SO HCEPUT WILL WRITE IT T5405000 L RIOT,SDBAIOT FLAG ALLOCATION IOT FOR T5405500 OI IOTFLAG1-IOTDSECT(RIOT),IOT1CKPT CHECKPOINT. T5406000 * CALL SVCPUT TO WRITE OUT UNPROTECTED BUFFER CONTENTS T5406500 OI SDBFLG2,SDB2EOD SET RECORD COUNT OFF @OZ43719 T5406600 LR R1,RRPL SET RPL REGISTER. T5407000 LA R0,HSVCEOBP SET FUNCTION REGISTER. T5407500 LNR R0,R0 FORCE DEBCHK IN IGC111 @OZ41386 T5407600 SVC HAMSVC START CLOSING. T5408000 * RESET THE CLOSE FLAG SO DATA SET CAN CONTINUE WRITING T5408500 NI SDBFLG1,255-SDB1CLOS RESET CLOSE FLAG. T5409000 NI SDBFLG2,255-SDB2EOD RESET RECORD COUNT @OZ43719 T5409100 * RESTORE BFLOC AND BFLEN TO RE-ESTABLISH UBF POSITION T5409500 STM R2,R3,BFLOC RESTORE BFLOC, BFLEN. T5410000 * IF ERROR, RETURN ERROR ADDRESS TO HAMENDR T5410500 LTR R15,R15 IF ERROR, T5411000 BNZ SVCEXIT RETURN CODE TO HAMENDR. T5411500 * TEST FOR PURGED I/O AND RESTART EXCP LOOP IF NECESSARY. @OZ28485 T5411600 TM SDBFLG2,SDB2IOA IF I/O NOT ACTIVE, @OZ28485 T5411620 BZ SVCENDR1 NO NEED TO TEST FOR PURGE. @OZ28485 T5411640 CLI SDBICMP,X'48' IF ACTIVE AND NOT PURGED, @OZ28485 T5411660 BNE SVCENDR1 GO WAIT FOR COMPLETION. @OZ28485 T5411680 L R2,SDBECB SAVE CURRENT ECB. @OZ28485 T5411700 MVI SDBECB,0 ZERO THE ECB. @OZ28485 T5411720 EXCP SDBIOB START CHANNEL PROGRAM. @OZ28485 T5411740 WAIT 1,ECB=SDBECB WAIT FOR COMPLETION. @OZ28485 T5411760 LTR R2,R2 IF SAVED ECB'S WAIT BIT @OZ28485 T5411780 BNM SVCNORML IS OFF, BRANCH. @OZ28485 T5411800 ST R2,SDBECB ELSE RESTORE IT. @OZ28485 T5411820 IC R0,SDBICMP GET POST CODE. @OZ28485 T5411840 SLL R0,24 LEFT JUSTIFY. @OZ28485 T5411860 POST SDBECB,(0) POST THE SAVED ECB. @OZ28485 T5411880 B SVCNORML AND DONE. @OZ28485 T5411900 SVCENDR1 DS 0H @OZ28485 T5411920 * WAIT FOR I/O TO COMPLETE. THEN RETURN. T5412000 WAIT 1,ECB=SDBECB WAIT FOR I/O COMPLETION. T5412500 B SVCNORML RETURN NORMALLY. T5413000 EJECT T5417500 * T5418000 * T5418500 * HAMSVC --- INTERNAL READER PROCESSING T5419000 * T5419500 * T5420000 SVCIRD DS 0H T5420500 * T5421000 * IF NO UNPROTECTED BUFFER - T5421500 * GET ONE, $$POST UNIT, AND RETURN T5422000 * T5422500 USING DCTDSECT,RSDB ESTABLISH DCT ADDRESSABILITY. T5423000 SLR R7,R7 SET ZERO RETURN CODE. T5423500 L RBUF,RIDUBF GET UNPROT BUF ADDRESS. T5424000 LTR RBUF,RBUF IS THERE ONE... T5424500 BNZ SVI100 CONTINUE IF SO. T5425000 $GETMAIN BC,SP=229,KEY=15,LV=RIDBUFSZ ELSE GET ONE. T5425500 BNZ SVI010 BR IF STORAGE UNAVAILABLE T5426000 LR RBUF,R1 ELSE SET BUF ADDRESSABILITY. T5426500 ST RBUF,RIDUBF SET POINTER IN DCT. T5427000 LA R0,BFDAT SET STARTING T5427500 ST R0,BFLOC DATA ADDRESS. T5428000 MVC BFLEN,=A(RIDBUFSZ-(BFDAT+1-BFD)) SET LENGTH. T5428500 XC RIDEOME,RIDEOME CLEAR EOM ECB @OZ48724 T5428550 MVC RIDEOMA,PSAAOLD-PSA SET ASCB TO POST @OZ48724 T5428600 TM RIDFLAGS,RIDEOM IS EOM IN PROGRESS... @OZ48724 T5428650 BZ SVINEOM BR IF NOT...ELSE, @OZ48724 T5428700 WAIT 1,ECB=RIDEOME WAIT FOR RDR TO COMPLETE @OZ48724 T5428750 SVINEOM DS 0H @OZ48724 T5428800 NI DCTSTAT,255-DCTHOLD-DCTDRAIN RESET DCTHOLD, T5429000 NI RIDFLAGS,255-RIDEND DCTDRAIN, AND RIDEND. T5429500 MVC RIDASCBP,PSAAOLD-PSA SAVE ASCB ADDRESS. T5430000 $$POST TYPE=UNIT $POST HASP FOR UNIT. T5430500 B SVCNORML RETURN NORMALLY. T5431000 * T5431500 * IF FAILURE TO GET UNPROTECTED BUFFER - T5432000 * WRITE ERROR MESSAGE AND RETURN T5432500 * T5433000 SVI010 DS 0H T5433500 BAL R14,SVIWTO WRITE ERROR MESSAGE T5434000 B SVCERRET *** TEMP RETURN R15=4. T5434500 SPACE 3 T5435000 * T5435500 * IF UNPROTECTED BUFFER EXISTS, T5436000 * WAIT TILL HASPRDR IS READY T5436500 * T5437000 SVI100 DS 0H T5437500 L R1,RIDECB GET POST ECB R4 T5438800 SKIP420 LR R2,R1 RELOAD ECB R4 T5438900 N R2,=X'7F000000' RESET WAIT BIT R4 T5439000 CS R1,R2,RIDECB RESET ECB, PRESERVING POST R4 T5439100 BNE SKIP420 TRY AGAIN, IF UNSUCCESSFUL R4 T5439200 WAIT 1,ECB=RIDECB ELSE WAIT FOR HASPRDR. T5439300 SLR R0,R0 THEN T5439500 ST R0,RIDECB ZERO OUT THE ECB T5440000 * T5441000 * IF PROTECTED BUFFER EXISTS, T5441500 * MOVE DATA TO IT, $$POST IO, AND RETURN T5442000 * T5442500 SVI110 DS 0H TEST PROTECTED BUFFER T5443000 L R2,RIDPBF GET PROTECTED BUF ADDRESS. T5443500 LTR R2,R2 DOES IT EXIST... T5444000 BNZ SVI120 BRANCH IF SO. T5444500 BAL R5,SVIFREE ELSE FREE UNPROT BUFFER, T5445000 BAL R5,SVIPOST POST HASP FOR FLAGS, R41 T5445100 BAL R14,SVIWTO WRITE MESSAGE, T5445500 B SVCERRET AND RETURN ERROR. T5446000 SVI120 DS 0H MOVE UNPROT BUF TO PROT BUF. T5446500 LA R2,BFDAT-BFD(,R2) ELSE GET ITS DATA ADDRESS T5447000 ST R2,RIDPBFO AND INITIALIZE RIDPBFO. T5447500 L R3,=A(RIDBUFSZ-(BFDAT-BFD)) GET LENGTH OF MOVE. T5448000 LA R4,BFDAT GET UNPROT DATA ADDRESS. T5448500 L R1,BFLOC POINT TO NEXT LRC SPACE. T5449000 LR R5,R4 GET ADDRESS OF @OZ29839 T5449100 ALR R5,R3 BUFFER END. @OZ29839 T5449150 CR R5,R1 COMPARE BFLOC TO END. @OZ29839 T5449200 BNH SVIABND ABEND1FA, BFLOC TOO LARGE. @OZ29839 T5449250 CR RBUF,R1 COMPARE BFLOC TO START. @OZ29839 T5449300 BNL SVIABND ABEND1FA, BFLOC TOO SMALL. @OZ29839 T5449350 USING LRCDSECT,R1 USE LRC DSECT. T5449500 MVI LRCTLENG,LRCBFEND TRUNCATE THE BUFFER. T5450000 DROP R1 DROP LRC DSECT. T5450500 ST R4,BFLOC RE-INITIALIZE UNPROT DATA START T5451000 MVC BFLEN,=A(RIDBUFSZ-(BFDAT+1-BFD)) AND LENGTH. T5451500 LR R5,R3 SET SOURCE LENGTH. T5452000 MVCL R2,R4 MOVE UNPROT TO PROT BUF T5452500 BAL R5,SVIPOST AFTER MOVE, POST HASP. T5453000 TM BFFL1,RIDERQ+RIDCLS IF NOT ENDREQ NOR T5453500 BZ SVCNORML CLOSE, JUST RETURN. T5454000 WAIT 1,ECB=RIDECB WAIT FOR JOB ID FROM HASP. T5454500 BAL R5,SVIFREE ELSE FREE UNPROT BUF, T5455000 BAL R5,SVIPOST POST HASP FOR FLAGS, T5455500 B SVCNORML AND THEN RETURN. T5456000 SPACE 3 T5456500 * T5457000 * SUBROUTINE TO FREE UNPROTECTED BUFFER T5457500 * T5458000 SVIFREE DS 0H BAL R5,SVIFREE T5458500 $FREMAIN BC,SP=229,KEY=15,LV=RIDBUFSZ,A=(RBUF) FREE UBF. T5459000 SLR R0,R0 ZERO POINTER T5459500 ST R0,RIDUBF TO UNPROTECTED BUFFER. T5460000 OI RIDFLAGS,RIDEND SHOW INTERNAL READER END T5460500 OI DCTSTAT,DCTHOLD AND DEVICE HELD. T5461000 BR R5 RETURN TO SUBROUTINE CALLER. T5461500 SPACE 3 T5462000 * T5462500 * SUBROUTINE TO POST HASP INTERNAL READER T5463000 * T5463500 SVIPOST DS 0H BAL R5,SVIPOST T5464000 SLR R0,R0 ZERO OUT ECB T5464500 ST R0,RIDECB BEFORE POSTING HASP. T5465000 NI RIDFLAGS,255-RIDBUSY SHOW SSSM GIVES UP CONTROL. T5465500 OI RIDFLAGS,RIDPOST SHOW HASPDISP WHICH TO POST. T5466000 $$POST ELMT=$SVIRDR POST HASPDISP FOR INTRDR. T5466500 BR R5 RETURN TO SUBROUTINE CALLER. T5467000 SPACE 3 T5467500 * @OZ29839 T5467600 * IF BUFFER ERROR, FORCE ABEND 1FA @OZ29839 T5467650 * @OZ29839 T5467700 SVIABND ABEND X'1FA',DUMP,,SYSTEM BUFFER ERROR. @OZ29839 T5467750 SPACE 1 @OZ29839 T5467800 * T5468000 * IF ERROR, WRITE ERROR MESSAGE T5468500 * T5469000 SVIWTO DS 0H T5469500 L R7,=A(RPLWTERD+65536*RPLPHYER) SET ERROR CODE. T5470000 GETMAIN RC,LV=SVIML GET MESSAGE BUFFER. T5470500 LTR R15,R15 IF GETMAIN FAILED, T5471000 BNZR R14 RETURN TO CALLER. T5471500 LR R2,R1 ELSE SAVE BUFFER ADDRESS. T5472000 MVC 0(SVIML,R1),SVIM MOVE MSG TO BUFFER. T5472500 MVC SVIML1(,R1),DCTDEVN MOVE INTRDR NAME TO MESSAGE. T5473000 WTO MF=(E,(1)) WRITE THE MESSAGE. T5473500 FREEMAIN RC,LV=SVIML,A=(R2) FREE THE BUFFER. T5474000 BR R14 RETURN TO CALLER. T5474500 $MID 354 HASP354 IS MESSAGE ID. T5475000 SVIM WTO '$&MID.******** - STORAGE NOT AVAILABLE FOR BUFFERS',MF=CT5475500 L,ROUTCDE=11,DESC=6 T5476000 SVIML EQU *-SVIM LENGTH OF MESSAGE BUFFER T5476500 SVIML1 EQU 4+1+9,8 LOC, LENGTH OF INTRDR NAME R4 T5477000 USING SDBDSECT,RSDB RESTORE SDB ADDRESSABILITY. T5477500 LTORG @OZ32729 T5477700 TITLE 'HAM CHANNEL END APPENDAGE' T5478000 * T5478500 * T5479000 * HASP ACCESS METHOD CHANNEL END APPENDAGE T5479500 * T5480000 * T5480500 HAMCEA DS 0H T5481000 USING *,R15 ESTABLISH ADDRESSABILITY T5481500 LR R10,R2 SWITCH IOB ADDRESS TO R10. T5482000 S R10,=A(SDBIOB-SDBDSECT) POINT TO SDB. T5482500 CLC SDBID-SDBDSECT(6,R10),HCSDBID DOES SDB LOOK OKAY... T5483000 BNER R14 NO --- PROBABLY SJB I/O. T5483500 SPACE 3 T5484000 * SAVE AND SET UP REGISTERS. T5484500 USING SDBDSECT,RSDB USE THE SDB DSECT. T5485000 L RSVT,SDBSVT SET THE SVT BASE REGISTER. T5485500 STM R0,R15,0(R13) SAVE REGISTERS. T5486000 BALR R12,0 ESTABLISH T5486500 USING *,R12 ADDRESSABILITY. T5487000 HCEBASE DS 0H T5487500 SPACE 2 T5488000 SR R15,R15 ZERO A REGISTER. T5488500 IC R15,SDBCHEND GET DISPLACEMENT FOR CHAN END CODE. T5489000 B *+4(R15) BRANCH ACCORDINGLY. T5489500 B HCEGET GET T5490000 B HCEPUT PUT T5490500 B HCEPNT POINT T5491000 B HCEGUP GET-UPDATE T5491500 HAMAVT DC A(*+20,HAMSIO,*+12,HAMCEA,HAMCEX),X'07FE' @OZ41000 T5492000 EJECT @OZ41000 T5492050 * @OZ41000 T5492100 * STARTIO APPENDAGE @OZ41000 T5492150 * @OZ41000 T5492200 HAMSIO DS 0H INDICATE EXCP IN PROCESS @OZ41000 T5492250 USING *,R15 SET LOCAL ADDRESSABILITY @OZ41000 T5492300 STM R0,R15,0(R13) SAVE REGISTERS @OZ41000 T5492350 L R12,=A(HCEBASE) SET PERMANENT BASE @OZ41000 T5492400 DROP R15 DROP TEMPORARY BASE @OZ41000 T5492450 LR R10,R2 COMPUTE AND SET @OZ41000 T5492500 SL R10,=A(SDBIOB-SDBDSECT) SDB POINTER @OZ41000 T5492550 CLC SDBID,HCSDBID IF NOT AN SDB, @OZ41000 T5492600 BNE HAMSIO1 RETURN IMMEDIATELY @OZ41000 T5492650 OI SDBFLG2,SDB2IOA SHOW EXCP IN PROGRESS @OZ41000 T5492700 HAMSIO1 LM R0,R15,0(R13) RESTORE REGISTERS @OZ41000 T5492750 BR R14 RETURN TO CONTINUE EXCP @OZ41000 T5492800 SPACE 2 @OZ41000 T5492850 * T5493000 * ABNORMAL CHANNEL END APPENDAGE T5493500 * T5494000 HAMCEX DS 0H T5494500 USING *,R15 SET LOCAL ADDRESSABILITY. T5495000 TM 4(R2),X'20' IF NOT FINAL ENTRY, T5495500 BNZR R14 RETURN IMMEDIATELY. T5496000 STM R0,R15,0(R13) SAVE REGISTERS. T5496500 L R12,=A(HCEBASE) SET PERMANENT BASE. T5497000 DROP R15 DROP TEMPORARY BASE. T5497500 LR R10,R2 COMPUTE AND SET T5498000 SL R10,=A(SDBIOB-SDBDSECT) SDB POINTER. T5498500 CLC SDBID,HCSDBID IF NOT AN SDB, T5499000 BNER R14 RETURN IMMEDIATELY. T5499500 L RSVT,SDBSVT SET POINTER TO SSVT. T5500000 OI SDBFLG2,SDB2IOE IF SDB, FLAG I/O ERROR T5500500 BR R12 AND CONTINUE. T5501000 EJECT T5501500 * T5502000 * CHANNEL END GET SERVICES - PERFORMED ONLY IF END-OF-UBUF T5502500 * T5503000 * T5503500 HCEGET DS 0H T5504000 L RBUF,SDBUBF POINT TO THE UNPROTECTED BUFFER. T5504500 USING BFD,RBUF SET BUFFER ADDRESSABILITY. T5505000 L R1,BFLENG PREPARE REGISTERS FOR @OZ30886 T5505150 HCEOBTST LR R2,R1 COMPARE AND SWAP @OZ30886 T5505300 N R1,=XL4'FFFF7FFF' RESET BF1EOB IN REG1 @OZ30886 T5505500 O R2,=XL4'00000080' TURN ON BF2IOC IN R2 @OZ30886 T5505750 CS R1,R2,BFLENG IF BF1EOB OFF, SET BF2IOC @OZ30886 T5506000 BE HCEGEND ON AND BRANCH @OZ30886 T5506125 TM BFFL1,BF1EOB DID A DIFFERENT BIT CHANGE @OZ30886 T5506250 BZ HCEOBTST TRY AGAIN IF SO @OZ30886 T5506375 CALL HENDREAD CHECK COMPLETION ETC. T5506500 TM SDBFLG2,SDB2IOE WAS THERE AN I/O ERROR... T5507000 BO HCRSPEC BRANCH IF NOT. T5507500 CALL HMOVEPU MOVE PROTECTED TO UNPROT ETC. T5508000 TM SDBFLG2,SDB2EOD IS THIS LAST OF INPUT... T5508500 BO HCRSPEC IF SO, JUST POST ECB. T5509000 CALL HCNVFDAD SET NEW FDAD IN IOB. T5509500 LA R11,BFECB POINT TO ECB TO POST T5510000 CALL HPOSTECB AND GO POST IT. T5510500 LA R15,8 SET RETURN TO RE-EXCP, T5511000 LA R0,1 INCREMENT T5511500 A R0,SDBXCPCT EXCP T5512000 ST R0,SDBXCPCT COUNTER, T5512500 B HCRETURN AND RETURN TO IOS. T5513000 SPACE 3 T5513500 * T5514000 * END OF READ - I/O ERROR OR END-OF-DATA T5514500 * T5515000 HCRSPEC DS 0H T5515500 LA R11,BFECB POINT TO UNPROT BUF ECB. T5516000 CALL HPOSTECB GO POST IT. T5516500 HCEGEND DS 0H T5517000 SLR R15,R15 SET POST RETURN CODE T5517500 B HCRETURN AND RETURN TO IOS. T5518000 EJECT T5518500 * T5519000 * T5519500 * CHANNEL END SERVICES FOR GET-UPDATE T5520000 * T5520500 * T5521000 HCEGUP DS 0H T5521500 USING LRCDSECT,R1 USE LOGICAL RECORD DSECT. T5522000 * T5522500 * FIND AND VALIDITY-CHECK PROTECTED BUFFER T5523000 * T5523500 L RBUF,SDBGBF POINT TO FIRST PROT BUFFER. T5524000 HCGUV1 L R1,BFBF POINT TO NEXT. T5524500 LTR R1,R1 IF NEXT IS ZERO, WE HAVE T5525000 BZ HCGUV2 THE BUFFER WE WANT. T5525500 LR RBUF,R1 ELSE MAKE NEXT CURRENT T5526000 B HCGUV1 AND LOOP. T5526500 HCGUV2 CLC BFKEY,SDBKEY IS BUFFER KEY CORRECT... T5527000 BNE HCGU80 IF NOT, SHOW ERROR. T5527500 * T5528000 * MOVE PROTECTED BUFFER TO LAST HOLD BUFFER T5528500 * T5529000 LA R4,BFIO POINT TO BUFFER I/O PORTION. T5529500 LH R5,$SVBFSIZ GET ITS LENGTH. R4 T5530000 L R1,BFECB POINT TO CORRESP UNPROT BUF. T5530500 LA R2,BFIO-BFD(,R1) POINT TO ITS I/O PORTION. T5531000 LR R3,R5 SET SINK LENGTH. T5531500 MVCL R2,R4 MOVE UPD-PROT TO UPD-UNPROT. T5532000 * T5532500 * IF THIS IS FIRST HOLD BUFFER FIND RECORD START T5533000 * T5533500 CL RBUF,SDBGBF IS THIS FIRST UPDATE BUFFER... T5534000 BNE HCGU10 BRANCH IF NOT. T5534500 LM R2,R3,SDBUPRBA LOAD REQUIRED RBA INTO R2,R3 T5535000 CALL HFINDRBA FIND REQUESTED LOGICAL RECORD. T5535500 BC 7,HCGU80 SHOW ERROR IF NOT FOUND. T5536000 LR R2,R1 TRANSFER REC ADR TO R2. T5536500 SLR R2,RBUF COMPUTE RECORD OFFSET. T5537000 L R3,BFECB POINT R3 TO UNPROT BUFFER. T5537500 ALR R2,R3 COMPUTE ADR OF IMAGE IN HBF. T5538000 ST R2,BFLOC-BFD(,R3) STORE THAT ADDRESS IN HBF. T5538500 SLR R15,R15 ASSUME RECORD NOT SPANNED. T5539000 TM LRCFLAG1,LRC1SPAN IS THIS A SPANNED RECORD... T5539500 BZ HCRETURN IF NOT, RETURN TO POST. T5540000 TM LRCFLAG1,LRC1SEND YES. IS THIS LAST SEGMENT... T5540500 BO HCRETURN IF SO, RETURN TO POST. T5541000 B HCGU20 ELSE READ ANOTHER RECORD. T5541500 * T5542000 * NOT FIRST HOLD BUFFER - IF END, RETURN T5542500 * T5543000 HCGU10 L R3,BFECB POINT TO HBF (UPDATE-UNPROT). T5543500 LA R1,BFDAT-BFD(,R3) SET DATA IMAGE ADDRESS T5544000 ST R1,BFLOC-BFD(,R3) IN IT. T5544500 TM LRCFLAG1,LRC1SPAN IS THIS A SPANNED RECORD... T5545000 BZ HCGU80 SHOW ERROR IF NOT. T5545500 SLR R15,R15 ASSUME LAST SEGMENT. T5546000 TM LRCFLAG1,LRC1SEND IS THIS THE LAST SEGMENT... T5546500 BO HCRETURN IF SO, RETURN TO POST. T5547000 * T5547500 * GET MORE BUFFERS AND READ NEXT RECORD T5548000 * T5548500 HCGU20 DS 0H T5549000 $GETBUF TYPE=PROT GET A NEXT PROTECTED BUFFER. T5549500 BNZ HCGU85 BRANCH IF NO STORAGE. T5550000 ST R1,BFBF POINT CURRENT TO NEXT. T5550500 MVI BFID-BFD(R1),C'G' SHOW UPDATE-PROTECTED. T5551000 SLR R0,R0 ZERO NEXT PROTECTED BUFFER'S T5551500 ST R0,BFBF-BFD(,R1) CHAIN ADDRESS. T5552000 MVC BFTRK-BFD(,R1),BFNXT SET NEXT BUF TRACK ADDRESS. T5552500 $GETBUF TYPE=UNPROT GET A NEXT UNPROTECTED BUFFER. T5553000 BNZ HCGU85 BRANCH IF NO STORAGE. T5553500 LR R5,RBUF POINT R5 TO CURRENT PROT BUF. T5554000 L RBUF,BFECB POINT RBUF TO CURR UNPROT BUF. T5554500 ST R1,BFBF POINT CURR TO NEXT UNPROT. T5555000 MVI BFID-BFD(R1),C'H' SHOW UPDATE-UNPROTECTED. T5555500 SLR R0,R0 ZERO NEXT UNPROTECTED BUFFER'S T5556000 ST R0,BFBF-BFD(,R1) CHAIN ADDRESS. T5556500 L RBUF,BFBF-BFD(,R5) POINT RBUF TO NEXT PROT. T5557000 ST R1,BFECB POINT NEXT PROT TO NEXT UNPROT. T5557500 MVC SDBMTTR,BFTRK MOVE MTTR FROM NEXT PROT T5558000 CALL HCNVFDAD FOR CONVERSION, AND CONVERT. T5558500 LA R1,BFIO POINT TO I/O AREA @OZ43706 T5558510 ICM R1,8,SDBCCW4 GET COMMAND CODE @OZ43706 T5558520 ST R1,SDBCCW4 STORE NEW CCW @OZ43706 T5558530 LA R15,8 RETURN FROM CE APPENDAGE T5559000 B HCRETURN TO CAUSE RE-EXCP. T5559500 SPACE 1 T5560000 HCGU80 OI SDBFLG2,SDB2IOE SHOW I/O ERROR R4 T5560100 MVC SDBSAVE,=A(HERRDERD) SET ERROR ADDRESS. T5561500 SLR R15,R15 DON'T RESTART. T5562000 B HCRETURN RETURN. T5562500 HCGU85 DS 0H T5563000 OI SDBFLG2,SDB2IOE SHOW I/O ERROR. T5563500 MVC SDBSAVE,=A(HERSTOR) SET ERROR ADDRESS. T5564000 SLR R15,R15 DON'T RESTART. T5564500 B HCRETURN RETURN. T5565000 EJECT T5565500 * T5566000 * T5566500 * CHANNEL END PUT SERVICES T5567000 * T5567500 * T5568000 HCEPUT DS 0H T5568500 * T5569000 * ADD BUFFERS FROM SDBPBFX TO CHAIN SDBPBF T5569500 * T5570000 L R1,SDBPBFX DECHAIN T5570500 SLR R0,R0 EVERYTHING T5571000 CS R1,R0,SDBPBFX ON CHAIN T5571500 BNE *-4 SDBPBFX. T5572000 LTR R1,R1 WAS CHAIN EMPTY... T5572500 BZ HCEP40 BRANCH IF SO. T5573000 SPACE 1 T5573500 LA RBUF,SDBPBF-(BFBF-BFD) CHAIN THROUGH T5574000 HCEP10 LR R3,RBUF THE SDBPBF T5574500 L RBUF,BFBF CHAIN TO FIND T5575000 LTR RBUF,RBUF THE LAST BUFFER T5575500 BNZ HCEP10 ON IT. (R3 PTS TO LAST BUF.) T5576000 SPACE 1 T5576500 HCEP20 LR RBUF,R1 SCAN SDBPBFX CHAIN, T5577000 SLR R5,R5 SAVING 2D-TO-LAST & LAST PTRS. T5577500 HCEP30 LR R4,R5 SAVE 2D-TO-LAST POINTER. T5578000 LR R5,RBUF SAVE LAST POINTER. T5578500 L RBUF,BFBF IF RBUF IS ZERO, T5579000 LTR RBUF,RBUF R4=2D-TO-LAST AND R5=LAST. T5579500 BNZ HCEP30 IF NOT, LOOP TILL SO. T5580000 * R5 POINTS TO LAST BUFFER ON SDBPBFX CHAIN T5580500 ST R5,BFBF-BFD(,R3) ADD THE BUF TO SDBPBF CHAIN. T5581000 LR R3,R5 SET R3 TO LAST BUF ON SDBPBF. T5581500 * R4 IS EITHER ZERO (END) OR PTR TO 2D-TO-LAST BUFFER. T5582000 LTR R4,R4 IF R4 IS ZERO, T5582500 BZ HCEP40 SDBPBFX CHAIN IS DONE. T5583000 ST R0,BFBF-BFD(,R4) ELSE SHOW 2D-LAST BUF IS LAST T5583500 B HCEP20 AND GO DECHAIN NEW LAST. T5584000 * T5584500 * DECHAIN 1ST SDBPBF AND PUT ON SDBFBF T5585000 * T5585500 HCEP40 DS 0H T5586000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T5586500 L RIOT,SDBAIOT POINT TO ALLOCATION IOT. T5587000 LA R0,IOTSTART POINT TO ITS I/O PORTION. T5587500 CLM R0,7,SDBCCW4+1 IF WE JUST WROTE IT, T5588000 BE HCEP50 DON'T FOR GOD SAKES FREE IT. T5588500 DROP RIOT DROP IOT BASE. T5589000 L RBUF,SDBPBF POINT TO FIRST BUF ON SDBPBF. T5589500 MVC SDBPBF,BFBF DECHAIN IT FROM SDBPBF. T5590000 OI BFFL1,BF1IOC SHOW I/O COMPLETE. T5590500 L R1,SDBFBF GET PTR TO OLD LAST SDBFBF. T5591000 ST R1,BFBF STORE PTR IN THIS BUF'S CHAIN. T5591500 CS R1,RBUF,SDBFBF SET NEW LAST SDBFBF. T5592000 BNE *-8 IF INTERFERENCE, STORE AGAIN. T5592500 * T5593000 * SHOW I/O COMPLETE AND HONOR EARLY POST REQUEST T5593500 * T5594000 ICM R11,15,SDBWAITQ ANY WAITS FOR EARLY POST.. @OZ37582 T5594500 BZ HCEP49 BRANCH IF NOT. @OZ37582 T5595000 SLR R15,R15 YES, CLEAR REG FOR SWAP @OZ37582 T5595500 HCEP45 CS R11,R15,SDBWAITQ DECHAIN ALL WAITERS @OZ37582 T5595600 BNE HCEP45 A NEW ONE, TRY AGAIN @OZ37582 T5595700 HCEP48 L R4,4(R11) SAVE ADDRESS OF NEXT ONE @OZ37582 T5595800 CALL HPOSTECB POST CURRENT ONE @OZ37582 T5595900 LTR R11,R4 IS THERE A NEXT ONE... @OZ37582 T5596000 BNZ HCEP48 YES, GO POST IT @OZ37582 T5596500 HCEP49 L RSVT,SDBSVT RESTORE SSVT POINTER. @OZ37582 T5596600 * T5597000 * START I/O FOR NEXT PROTECTED BUFFER T5597500 * T5598000 HCEP50 DS 0H T5598500 L RIOT,SDBAIOT POINT TO ALLOCATION IOT. T5599000 LTR RIOT,RIOT IF IT DOESN'T EXIST, T5599500 BZ HCEP55 CONTINUE NORMALLY. T5600000 USING IOTDSECT,RIOT SET IOT ADDRESSABILITY. T5600500 TM IOTFLAG1,IOT1CKPT DOES IT NEED WRITING... T5601000 BZ HCEP55 IF NOT, CONTINUE NORMALLY. T5601500 NI IOTFLAG1,255-IOT1CKPT RESET CHECKPOINT FLAG. T5602000 LA R0,IOTSTART SET IOT ADDRESS T5602500 STCM R0,7,SDBCCW4+1 IN SDBCCW4. T5603000 MVC SDBMTTR,IOTTRACK CONVERT T5603500 CALL HCNVFDAD TRACK ADDRESS. T5604000 LA R15,8 SET RETURN TO +8. T5604500 B HCRETURN RETURN TO EXCP. T5605000 DROP RIOT DROP IOT BASE. T5605500 HCEP55 DS 0H T5606000 L RBUF,SDBPBF POINT TO NEXT PBF FOR I/O. T5606500 LTR RBUF,RBUF CAN WE START AN I/O... T5607000 BZ HCEP60 BRANCH IF NOT. T5607500 MVC SDBMTTR,BFTRK MOVE RELATIVE TRACK AND T5608000 CALL HCNVFDAD CONVERT IT TO ABSOLUTE. T5608500 LA R0,1 INCREMENT T5609000 AL R0,SDBXCPCT EXCP T5609500 ST R0,SDBXCPCT COUNTER. T5610000 LA R0,BFIO SET BUFFER I/O ADDRESS T5610500 STCM R0,7,SDBCCW4+1 INTO WRITE-DATA CCW. T5611000 LA R15,8 CAUSE RETURN TO RE-EXCP. T5611500 B HCRETURN RETURN TO IOS. T5612000 * T5612500 * NO BUFFERS LEFT. ALLOW SVCPUT TO ISSUE EXCP. T5613000 * T5613500 HCEP60 DS 0H T5614000 SLR R15,R15 CAUSE RETURN TO POST. T5614500 B HCRETURN RETURN TO IOS. T5615000 EJECT T5615500 * T5616000 * CHANNEL END POINT SERVICES T5616500 * T5617000 HCEPNT DS 0H T5617500 CALL HENDREAD CHECK I/O COMPLETION. T5618000 TM SDBFLG2,SDB2IOE IF I/O ERROR, T5618500 BO HCT800 BRANCH. T5619000 * SET SDBTRK, BFRBA (PBF) FROM SDBUPRBA. FIND RBA IN PBF. T5619500 L RBUF,SDBPBF POINT TO PROTECTED BUFFER. T5620000 USING BFD,RBUF SET BUFFER ADDRESSABILITY. T5620500 LM R2,R3,SDBUPRBA GET POINT TARGET RBA. T5621000 STM R2,R3,SDBTRK SET SDBTRK FROM IT. T5621500 STM R2,R3,BFRBA ALSO PROTECTED BFRBA. T5622000 CALL HFINDRBA SEARCH FOR LOGICAL RECORD. T5622500 LA LINK,HCRETURN SET EOB & RF EXIT ADDRESS R4 T5622600 BZ HCT100 BRANCH IF FOUND. T5623000 LA LINK,HCT820 SET EOB & NRF EXIT ADDRESS R4 T5623100 SPACE 2 T5623500 * LOGICAL RECORD NOT FOUND IN THIS BUFFER --- T5624000 * UPDATE SDBRECCT, THE LOGICAL RECORD COUNTER T5624500 LCR R2,R3 GET NEG OF DECREMENTED COUNT. T5625000 L R15,BFRBA+4 UPDATE R4 T5625500 LA R15,0(R2,R15) THE LOGICAL R4 T5626000 AL R15,SDBRECCT RECORD R4 T5626500 ST R15,SDBRECCT COUNTER R4 T5627000 * UPDATE VALUE OF SDBUPRBA FOR NEXT PHYSICAL RECORD T5627500 L R0,BFNXT GET NEXT TRACK ADDRESS. T5628000 LTR R0,R0 IF IT'S ZERO, WE'RE AT EOF. T5628500 BZ HCT100 GO MOVE PBF TO UBF R4 T5629000 STCM R0,15,SDBUPRBA+1 ELSE SET NEXT TRACK AND T5629500 STCM R3,7,SDBUPRBA+5 DECR'D COUNT IN SDBUPRBA. T5630000 * EXIT TO READ NEXT PHYSICAL RECORD T5630500 ST R0,SDBMTTR SET TRK ADR TO CONVERT. T5631000 CALL HCNVFDAD CONVERT TO MBBCCHHR. T5631500 LA R15,8 SET +8 IOS RETURN. T5632000 B HCRETURN RETURN TO RESTART CHAN PROG. T5632500 SPACE 3 T5633000 * R1 POINTS TO THE TARGET LOGICAL RECORD T5633500 HCT100 DS 0H T5634000 * MOVE PROTECTED BUFFER TO UNPROTECTED BUFFER T5634500 L R7,SDBUBF R7 POINTS TO UNPROT BUFFER. T5635000 LA R4,BFIO-BFD(,R7) R4 IS UBF START-OF-MOVE. T5635500 LA R2,BFIO-BFD(,RBUF) R2 IS PBF START-OF-MOVE. T5636000 LH R3,$SVBFSIZ R3 IS LENGTH OF MOVE. R4 T5636500 LR R5,R3 SO IS R5. T5637000 MVCL R4,R2 MOVE PBF TO UBF. T5637500 * SET NEXT TRACK ADDRESS FOR CONVERSION. T5638000 MVC SDBMTTR,BFNXT SET NEXT TRACK FROM PBF. T5638500 * SET UP POINTERS AND FLAGS IN UNPROTECTED BUFFER. T5639000 SLR R1,R6 SUBTR PBF ADR FROM POSITION. T5639500 ALR R1,R7 ADD UBF ADR TO POSITION. T5640000 LR RBUF,R7 SET UBF ADDRESSABILITY. T5640500 ST R1,BFLOC SAVE POSITION IN UBF. T5641000 NI BFFL1,255-BF1EOB SHOW UBF NOT EMPTY. R4 T5641500 SLR R7,R1 COMPUTE (UBF START)-(POSN). T5642000 AH R7,$SVBFSIZ ADD USABLE R4 T5642500 AL R7,=A(BFIO-1-BFD) BUF LENG. R4 T5642800 ST R7,BFLEN SAVE REMAINING UBF LENGTH. T5643000 MVC BFRBA,SDBTRK SET CURRENT RBA IN UBF. T5643500 * IF DATA SET WAS OPENED FOR INPUT, READ AGAIN. T5644000 * OTHERWISE JUST RETURN FOR IOS TO POST. T5644500 SLR R15,R15 SET IOS RETURN +0. T5645000 ST R15,SDBSAVE SET COMPLETION CODE ZERO. T5645500 TM SDBFLG2,SDB2EOD IF INPUT DATA SET AT EOF, T5647000 BOR LINK GO SET UP HAM EXIT R4 T5647100 TM SDBFLG1,SDB1GET IF DATA SET NOT INPUT, R4 T5647600 BZ HCRETURN RETURN TO POST R4 T5647700 MVI SDBCHEND,SDBCEGET SET HCEGET APPENDAGE. T5648000 CALL HCNVFDAD CONVERT NEXT TRACK ADDRESS. T5648500 LA R15,8 SET IOS RETURN TO +8. T5649000 B HCRETURN RETURN TO RESTART CHAN PROG. T5649500 SPACE 3 T5650000 * I/O ERROR OR BAD DATA SET KEY FOUND BY HENDREAD T5650500 HCT800 DS 0H T5651000 L R0,=A(HERRDERD) SET ADDRESS OF HAM EXIT. T5651500 B HCT890 RETURN. T5652000 SPACE 2 T5652500 * END-OF-DATASET FOUND BEFORE END-OF-POINT T5653000 HCT820 DS 0H T5653500 L R0,=A(HERNOEOD) SET ADDRESS OF HAM EXIT. T5657500 SPACE 2 T5658000 * COMMON CODE FOR EXCEPTIONAL EXIT T5658500 HCT890 DS 0H T5659000 ST R0,SDBSAVE SAVE HAM EXIT ADDRESS. T5659500 SLR R15,R15 DO NOT RE-EXCP. T5660000 B HCRETURN RETURN FOR POSTING. T5660500 EJECT T5661000 * T5661500 * EXIT FROM CHANNEL END T5662000 * T5662500 HCRETURN DS 0H T5663000 LTR R15,R15 IF NO RESTART, T5663500 BZ HCRET20 GO RESET I/O-ACTIVE FLAG. T5663600 L R1,4(,R13) RESTART. POINT TO RQE, T5663700 L R1,28(,R1) THENCE TO SRB/IOSB, T5663800 L R1,28(,R1) GET IOSB ADDRESS R4 T5663900 L R1,IOSIPIB-IOSB(,R1) GET IPIB ADDRESS R4 T5664000 LTR R1,R1 IF IPIB NOT PRESENT, T5664100 BZ HCRET40 RESTART IS OKAY. T5664200 OI SDBFLG1,SDB1BFXS SHOW BUFFER EXCESSION OKAY. T5664300 SLR R15,R15 DON'T REDRIVE I/O. T5664400 HCRET20 DS 0H T5664500 NI SDBFLG2,255-SDB2IOA SHOW I/O INACTIVE. T5664600 ICM R11,15,SDBWAITQ ANY WAITS FOR EARLY POST.. @OZ37582 T5664700 BZ HCRET40 BR IF NO @OZ37582 T5664750 SLR R15,R15 YES, CLEAR REG FOR SWAP @OZ37582 T5664800 HCRET25 CS R11,R15,SDBWAITQ DECHAIN ALL WAITERS @OZ37582 T5664850 BNE HCRET25 A NEW ONE, TRY AGAIN @OZ37582 T5664900 HCRET30 L R4,4(R11) SAVE ADDRESS OF NEXT ONE @OZ37582 T5664950 CALL HPOSTECB POST CURRENT ONE @OZ37582 T5665000 LTR R11,R4 IS THERE A NEXT ONE... @OZ37582 T5665050 BNZ HCRET30 YES, GO POST IT @OZ37582 T5665100 SLR R15,R15 RESET FOR NO RESTART @OZ37582 T5665150 HCRET40 DS 0H R4 T5665200 LTR R15,R15 TEST AGAIN FOR RE-EXCP. T5665300 LM R0,R14,0(R13) RESTORE REGISTERS BUT R15. T5665500 BZR R14 RETURN TO POST COMPLETE. T5666000 USING DEBBASIC,R3 ELSE SET DEB BASE. T5666500 SLR R10,R10 ZERO R10 FOR IC. T5667000 IC R10,32(,R2) GET EXTENT NUMBER FROM IOB. T5667500 SLL R10,4 MULTIPLY EXTENT BY 16. T5668000 LA R10,DEBSUCBA+2(R10) DEVELOP DEB EXTENT ADDRESS T5668100 SLR R7,R7 CLEAR REGISTER T5668200 ICM R7,3,0(R10) INSERT UCB ADDRESS T5668500 STH R7,2(,R1) SET RQEUCB. T5669000 L R10,28(,R1) POINT TO SRB/IOSB. T5669500 L R10,28(,R10) GET IOSB ADDRESS R4 T5670000 ST R7,IOSUCB-IOSB(,R10) SET IOSUCB R4 T5670100 B 0(R14,R15) RETURN TO OFFSET IN R15. T5670500 DROP R3 DROP DEB BASE. T5671000 SPACE 3 T5671500 * T5672000 * CONSTANTS T5672500 * T5673000 HCSDBID DC CL4'SDB',AL2(SDBLNG) T5673500 DROP RBUF DROP BUFFER ADDRESSABILITY. T5674000 EJECT T5674500 LTORG T5675000 TITLE 'SUBROUTINES FOR HAMSVC AND CE APDG' T5675500 * T5676000 * T5676500 * HENDREAD - VERIFY COMPLETION OF A READ T5677000 * T5677500 * T5678000 HENDREAD DS 0H T5678500 USING *,R15 ESTABLISH ADDRESSABILITY. T5679000 CLI SDBICMP,X'7F' WAS COMPLETION NORMAL... T5679500 BNE HERIOERR IF NOT, SHOW I/O ERROR. T5680000 L RPBF,SDBPBF YES. POINT TO PROTECTED BUFFER. T5680500 USING BFD,RPBF USE BUFFER DSECT. T5681000 CLC SDBKEY,BFKEY DOES KEY MATCH... T5681500 BNE HERIOERR IF NOT, SHOW I/O ERROR. T5682000 L R1,BFNXT YES. NOW CHECK FOR T5682500 LTR R1,R1 END-OF-DATA-SET. T5683000 BZ HEREOD IF ZERO, SHOW END-OF-DATA. T5683500 CLI BFNXT+3,0 IF RECORD NUMBER NON-ZERO, T5684000 BNER R14 RETURN TO CALLER. T5684500 * OTHERWISE, I/O ERROR. T5685000 SPACE 3 T5685500 HERIOERR DS 0H T5686000 OI SDBFLG2,SDB2IOE SHOW I/O ERROR T5686500 BR R14 AND RETURN. T5687000 SPACE 3 T5687500 HEREOD DS 0H T5688000 OI SDBFLG2,SDB2EOD SHOW END-OF-DATA T5688500 BR R14 AND RETURN. T5689000 SPACE 3 T5689500 DROP R15,RPBF T5690000 EJECT T5690500 * T5691000 * T5691500 * HPOSTECB - POST AN ECB ACCORDING TO MVM STANDARDS T5692000 * T5692500 * T5693000 HPOSTECB DS 0H T5693500 USING *,R15 T5694000 * T5694500 * POST ECB IN SAME MEMORY T5695000 * T5695500 LR R2,R14 SAVE RETURN ADDRESS. T5696000 LR R0,R10 SAVE ADDRESS OF DDT. T5696500 LR R3,R13 SAVE R13 IN R3. T5697000 L R10,=X'40000000' LOAD POST CODE. T5697500 L R1,0(,R11) GET ECB. T5698000 LTR R1,R1 IS ECB WAITING... T5698500 BM HPE010 BRANCH IF SO, TO POST. T5699000 CS R1,R10,0(R11) POST ECB IF STILL UNWAITING. T5699500 BE HPE020 BRANCH IF OK, TO AVOID POST. T5700000 HPE010 L R15,CVTPTR POINT TO CVT. T5700500 USING CVTMAP,R15 USE THE CVT DSECT. T5701000 L R15,CVT0PT01 POINT TO IEA0PT01. T5701500 BALR R14,R15 POST BY BRANCH ENTRY. T5702000 HPE020 LR R10,R0 RESTORE ADDRESS OF DDT. T5702500 L RSVT,SDBSVT RELOAD THE SVT BASE REGISTER. T5703000 LR R13,R3 RESTORE R13 FROM R3. T5703500 SLR R15,R15 SET R15 TO ZERO R4 T5703700 BR R2 RETURN TO CALLER. T5704000 DROP R15 DROP CVT ADDRESSABILITY. T5704500 EJECT T5705000 * T5705500 * T5706000 * HMOVEPU - MOVE PROTECTED BUFFER TO UNPROTECTED BUFFER T5706500 * T5707000 * T5707500 HMOVEPU DS 0H T5708000 USING *,R15 T5708500 USING BFD,RBUF USE THE BUFFER DSECT. T5709000 MVC SDBTRK+1(4),SDBMTTR SET CURRENT RBA IN DDT. T5709500 LA R0,1 SET RBA'S RECORD NUMBER T5710000 STCM R0,7,SDBTRK+5 TO 000001. T5710500 L R1,BFRBA+4 GET MAX+1 RECORD NR. T5711000 LA R1,0(,R1) CLEAN IT UP. T5711500 BCTR R1,0 COMPUTE MAX REC NR. T5712000 LTR R1,R1 DON'T USE IT T5712500 BNP HMOVPU20 UNLESS POSITIVE (IT, NOT YOU). T5713000 AL R1,SDBRECCT ADD NR OF RECS READ FROM T5713500 ST R1,SDBRECCT PREV BUFFER TO SDBRECCT. T5714000 HMOVPU20 DS 0H T5714500 MVC BFRBA,SDBTRK SET BFRBA FOR NEXT BUFFER. T5715000 LA R2,BFDAT POINT TO UBF DATA AREA AND T5715500 ST R2,BFLOC SET ADDRESS IN UBF. T5716000 LA R2,BFIO POINT TO START OF MOVE. T5716500 LH R3,$SVBFSIZ GET LENGTH OF SINK AREA. R4 T5717000 L R4,SDBPBF POINT TO PROTECTED BUFFER AND T5717500 MVC SDBMTTR,BFNXT-BFD(R4) MOVE NEXT TRACK AND T5718000 LA R4,BFIO-BFD(,R4) THENCE TO SOURCE DATA. T5718500 LR R5,R3 GET SOURCE LENGTH (SAME AS SINK). T5719000 MVCL R2,R4 MOVE SOURCE TO SINK. T5719500 NI BFFL1,255-BF1EOB SHOW NOT END-OF-BUFFER. R4 T5720000 BR R14 RETURN TO CALLER. T5720500 DROP R15 DROP LOCAL ADDRESSABILITY. T5721000 EJECT T5721500 * T5722000 * T5722500 * HCNVFDAD - CONVERT MTTR TO MBBCCHHR T5723000 * T5723500 * MTTR IS GOT FROM DDTMTTR T5724000 * MBBCCHHR IS PUT IN DDTIFDAD T5724500 * T5725000 * T5725500 HCNVFDAD DS 0H T5726000 USING *,R15 ESTABLISH ADDRESSABILITY. T5726500 MVI SDBIFDAD+1,X'FF' SET FALSE FDAD TO CAUSE T5727000 CLC SDBMTTR(1),$SVNUMDA POST OF X'42' IF R4 T5727500 BNLR R14 INVALID EXTENT. R4 T5728000 L R3,SDBMTTR PREPARE TO SET MBBCCHHR IN IOB. T5728500 LA R0,0(,R3) GET MTTR, ISOLATE TTR IN R0. T5729000 XR R3,R0 ISOLATE M IN R3. T5729500 ST R3,SDBIFDAD SET 'M000' IN THE IOB. T5730000 STC R0,SDBIFDAD+8 SET RECORD NR TOO FAR RIGHT. T5730500 SRL R3,24 SHIFT EXTENT NR FOR MULTIPLY. T5731000 MH R3,=AL2(TEDSIZ) COMPUTE ADR OF EXTENT DATA T5731500 AL R3,$SVTED APPLICABLE TO THIS EXTENT. R4 T5732000 USING TEDDSECT,R3 USE DSECT TO ADDRESS IT. T5732500 SRDL R0,40 SHIFT 'TT' FOR DIVIDE. T5733500 D R0,TNTC COMPUTE CYLINDER AND HEAD NUMBERS. T5734000 STH R1,SDBIFDAD+4 SET CYLINDER NUMBER TOO FAR RIGHT. T5734500 STH R0,SDBIFDAD+6 SET HEAD NUMBER TOO FAR RIGHT. T5735000 MVC SDBIFDAD+3(5),SDBIFDAD+4 SHIFT CCHHR LEFT ONE BYTE. T5735500 * ADD ONE TO INPUT/OUTPUT SERVICE MEASURE T5736000 L R4,PSAAOLD-PSA POINT TO CURRENT ASCB. T5736500 USING ASCB,R4 SET ASCB ADDRESSABILITY. T5737000 L R0,ASCBIOSM GET CURRENT IOSM - BYTES 0,1. T5737500 HCNVIOSM DS 0H T5738000 LR R2,R0 MOVE IT TO UPDATE REGISTER. T5738500 AL R2,=FS16'1' ADD 1 TO SERVICE MEASURE. T5739000 CS R0,R2,ASCBIOSM STORE NEW MEASURE. T5739500 BNE HCNVIOSM REPEAT IF INTERFERENCE. T5740000 DROP R4 DROP ASCB ADDRESSABILITY. T5740500 * SET UP SET-SECTOR COMMAND FOR ROTATIONAL POSITION SENSING T5741000 MVI SDBCCW1,3 ASSUME NOT RPS. T5741500 L R1,TRPS POINT TO EXTENT'S RPS TABLE. T5742000 LTR R1,R1 IS POINTER ZERO... T5742500 BZR R14 IF SO, RETURN. T5743000 SR R3,R3 THIS IS AN RPS DEVICE. T5743500 IC R3,SDBMTTR+3 GET RECORD NUMBER AND T5744000 IC R3,0(R1,R3) THEN SECTOR NUMBER. T5744500 STC R3,SDBCCW1+5 PUT SECTOR NUMBER IN 1ST CCW T5745000 MVI SDBCCW1,X'23' AND MAKE CCW A SET-SECTOR. T5745500 BR R14 THEN RETURN. T5746000 SPACE 1 R4 T5746500 LTORG T5747000 DROP , T5747500 TITLE 'GETMAIN/FREEMAIN SUBROUTINE' T5748000 * T5748500 * T5749000 * BRANCH-TYPE GETMAIN/FREEMAIN SUBROUTINE T5749500 * T5750000 * T5750500 HGFMAIN DS 0H T5751000 USING *,R15 T5751500 * T5752000 * SET PROTECTION KEY TO ZERO T5752500 * T5753000 MODESET EXTKEY=ZERO,SAVEKEY=(2) SAVE KEY, SET KEY ZERO. T5753500 LA R4,0(,R4) SAVE FORMER KEY T5754000 SLL R2,24 IN REGISTER 4, T5754500 OR R4,R2 BITS 0-3. T5755000 * T5755500 * SAVE REGISTERS PREPARATORY TO SETLOCK T5756000 * T5756500 LR R3,R11 SAVE REGISTER 11 IN REGISTER 3. T5757000 LR R7,R12 SAVE REGISTER 12 IN REGISTER 7. T5757500 LR R2,R13 SAVE REGISTER 13 IN REGISTER 2. T5758000 * T5758500 * ACQUIRE LOCAL LOCK AND SAVE RETURN CODE T5759000 * T5759500 HGF010 SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,RELATED=HGF020 T5760000 SLL R13,24 SAVE SETLOCK RETURN CODE T5760500 OR R4,R13 IN REGISTER 4 BITS 4-7. T5761000 * T5761500 * RESTORE REGISTERS AFTER SETLOCK T5762000 * T5762500 LR R11,R3 RESTORE REGISTER 11 FROM REG 3. T5763000 LR R12,R7 RESTORE REGISTER 12 FROM REGISTER 7. T5763500 LR R13,R2 RESTORE REGISTER 13 FROM REGISTER 2. T5764000 * T5764500 * LOAD CRBRANCH, TCB, AND ASCB ADDRESSES T5765000 * T5765500 LR R2,R4 SAVE CONTENTS OF R4 IN R2. T5766000 TM 0(R2),X'50' IS THIS BUFFER FREEMAIN... T5766500 BNO HGFB10 BRANCH IF NOT. T5767000 * BUFFER FREEMAIN - TCB, ASCB ARE USED FROM BUFFER T5767500 USING BFD,R1 USE THE BUFFER DSECT. T5768000 USING PSA,R0 USE PREFIX SAVE AREA DSECT @OZ42546 T5768050 L R3,PSATOLD POINT TO CURRENT TCB @OZ42546 T5768100 TM TCBPKF-TCB(R3),X'80' IF NOT PROBLEM PROGRAM @OZ42546 T5768150 BZ HGF015 STATE, BRANCH @OZ42546 T5768200 CLI 1(R2),X'F0' IS THIS A UBUF... @OZ42546 T5768250 BE HGFB10 ...BRANCH IF SO @OZ42546 T5768300 HGF015 L R4,BFTCB R4=TCB ADDRESS. @OZ42546 T5768500 B HGFB20 CONTINUE. T5769500 * OTHER OPERATION - TCB, ASCB ARE USED FROM IEATCBP T5770000 * THIS LINE DELETED BY APAR ===> @OZ42546 T5770500 HGFB10 EQU * @OZ43706 T5771000 ICM R4,15,PSATOLD GET CURRENT TCB @OZ43706 T5771010 BNZ HGFB102 R4=TCB IF TCB MODE @OZ43706 T5771020 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T5771030 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T5771040 * GET TCB FROM INPUT RQE IF UNDER SRB FOR CHAN-END @OZ43706 T5771050 HGFB101 L R4,4(R13) R4=RQE FROM CHANNEL-END @OZ43706 T5771060 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T5771069 L R4,RQETCB-RQE(R4) R4=TCB FROM RQE @OZ43706 T5771070 HGFB102 LR R3,R4 SAVE R4 @OZ43706 T5771080 USING TCB,R4 SET TCB ADDRESSABILITY. T5771500 L R4,TCBJSCB POINT TO TCB'S JSCB. T5772000 USING IEZJSCB,R4 SET JSCB ADDRESSABILITY. T5772500 L R4,JSCBACT POINT TO ACTIVE JSCB. T5773000 L R4,JSCBTCBP POINT THENCE TO TCB. T5773500 LTR R4,R4 IF NONZERO POINTER, T5774000 BNZ *+6 KEEP IT @OZ43706 T5774500 LR R4,R3 RESTORE TCB ADDRESS @OZ43706 T5775000 TM 0(R2),X'18' IS TCB SUPPLIED FOR FREEMAIN... T5775500 BNO *+8 SKIP IF NOT. T5776000 L R4,0(,R1) USE USER-SUPPLIED TCB. T5776500 DROP R4 DROP JSCB BASE. T5777000 HGFB20 L R7,PSAAOLD R7 = ASCB ADDRESS. T5777500 * SINCE R15 IS OUR BASE, POINT TO CRBRANCH WITH R14. T5778000 L R3,CVTPTR POINT TO CVT T5778500 USING CVT,R3 AND USE DSECT. T5779000 L R14,CVTCRMN LOAD ADDRESS OF CRBRANCH. T5779500 * T5780000 * SET UP ARGUMENTS - R0, R1, AND R3 T5780500 * T5781000 DROP R0,R1,R3 DROP ADDRESSABILITIES. T5781500 L R3,0(,R2) R3 = KEY, SUBPOOL, TYPE. T5782000 LTR R3,R3 SET CC=1 IF R0 ALREADY SET. T5782500 LA R3,0(,R3) ZERO OUR FLAG BYTE IN R3. T5783000 BM *+8 SKIP IF R0 IS ALREADY SET. T5783500 L R0,4(,R2) R0 = LENGTH. T5784000 * R1 IS ALWAYS SET IN MACRO-EXPANSION. T5784500 CLI 1(R2),X'F0' ARE WE TO USE TCBPKF AS KEY... T5785000 BNE HGFB201 NO @OZ43706 T5785500 ICM R3,15,PSATOLD-PSA GET CURRENT TCB @OZ43706 T5785510 BNZ HGFB203 BR IF IN TCB MODE @OZ43706 T5785520 * GET TCB FROM INPUT RQE IF UNDER SRB FOR CHAN-END @OZ43706 T5785530 L R3,4(R13) GET RQE ADDR FROM INPUT @OZ43706 T5785540 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T5785550 L R3,RQETCB-RQE(R3) GET TCB FROM RQE @OZ43706 T5785560 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T5785570 * THIS LINE DELETED BY APAR NUMBER @OZ43706 T5786000 HGFB203 EQU * @OZ43706 T5786010 LR R15,R3 PUT TCB ADDRESS IN R15 @OZ43706 T5786020 L R3,0(,R2) RESTORE PARM @OZ43706 T5786030 LA R3,0(,R3) CLEAR HIGH BYTE @OZ43706 T5786040 USING TCB,R15 USE TCB DSECT, T5786500 ICM R3,4,TCBPKF AND PICK UP CURRENT KEY. T5787000 DROP R15 DROP TCB ADDRESSABILITY. T5787500 * T5788000 * CALL CRBRANCH T5788500 * T5789000 HGFB201 EQU * @OZ43706 T5789490 LR R15,R14 R15 POINTS TO CRBRANCH. T5789500 BALR R14,R15 CALL VIRT STORAGE SUPERVISOR. T5790000 USING *,R3 USE R3 AS LOCAL BASE. T5790500 LR R3,R14 SET R3 FROM R14 FOR BASE. T5791000 * T5791500 * IF BUFFER GETMAIN, INITIALIZE THE T5792000 * FOLLOWING FIELDS --- T5792500 * BFID TO C'XBF ' T5793000 * BFLENG TO CONTENTS OF R0 T5793500 * BFTCB TO CONTENTS OF R4 T5794000 * BFASCB TO CONTENTS OF R7 T5794500 * ALL OTHER FIELDS TO X'00' T5795000 * T5795500 LTR R15,R15 WAS CRBRANCH SUCCESSFUL... T5796000 BNZ HGFB30 BRANCH IF NOT. T5796500 TM 0(R2),X'20' WAS THIS A GETMAIN... T5797000 BZ HGFB30 BRANCH IF NOT. T5797500 ST R4,0(,R1) RETURN TCB ADDRESS TO CALLER. T5798000 STH R0,4(,R1) RETURN AREA LENGTH TO CALLER. R4 T5798300 TM 0(R2),X'40' WAS GETMAIN FOR BUFFER... T5798500 BZ HGFB30 BRANCH IF NOT. T5799000 USING BFD,R1 USE THE BUFFER DSECT. T5799500 XC 0(BFIO-BFD,R1),0(R1) CLEAR BUFFER UP TO BFIO. T5800000 MVC BFID,=CL4'XBF' SET BUFFER IDENTIFIER. T5800500 STH R0,BFLENG SET BUFFER LENGTH. T5801000 ST R4,BFTCB SET TCB ADDRESS IN BUFFER. T5801500 HGFB30 DS 0H CONTINUE. T5802500 * T5803000 * TEST LOCAL LOCK CONDITION UPON ENTRY T5803500 * T5804000 L R0,=X'0F000000' DID SETLOCK AT HGF010 T5804500 NR R0,R2 RETURN NONZERO CODE... T5805000 BNZ HGF030 IF SO, DON'T RELEASE LOCAL LOCK. T5805500 * T5806000 * SAVE REGISTERS PREPARATORY TO SETLOCK T5806500 * T5807000 LR R0,R11 SAVE REGISTER 11 IN REGISTER 0. T5807500 LR R4,R12 SAVE REGISTER 12 IN REGISTER 4. T5808000 LR R7,R13 SAVE REGISTER 13 IN REGISTER 7. T5808500 LR R3,R15 SAVE REGISTER 15 IN REGISTER 3. T5809000 * T5809500 * RELEASE LOCAL LOCK T5810000 * T5810500 HGF020 SETLOCK RELEASE,TYPE=LOCAL,RELATED=HGF010 T5811000 * T5811500 * RESTORE REGISTERS AFTER SETLOCK T5812000 * T5812500 LR R11,R0 RESTORE REGISTER 11 FROM REGISTER 0. T5813000 LR R12,R4 RESTORE REGISTER 12 FROM REGISTER 4. T5813500 LR R13,R7 RESTORE REGISTER 13 FROM REGISTER 7. T5814000 LR R15,R3 RESTORE REGISTER 15 FROM REG 3. T5814500 * T5815000 * RESTORE ORIGINAL PROTECT KEY T5815500 * T5816000 HGF030 DS 0H T5816500 BALR R3,0 RE-ESTABLISH R4 T5816600 USING *,R3 LOCAL BASE R4 T5816700 LR R4,R2 RESTORE CALLER'S LINK REGISTER. T5817000 SRL R2,24 SET KEY IN R2 BITS 24-27. T5817500 MODESET KEYADDR=(2) RESTORE ORIGINAL PROTECT KEY. T5818000 * T5818500 * RETURN TO CALLER WITH CODE IN REGISTER 15 T5819000 * T5819500 TM 0(R4),X'80' SET CC=3 IF LENGTH IN R0. T5820000 LA R4,4(,R4) BUMP RETURN PAST R3 PARAMETER. T5820500 BO *+8 SKIP IF NO ASSEMBLED LENGTH. T5821000 LA R4,4(,R4) BUMP RETURN PAST R0 PARAMETER. T5821500 LTR R15,R15 SET CONDITION CODE T5822000 BR R4 AND RETURN TO CALLER. T5822500 DROP R1,R3 DROP DSECT, BASE. T5823000 SPACE 3 T5823500 LTORG T5824000 TITLE 'HASP DIRECT ACCESS SPACE ALLOCATION ROUTINE' T5824500 SPACE 2 T5825000 *********************************************************************** T5825500 * * T5825600 * * T5825700 * $STRAK - SSSM VERSION OF SPOOL SPACE ALLOCATION * T5825800 * * T5825900 * * T5826000 * FUNCTION --- * T5826100 * * T5826200 * * T5826300 * (1) IF CALL IS FOR INITIAL ALLOCATION, A TRACK GROUP (TG) * T5826400 * IS OBTAINED FROM THE TRACK GROUP BLOCK (TGB) MAINTAINED * T5826500 * BY THE JES-II CHECKPOINT PROCESSOR. * T5826600 * * T5826700 * (2) IF CALL IS NOT FOR INITIAL ALLOCATION, AN ATTEMPT * T5826800 * IS MADE TO SUPPLY AN MTTR BASED ON THE TRACK CELL (TAB) * T5826900 * REFERENCED BY R1. IF SUCCESSFUL, THE MTTR IS RETURNED * T5827000 * IN R1. IF NOT, WE TRY TO OBTAIN A NEW TRACK CELL FROM * T5827100 * THE CURRENT TRACK GROUP. IF THIS IS SUCCESSFUL, AN * T5827200 * MTTR IS RETURNED IN R1. IF NOT, A SEARCH FOR A NEW TG * T5827300 * IS PERFORMED USING THE TGB. * T5827400 * * T5827600 * (3) IF THE TGB IS EMPTY, THE CALLER IS HELD IN ABEYANCE BY * T5827700 * ENQ/WAIT LOGIC. THE JES-II CHECKPOINT PROCESSOR IS * T5827800 * $$POSTED TO CAUSE A REFILLING OF THE TGB. * T5827900 * * T5828000 * * T5828100 * INPUT --- * T5828200 * * T5828300 * (1) R1 CONTAINS THE ADDRESS OF A TRACK ALLOCATION BLOCK (TAB) * T5828400 * * T5828500 * (2) THE THIRD WORD OF THE TAB IS USED TO GET THE ADDRESS OF * T5828600 * THE ALLOCATION IOT, WHICH IN TURN ALLOWS US TO GET THE * T5828700 * ADDRESS OF THE TRACK GROUP MAP. THE * T5828800 * FIRST WORD CONTAINS AN MTTR OF THE LAST ALLOCATED * T5828900 * BUFFER FROM THE TRACK CELL ASSIGNED TO THE TAB. THE * T5829000 * SECOND WORD CONTAINS A FLAG BYTE TO TELL WHAT KIND OF * T5829100 * TAB THIS IS, THE SUB-PERMUTATION NUMBER ASSOCIATED WITH * T5829200 * THE CURRENT TRACK CELL, THE MAXIMUM NBR OF RECORDS THAT * T5829300 * WILL FIT ON A TRACK IN THE CURRENT TRACK CELL, AND THE * T5829400 * NBR OF BUFFERS LEFT IN THE TRACK CELL. IF THE BUFFER * T5829500 * COUNT IS 0, AND THE LAST ALLOCATED BUFFER IS 0, THE CALL * T5829600 * IS FOR THE INITIAL ALLOCATION OF A BUFFER. * T5829700 * * T5829800 * * T5829900 * OUTPUT --- * T5830000 * * T5830100 * (1) R1 CONTAINS AN UPDATED MTTR. THIS IS THE SAME VALUE AS * T5830200 * IS SET IN THE FIRST WORD OF THE INPUT TAB. * T5830300 * * T5830400 * * T5830500 *********************************************************************** T5830600 EJECT T5843000 * T5843500 *********************************************************************** T5844000 * * T5844500 * $STRAK --- GET A NEW MTTR FOR CALLER. * T5845000 * * T5845500 *********************************************************************** T5846000 * * T5846500 USING TGMDSECT,R4 TGM ADDRESSABILITY R4 T5846600 USING TABDSECT,R10 TAB ADDRESSABILITY R4 T5846700 USING SSVT,R11 PROVIDE SSVT ADDRESSABILITY R4 T5846800 USING $STRAKWA,R13 SAVE AREA ADDRESSABILITY R4 T5846900 SPACE 1 R4 T5847000 $STRAK DS 0H T5847100 SAVE (14,12) SAVE REGISTERS. T5847500 BALR R12,0 ESTABLISH T5848000 USING *,R12 ADDRESSABILITY. T5848500 LR R10,R1 SETUP TABDSECT R4 T5848600 SLR R14,R14 SETUP FOR MINOR TAB USE R4 T5848700 TM TABFLAG,TABMAJOR TEST FOR MAJOR TAB R4 T5848800 BZ T1MINOR BR IF MINOR -- GO USE MASTER R4 T5848900 TM TABFLAG,TABMASTR IS THIS A MASTER TAB R4 T5849000 BO T1MASTR YES - GET ADDR OF TGM R4 T5849100 L R4,TABAIOT A(ALLOCATION IOT) FROM MAJOR TAB R4 T5849200 LA R4,IOTTGMAP-IOTDSECT(,R4) A(TGM) FOR TGMDSECT R4 T5849300 B T1RETRY GET READY FOR PROCESSING R4 T5849400 T1MINOR NULL R4 T5849500 LR R14,R10 SAVE A(MINOR TAB) FOR UPDATTING R4 T5849600 L R10,TABAIOT A(ALLOCATION IOT) R4 T5849700 LA R10,IOTMSTAB-IOTDSECT(,R10) A(MASTER TAB) R4 T5849800 T1MASTR NULL R4 T5849900 LR R4,R10 A(MASTER TAB) R4 T5850000 LA R4,IOTTGMAP-IOTMSTAB(,R4) A(TGM) FOR TGMDSECT R4 T5850100 EJECT R4 T5850200 T1RETRY DS 0H T5850300 LM R0,R1,TABMTTR GET OLD VALUES R4 T5850400 T1AGAIN DS 0H T5853000 LR R2,R0 GET TABMTTR THAT WE WILL WORK ON R4 T5853100 LR R3,R1 GET TABSPN ETC. ETC. R4 T5853200 ST R3,$SKFLD15 SETUP WORK AREA WITH TABFLAG+ R4 T5853300 * TABSPN+TABMAXR+TABUFCNT R4 T5853400 ICM R6,1,$SBUFCNT GET TABUFCNT AND SET CC R4 T5853500 BZ T1CELL NO BUFFERS - NEED A NEW TRAKCELL R4 T5853600 BCTR R6,0 SUBTRACT 1 FOR BUFFER WE'LL USE R4 T5853700 STC R6,$SBUFCNT MOVE BACK NEW TABUFCNT R4 T5853800 * T5855000 * RECORDS ON A TRACK ARE ASSIGNED IN T5855500 * A PERMUTED ORDER --- T5856000 * 1, T5856500 * 1+&RECINCR, T5857000 * 1+&RECINCR*2, T5857500 * ...., T5858000 * 2, T5858500 * 2+&RECINCR, T5859000 * 2+&RECINCR*2, T5859500 * ...., T5860000 * AND SO ON. T5860500 * ATTEMPT TO ASSIGN THE NEXT RECORD OF A T5861000 * SUB-PERMUTATION BY ADDING &RECINCR TO THE T5861500 * CURRENT RECORD NUMBER. T5862000 * T5862500 SLR R15,R15 CLEAR WORK REG R4 T5862600 IC R15,$SVRINCR PICK UP &RECINCR R4 T5862700 ALR R2,R15 ADD TO R OF TABMTTR R4 T5862800 CLM R2,1,$SBMAXR COMPARE R OF TABMTTR TO TABMAXR R4 T5862900 BNH T1SKIP NEW MTTR IS OK R4 T5863000 * WE'VE RUN OFF THE END OF THE TRACKR4 T5863100 IC R2,$SBSPN PICK UP TABSPN R4 T5863200 AL R2,=F'1' ADD 1 TO IT R4 T5863300 STC R2,$SBSPN MOVE BACK NEW TABSPN R4 T5863400 T1SKIP NULL R4 T5863500 L R3,$SKFLD15 GET UPDATTED TABUFCNT+TABSPN R4 T5863600 CDS R0,R2,TABMTTR SEE IF TAB CHANGED UNDER US R4 T5863700 BNE T1AGAIN YES - TRY AGAIN R4 T5863800 LTR R14,R14 DID WE HAVE A MINOR TAB R4 T5863900 BZ T1EXIT NO - RETURN R4 T5864000 ST R2,0(,R14) NEW VALUE OF TABMTTR R4 T5864100 STCM R3,7,5(R14) NEW VALUE OF TABUFCNT, ETC. R4 T5864200 T1EXIT NULL R4 T5864300 ST R2,$SKFLD1 PUT TABMTTR IN R1 IN SAVE AREA R4 T5864400 LM R14,R12,12(R13) RESTORE REGS R4 T5864500 SR R15,R15 SET R15 = 0, CC = 0 R4 T5864600 BR R14 RETURN TO CALLER R4 T5864700 EJECT R4 T5864800 T1CELL NULL R4 T5864900 LM R6,R7,TGMCYMXM GET OLD VALUES R4 T5865000 LR R8,R6 GET TGMCYMXM TO WORK ON R4 T5865100 LTR R9,R7 GET TGMCELL TO WORK ON R4 T5865200 BZ TBLOB NO TRAKCELL - 1ST TIME THRU R4 T5865300 ST R8,$SKFLD15 PUT TGMCYMXM IN WORK AREA R4 T5865400 CLM R9,1,$SMMAXR R OF TGMCELL GT MAX R OF TG R4 T5865500 BH T1TRACK YES - NO MORE TRAKCELLS ON TRACK R4 T5865600 SLR R5,R5 SETUP R5 AS CTR FOR TABUFCNT R4 T5865700 SLR R15,R15 USE TO HOLD &RECINCR R4 T5865800 IC R15,$SVRINCR GET &RECINCR R4 T5865900 T1LOOP NULL R4 T5866000 ALR R9,R15 ADD &RECINCR TO TGMCELL TO GET R4 T5866100 * MTTR OF NEXT BUFFER R4 T5866200 LA R5,1(,R5) INCREASE BUFFER COUNT R4 T5866300 T1CHECK NULL R4 T5866400 CLM R9,1,$SMMAXR R GONE PAST MAX R FOR THE TG R4 T5866500 BNH T1LOOPND NO - SEE IF WE HAVE &TCELSIZ R4 T5866600 CLM R8,8,$SVRINCR IS TGMSPN STILL VALID R4 T5866700 BNL T1CSTUNT NO - IS TRAKCELL TOO SMALL R4 T5866800 A R8,=FS24'1' ADD 1 TO TGMSPN R4 T5866900 ST R8,$SKFLD15 PUT IN WORK AREA R4 T5867000 IC R9,$SMSPN REPLACE R IN TGMCELL BY TGMSPN R4 T5867100 B T1CHECK MAKE SURE R STILL VALID R4 T5867200 T1LOOPND NULL R4 T5867300 CLM R5,1,$SVTKCEL DO WE HAVE A FULL TRAKCELL R4 T5867400 BL T1LOOP NO - COUNT ANOTHER BUFFER R4 T5867500 T1CEND NULL R4 T5867600 ST R14,$SKFLD15 SAVE R14 BECAUSE OF NEXT BAL R4 T5867700 ST R8,$SKFLD1 SAVE R8 BECAUSE OF NEXT BAL R4 T5867800 BAL R8,TGETLCL GET LOCAL LOCK R4 T5867900 CL R2,TABMTTR HAS TAB CHANGED R4 T5868000 BNE T1CABORT YES - TRY AGAIN R4 T5868100 CL R6,TGMCYMXM HAS TGM CHANGED R4 T5868200 BNE T1CABORT YES - TRY AGAIN R4 T5868300 CL R7,TGMCELL HAS TGM CHANGED R4 T5868400 BE T1CFINSH NO - FINISH UP ALLOCATION R4 T5868500 T1CABORT NULL R4 T5868600 BAL R8,TFREELCL FREE LOCAL LOCK R4 T5868700 L R14,$SKFLD15 RESTORE R14 R4 T5868800 B T1RETRY TRY IT AGAIN R4 T5868900 T1CFINSH NULL R4 T5869000 MVC TABMTTR,TGMCELL MTTR OF 1ST BUFFER IN NEW TRKCEL R4 T5869100 BCTR R5,0 1ST BUF ALREADY ALLOCATED R4 T5869200 STC R5,TABUFCNT MOVE BUFCNT INTO TABUFCNT R4 T5869300 MVC TABSPN,TGMCYMXM MOVE IN NEW SUB-PERM NBR R4 T5869400 MVC TABMAXR,TGMCYMXM+3 MOVE IN MAX R R4 T5869500 MVC TGMCYMXM(1),$SKFLD1 MOVE IN NEW SUB-PERM NBR R4 T5869600 ST R9,TGMCELL MOVE IN NEW TRAKCELL ADDR R4 T5869700 ICM R14,15,$SKFLD15 IS THERE A MINOR TAB R4 T5869800 BZ SKIP430 NO - SKIP COPY R4 T5869900 MVC 0(4,R14),TABMTTR COPY OVER DATA R4 T5870000 MVC 5(3,R14),TABSPN COPY OVER DATA R4 T5870100 SKIP430 L R2,TABMTTR GET MTTR OF ALLOCATED BUFFER R4 T5870200 BAL R8,TFREELCL FREE LOCAL LOCK R4 T5870300 B T1EXIT PREPARE TO RETURN R4 T5870400 T1CSTUNT NULL R4 T5870500 TM TABFLAG,TABMASTR IS THIS A MASTER TAB R4 T5870600 BO T1CEND YES - STUNTED TRAKCELL OK R4 T5870700 * NOTE THAT TAKING THIS BRANCH MAKESR4 T5870800 * R IN TGMCELL INVALID R4 T5870900 LR R15,R9 R15 = MTTR OF TGMCELL R4 T5871000 SRL R15,24 R15 = 000M R4 T5871100 MH R15,=AL2(TEDSIZ) R15 = M * TED SIZE R4 T5871200 AL R15,$SVTFRST R15 = ADDR OF TED ELEMENT R4 T5871300 CLM R5,1,TTCM+1-TEDDSECT(R15) COMP BUFCNT & MIN CELL SIZE R4 T5871400 BNL T1CEND STUNTED TRAKCELL BIG ENOUGH R4 T5871500 * NOTE THAT TAKING THE BRANCH MAKES R4 T5871600 * R IN TGMCELL INVALID R4 T5871700 CDS R6,R8,TGMCYMXM SEE IF TGM CHANGED UNDER US R4 T5871800 BNE T1RETRY YES - TRY AGAIN R4 T5871900 * NOTE THAT NOW THE STUNTED R4 T5872000 * TRAKCELL CANNOT BE ALLOCATED R4 T5872100 LR R6,R8 RESET WITH R4 T5872200 LR R7,R9 NEW VALUES R4 T5872300 T1TRACK NULL R4 T5872400 CLM R9,6,$SMTT TT OF TGMCELL WITH TT OF TGMC T5872500 BNL TBLOB NO MORE TRACKS IN TRACK GROUP R4 T5872600 AL R9,=FS8'1' ADD 1 TO TT OF TGMCELL R4 T5872700 IC R9,=X'01' MAKE R OF TGMCELL 1 R4 T5872800 ICM R8,8,=X'01' SET SUP-PERM BACK TO 1 R4 T5872900 CDS R6,R8,TGMCYMXM TGM CHANGED UNDER US R4 T5873000 BNE T1RETRY YES - TRY AGAIN R4 T5873100 B T1CELL NO - ALLOCATE A NEW TRAKCELL R4 T5873200 EJECT R4 T5873300 *********************************************************************** T5885500 * * T5886500 * GET LOCAL LOCK TO PREVENT SIMULT ALLOC * T5887500 * * T5888500 *********************************************************************** T5889500 SPACE 1 T5890500 TBLOB NULL R4 T5890600 LR R2,R0 SAVE ORIGINAL TABMTTR R4 T5890700 ST R14,$SKFLD1 SAVE BECAUSE OF NEXT BAL R4 T5890800 BAL R8,TGETLCL GET LOCAL LOCK R4 T5890900 CL R2,TABMTTR HAS TAB CHANGED R4 T5891000 BNE TBLOBOUT YES - TRY AGAIN R4 T5891100 CL R6,TGMCYMXM HAS TGM CHANGED R4 T5891200 BNE TBLOBOUT YES - TRY AGAIN R4 T5891300 CL R7,TGMCELL HAS TGM CHANGED R4 T5891400 BE TBLOBA NO - GET A NEW TG R4 T5891500 TBLOBOUT NULL R4 T5891600 BAL R8,TFREELCL FREE LOCAL LOCK R4 T5891700 L R14,$SKFLD1 RESTORE R14 R4 T5891800 B T1RETRY TRY IT AGAIN R4 T5891900 SPACE 1 T5897500 *********************************************************************** T5898500 * * T5899500 * ALLOCATE MTTR FROM TGB * T5900500 * * T5901500 *********************************************************************** T5902500 SPACE 1 T5903500 TBLOBA SLR R2,R2 R2 = 0 (FOR CDS) T5905500 SLR R3,R3 R3 = 0 (FOR CDS) T5906500 SL R4,=A(IOTTGMAP-IOTDSECT) FLAG R4 T5906800 OI IOTFLAG1-IOTDSECT(R4),IOT1CKPT IOT R4 T5907000 LA R4,IOTTGMAP-IOTDSECT(,R4) FOR CKPT R4 T5907300 TBLOBB LM R5,R7,$SVTTGBA R5=1ST, R4=SIZE,R6=LAST TGB T5907500 USING TGBDSECT,R5 TGB ADDRESSABILITY T5908500 TBLOBC LM R0,R1,TGBENTRY FETCH TGB ENTRY T5909500 LTR R1,R1 TEST FOR AVAILABLE TGB ENTRY T5910500 BZ TBLOBD BRANCH IF NOT AVAILABLE T5911500 CDS R0,R2,TGBENTRY TRY TO ALLOCATE ENTRY T5912500 BNE TBLOBB BRANCH IF TGB REPLENISHED T5913500 DROP R5 FORGET TGB T5914500 SPACE 1 T5915500 *********************************************************************** T5916500 * * T5917500 * TGB ALLOCATED. ESTABLISH TED ADDR * T5918500 * * T5919500 *********************************************************************** T5920500 SPACE 1 T5921500 LR R2,R1 R2 = MTTR T5922500 SRL R2,24 R2 = 000M T5923500 MH R2,=AL2(TEDSIZ) R2 = M * TED SIZE T5924500 AL R2,$SVTFRST R2 = ADDRESS OF TED T5925500 USING TEDDSECT,R2 TED ADDRESSABILITY T5926500 EJECT T5927500 *********************************************************************** T5928500 * * T5929500 * SHOW TRACK GROUP ALLOCATION IN USERS MAP * T5930500 * * T5931500 *********************************************************************** T5932500 SPACE 1 T5933500 LR R3,R0 R3 = OFFSET & BIT MASK T5934500 SRL R3,16 R3 = OFFSET TO ALLOCATION BYTE T5935500 IC R8,TGMAP(R3) R8 = MAP BYTE T5936500 OR R8,R0 SHOW ALLOCATION T5937500 STC R8,TGMAP(R3) FOR THIS TRACK GROUP T5938500 SPACE 1 T5939500 *********************************************************************** T5940500 * * T5941500 * DEVELOP NEW PTTR FROM MTTR & TED * T5942500 * * T5943500 *********************************************************************** T5944500 SPACE 1 T5945500 LR R0,R1 R0 = NEW MTTR T5946500 SRL R0,8 R0 = 0MTT T5947500 AH R0,TNTG R0 = MAX TT + 1 T5948500 BCTR R0,0 R0 = MAX TT T5949500 SLL R0,8 R0 = MAX TT0 T5950500 AH R0,TNRT R0 = MAX TTR T5951500 ICM R0,8,=X'01' R0 = PTTR T5952500 DROP R2 FORGET THE TED T5953500 SPACE 1 T5954500 *********************************************************************** T5955500 * * T5956500 * STORE NEW PTTR (MAX) & MTTR IN TGM * T5957500 * * T5958500 *********************************************************************** T5959500 SPACE 1 T5960500 LM R6,R7,TGMCYMXM GET CURRENT VALUES R4 T5960600 CDS R6,R0,TGMCYMXM MOVE IN NEW VALUES R4 T5960700 LM R0,R1,TABMTTR GET CURRENT VALUES R4 T5960800 LM R2,R3,TABMTTR GET CURRENT VALUES R4 T5960900 BAL R8,TFREELCL FREE LOCAL LOCK R4 T5961000 L R14,$SKFLD1 RESTORE R14 R4 T5961100 B T1CELL ALLOCATE A NEW TRAKCELL R4 T5961200 SPACE 1 T5966500 *********************************************************************** T5967500 * * T5968500 * PLOW THRU TGB. IF NO ENTRY, WAIT FOR JES-2 * T5969500 * * T5970500 *********************************************************************** T5971500 SPACE 1 T5972500 TBLOBD BXLE R5,R6,TBLOBC SEARCH TGB T5973500 BAL R8,TFREELCL RELEASE LOCAL LOCK T5974500 L R3,$SKFLD1 LOAD SAVED R14 INTO R3 R41 T5974600 MVC $SKFLD15(12),TENQLIST SET LIST FORM ENQ R4 T5974700 ENQ ($SVQNAM),MF=(E,$SKFLD15) R4 T5974800 $$POST TYPE=CKPW TELL JES-2 T5977500 NI $SVTGECB,X'7F' RESET WAIT BIT T5978500 MVC $SVTGASC+1(3),PSAAOLD+1-PSA SET ASCB T5979500 WAIT 1,ECB=$SVTGECB WAIT FOR CKPT PROCESS T5980500 MVI $SVTGECB,0 CLEAR ECB T5981500 MVC $SKFLD15(12),TDEQLIST SET LIST FORM DEQ R4 T5981600 DEQ ($SVQNAM),MF=(E,$SKFLD15) R4 T5981700 BAL R8,TGETLCL GET LOCAL LOCK T5984500 LR R14,R3 RESTORE R14 R41 T5984600 ST R14,$SKFLD1 SAVE AGAIN IN $SKFLD1 R41 T5984700 B TBLOBA GO ALLOCATE FROM TGB T5985500 SPACE 1 T5986500 TENQLIST ENQ (,T2MINOR,E,L'T2MINOR,SYSTEM),RET=HAVE,MF=L T5987500 TDEQLIST DEQ (,T2MINOR,L'T2MINOR,SYSTEM),MF=L T5988500 T2MINOR DC C'AWAITING SPOOL SPACE' T5989500 SPACE 2 R4 T5989600 DROP R4,R10,R13 DROP TGMDSECT, TABDSECT, $STRAKWA R4 T5989700 SPACE 1 R4 T5989800 $STRAKWA DSECT USE OS SAVE AREA AS A WORK AREA R4 T5989900 DS CL16 FIRST 4 WORDS R4 T5990000 $SKFLD15 DS CL4 R15 SAVE AREA R4 T5990100 ORG $SKFLD15 REDEFINE R4 T5990200 $SBFLAG DS CL1 TABFLAG R4 T5990300 $SBSPN DS CL1 TABSPN R4 T5990400 $SBMAXR DS CL1 TABMAXR R4 T5990500 $SBUFCNT DS CL1 TABUFCNT R4 T5990600 ORG $SKFLD15 REDEFINE R4 T5990700 $SMSPN DS CL1 TGMCYMXM R4 T5990800 $SMTT DS CL2 . . R4 T5990900 $SMMAXR DS CL1 . . R4 T5991000 $SKFLD0 DS CL4 R0 SAVE AREA R4 T5991100 $SKFLD1 DS CL4 R1 SAVE AREA R4 T5991200 HASPSSSM CSECT R4 T5991300 TITLE 'SETLOCK SUBROUTINES' T6176000 * T6176500 * SUBROUTINE TO GET LOCAL LOCK T6177000 * T6177500 TGETLCL SETLOCK OBTAIN,TYPE=LOCAL,MODE=UNCOND,REGS=USE, CT6178000 RELATED=($SVTGMAP,HASPSSSM(TFREELCL)) T6178500 BR R8 RETURN. T6179000 PRINT OFF - SECTION DELETED @OZ35278 T6179500 * THIS CARD DELETED BY APAR @OZ35278 T6180000 * THIS CARD DELETED BY APAR @OZ35278 T6180500 * THIS CARD DELETED BY APAR @OZ35278 T6181000 * THIS CARD DELETED BY APAR @OZ35278 T6181500 * THIS CARD DELETED BY APAR @OZ35278 T6182000 * THIS CARD DELETED BY APAR @OZ35278 T6182500 * THIS CARD DELETED BY APAR @OZ35278 T6183000 * THIS CARD DELETED BY APAR @OZ35278 T6183500 * THIS CARD DELETED BY APAR @OZ35278 T6184000 * THIS CARD DELETED BY APAR @OZ35278 T6184500 PRINT ON -- SECTION DELETED @OZ35278 T6185000 * T6185500 * SUBROUTINE TO FREE LOCAL LOCK T6186000 * T6186500 TFREELCL SETLOCK RELEASE,TYPE=LOCAL,REGS=USE, CT6187000 RELATED=($SVTGMAP,HASPSSSM(TGETLCL)) T6187500 BR R8 RETURN. T6188000 DROP , DROP ALL ADDRESSABILITY. T6188500 LTORG LITERAL POOL T6189000 DS 0D DOUBLEWORD BOUNDARY FOR PATCH. T6189500 SSMPATCH DC CL256'PATCH SPACE',CL256' ' PATCH AREA. T6190000 $DLENGTH $DLENGTH COMPUTE CONTROL SECTION LENGTH T6190500 APARNUM DC CL5'58848' APAR NUMBER T6190998 END T6191000