$JOB ASSIST MACRO=F 00000050 *********************************************************************** 00000100 * * 00000150 * SET OF JOBS - ILLUSTRATES MACRO PROCESSOR UNDER * 00000200 * REASONABLE AND NORMAL OPERATIONS - WITH SOME ACTUAL * 00000250 * PROGRAM WRITTEN PREVIOUSLY. * 00000300 *********************************************************************** 00000350 TITLE 'MACRO ILLUSTRATION TEST' 00000400 MACRO 00000450 &L @DOUB ®,&TIMES 00000500 AIF (&TIMES LT 1).ZERO 00000550 AIF (&TIMES EQ 1).AR 00000600 &L SLL ®,&TIMES 00000650 MEXIT 00000700 .AR ANOP 00000750 &L AR ®,® 00000800 .ZERO MEND 00000850 SPACE 3 00000900 MACRO 00000950 &L MULT &OUT,&IN,&BY 00001000 LCLA &X,&BP,&DC,&SL,&WORK 00001050 LCLC &AR,&SR 00001100 LCLB &B(33) 00001150 AIF (&BY NE 0).NOTZERO 00001200 MNOTE ,'*** MULT *** JUST WHAT ARE YOU TRYING TO DO ??? ***' 00001250 &L SR &OUT,&OUT 00001300 MEXIT 00001350 SPACE 1 00001400 .NOTZERO AIF (&BY GT 0).PLUS 00001450 LCR &OUT,&IN 00001500 &AR SETC 'SR' 00001550 &SR SETC 'AR' 00001600 &X SETA 0-&BY 00001650 AGO .CONVERT 00001700 .PLUS LR &OUT,&IN 00001750 &AR SETC 'AR' 00001800 &SR SETC 'SR' 00001850 &X SETA &BY 00001900 .CONVERT ANOP 00001950 &B(33) SETB (0) 00002000 &B(32) SETB (0) 00002050 &BP SETA 31 00002100 .CONLOOP ANOP 00002150 &WORK SETA &X 00002200 &X SETA &X/2 00002250 &WORK SETA &WORK-2*&X 00002300 &B(&BP) SETB (&WORK) 00002350 &BP SETA &BP-1 00002400 AIF (&BP GT 0).CONLOOP 00002450 AIF (&X NE 0).BLEWIT 00002500 &DC SETA 0 00002550 .FIRST ANOP 00002600 &BP SETA &BP+1 00002650 AIF ( NOT &B(&BP)).FIRST 00002700 .HEAD AIF (&B(&BP+1) AND &B(&BP+2)).SHIFTY 00002750 @DOUB &OUT,&DC 00002800 &AR &OUT,&IN 00002850 &DC SETA 1 00002900 &BP SETA &BP+1 00002950 AGO .FOOT 00003000 .SHIFTY ANOP 00003050 &WORK SETA &DC-1 00003100 @DOUB &OUT,&WORK 00003150 &DC SETA 1 00003200 &AR &OUT,&IN 00003250 &SL SETA 0 00003300 .SCAN ANOP 00003350 &SL SETA &SL+1 00003400 &BP SETA &BP+1 00003450 AIF (&B(&BP)).SCAN 00003500 SLL &OUT,&SL 00003550 &SR &OUT,&IN 00003600 .FOOT AIF (&B(&BP)).HEAD 00003650 &BP SETA &BP+1 00003700 &DC SETA &DC+1 00003750 AIF (&BP LT 32).FOOT 00003800 &WORK SETA &DC-2 00003850 @DOUB &OUT,&WORK 00003900 SPACE 2 00003950 MEXIT 00004000 .BLEWIT MNOTE 16,'*** MULT *** INTERNAL MACRO ERROR, SOMEBODY GOOFED' 00004050 MEND 00004100 SPACE 3 00004150 * THE CORRECT CODE FOR THE FOLLOWING MACRO IS AS FOLLOWS 00004200 * LR 1,2 1* 00004250 * SLL 1,5 (2**5)=32* 00004300 MULT 1,2,32 00004350 * THE CORRECT CODE FOR THE FOLLOWING MACRO IS AS FOLLOWS 00004400 * LR 2,3 1* 00004450 * SLL 2,2 (2**2)=4* 00004500 LABEL1 MULT 2,3,4 00004550 * THE CORRECT CODE FOR THE FOLLOWING MACRO IS AS FOLLOWS 00004600 * LR 5,4 1* 00004650 * AR 5,5 2* 00004700 * AR 5,4 +1=3* 00004750 THREE MULT 5,4,3 00004800 * THE CORRECT CODE FOR THE FOLLOWING MACRO IS AS FOLLOWS 00004850 * LR 6,8 1* 00004900 * SLL 6,6 (2**6)=64* 00004950 * SR 6,8 -1=63* 00005000 MULT 6,8,63 00005050 * THE FOLLOWING NUMBERS WERE PICKED OUT OF THE AIR SO WHO KNOWS 00005100 * WHAT THEY WILL PRODUCE, BUT IT CAN BE CHECKED 00005150 MULT 3,5,7238 00005200 MULT 5,6,5570 00005250 END 00005300 $JOB ASSIST MACRO=F 00005350 TITLE 'MACRO - PA DEMAINE - SOLID SYSTEM' 00005400 ******************************** REIDC *********************AUGUST/1970 00005450 MACRO 00005500 &J REIDC &FMT,&VAR,&LEN=$,&SAV=$,&MSG=$,&CC=0 00005550 *XXXXXXXXXXXXXXXXXXXXXXXXXXXX REIDC XXXXXXXXXXXXXXXXXXXXXXXXXXXX 00005600 *---REIDC IS THE CALLING ROUTINE FOR FORMATTED INPUT FROM CARDS. 00005650 *---&FMT IS THE LIST OF FORMATS TO BE USED DURING THE READ. 00005700 *---&VAR IS THE LIST OF VARIABLES TO BE READ (USE LIST FORM ). 00005750 *---&LEN IS A FULL WORD TO STORE THE NUMBER OF BYTES READ. 00005800 *---&SAV IS A SAVEAREA FROM USER OR DEFINED IN ROUTINE. 00005850 *---&MSG IS A 132 BYTE WORKAREA FOR PRINTING MESSAGES FROM READ. 00005900 *---&CC IS A CARRIAGE CONTROL CHARACTER TO BE USED WHEN PRINT. MESS. 00005950 *---------------------------------------------------------------------- 00006000 LCLA &FLG,&NV,&CFMT,&CVAR,&C1,&C2,&C3,&C4,&C5 00006050 LCLC &NAM1,&NAM2 00006100 SPACE 2 00006150 .* SET FLAG AND COUNT FOR SET SYMBOLS &FLG AND &NV. 00006200 &FLG SETA N'&SYSLIST 00006250 &NV SETA N'&VAR 00006300 .* CHECK IF THE COUNTS ARE IN THE PROPER RANGE. 00006350 AIF (K'&FMT EQ 0 OR K'&VAR EQ 0).ARGERR 00006400 AIF (&FLG LT 2 OR &FLG GT 6).ARGERR 00006450 AIF (&NV LT 1 OR &NV GT 8).VARERR 00006500 *** ALIGN THE CODE ON A WORD BOUNDARY. 00006550 CNOP 0,4 00006600 .* DETERMINE HOW THE SAVEAREA FOR REGISTERS IS TO BE SET UP. 00006650 AIF ('&SAV'(1,1) EQ '$').MAC1 00006700 .* USE SAVEAREA PROVIDED BY THE USER (&SAV). 00006750 &J STM 14,1,&SAV . *SAVE REGISTERS FOR I/O. 00006800 &FLG SETA 1 00006850 AGO .MAC2 00006900 .* DEFINE SAVEAREA WITHIN THIS MACRO. 00006950 .MAC1 ANOP 00007000 &J STM 14,1,DA&SYSNDX. . *SAVE REGISTERS FOR I/O. 00007050 &FLG SETA 2 00007100 .* CREATE ARGUMENT LIST FOR I/O ROUTINE. 00007150 .MAC2 ANOP 00007200 &C1 SETA 1 00007250 &C2 SETA 0 00007300 &C3 SETA 4 00007350 B EA&SYSNDX. . *BRANCH AROUND ARGUMENT LIST. 00007400 AA&SYSNDX DC F'&NV.' . *NUMBER OF VARIABLES TO BE READ. 00007450 DC A(CA&SYSNDX.) . *ADDRESS OF THE READ FORMATS. 00007500 .* CREATE ADDRESSES FOR EACH OF THE VARIABLES. 00007550 .MAC3 AIF ('&VAR(&C1)'(1,1) EQ '*').MAC4 00007600 AIF ('&VAR(&C1)'(1,8) EQ 'GENERATE').MAC3A 00007650 AIF ('&VAR(&C1)'(1,8) EQ 'NOSCREEN').MAC3A 00007700 AIF ('&VAR(&C1)'(1,7) EQ 'JLRSKIP').MAC3A 00007750 AIF ('&VAR(&C1)'(1,7) EQ 'NUMDIAG').MAC3A 00007800 AIF ('&VAR(&C1)'(1,7) EQ 'KLENGTH').MAC3A 00007850 AIF ('&VAR(&C1)'(1,7) EQ 'LLENGTH').MAC3A 00007900 AIF ('&VAR(&C1)'(1,7) EQ 'NEWFILE').MAC3A 00007950 AIF ('&VAR(&C1)'(1,6) EQ 'JLGATE').MAC3A 00008000 AIF ('&VAR(&C1)'(1,6) EQ 'JVALUE').MAC3A 00008050 AIF ('&VAR(&C1)'(1,6) EQ 'MVALUE').MAC3A 00008100 AIF ('&VAR(&C1)'(1,6) EQ 'RSKIPS').MAC3A 00008150 AIF ('&VAR(&C1)'(1,6) EQ 'NTASKS').MAC3A 00008200 AIF ('&VAR(&C1)'(1,6) EQ 'SECURE').MAC3A 00008250 AIF ('&VAR(&C1)'(1,6) EQ 'LEXCON').MAC3A 00008300 AIF ('&VAR(&C1)'(1,6) EQ 'OUTPXT').MAC3A 00008350 AIF ('&VAR(&C1)'(1,6) EQ 'RNOSEG').MAC3A 00008400 AIF ('&VAR(&C1)'(1,5) EQ 'TGATE').MAC3A 00008450 AIF ('&VAR(&C1)'(1,5) EQ 'NJOBS').MAC3A 00008500 AIF ('&VAR(&C1)'(1,5) EQ 'NFORM').MAC3A 00008550 AIF ('&VAR(&C1)'(1,5) EQ 'INPXT').MAC3A 00008600 AIF ('&VAR(&C1)'(1,5) EQ 'LEXNO').MAC3A 00008650 AIF ('&VAR(&C1)'(1,4) EQ 'RNOS').MAC3A 00008700 AIF ('&VAR(&C1)'(1,4) EQ 'MODE').MAC3A 00008750 AIF ('&VAR(&C1)'(1,2) EQ 'LJ').MAC3A 00008800 AIF ('&VAR(&C1)'(1,2) NE 'NV').MAC3B 00008850 .* ARGUMENT IS SYMBOLIC ADDRESS (USE VDCON FOR ADDRESS). 00008900 .MAC3A DC V(&VAR(&C1).) . *ADDRESS OF SYMBOLIC ARGUMENT. 00008950 AGO .MAC5 00009000 .* ARGUMENT IS SYMBOLIC ADDRESS (USE ADCON FOR ADDRESS). 00009050 .MAC3B DC A(&VAR(&C1).) . *ADDRESS OF SYMBOLIC ARGUMENT. 00009100 AGO .MAC5 00009150 .* ARGUMENT IS IN REGISTER NOTATION (DEFINE STORAGE FOR LATER USE). 00009200 .MAC4 DC F'0' . *ADDRESS FOR REGISTER NOTATION ARG. 00009250 &C2 SETA &C2+1 00009300 .* SEE IF ALL ARGUMENTS HAVE BEEN PROCESSED. 00009350 .MAC5 ANOP 00009400 &C3 SETA &C3+4 00009450 &C1 SETA &C1+1 00009500 AIF (&C1 LE &NV).MAC3 00009550 .* ARGUMENT LIST SET UP FOR VARIABLES - SEE IF PRINT MESSAGE IS WANTED. 00009600 AIF ('&MSG'(1,1) EQ '$').MAC6 00009650 .* PRINT OUT READ MESSAGE DURING EXECUTION. 00009700 .* DEFINE THE CARRIAGE CONTROL CHAR. AND ADDRESS OF MACRO BEGIN. 00009750 AIF ('&MSG'(1,1) EQ '*').MAC5A 00009800 &NAM1 SETC '&MSG' 00009850 DC CL1'&CC.',AL3(AA&SYSNDX.-8) 00009900 &C4 SETA 1 00009950 AGO .MAC5B 00010000 .MAC5A ANOP 00010050 &NAM1 SETC '&MSG'(2,8) 00010100 DC CL1'&CC.',AL3(0) 00010150 &C4 SETA 2 00010200 .MAC5B AIF ('&NAM1'(1,4) EQ 'DASH').MAC5C 00010250 AIF ('&NAM1'(1,5) EQ 'BLANK').MAC5C 00010300 AIF ('&NAM1'(1,5) EQ 'WORKA').MAC5C 00010350 DC A(&NAM1.) 00010400 AGO .MAC5D 00010450 .MAC5C DC V(&NAM1.) 00010500 .MAC5D ANOP 00010550 &C3 SETA &C3+8 00010600 AIF (&C4 EQ 2).MAC6 00010650 .* DEFINE STORAGE FOR THE VARIABLE LIST SYMBOLS. 00010700 &CVAR SETA (K'&VAR+1)/2*2 00010750 AIF (&CVAR LE 50).LESS 00010800 &CVAR SETA 50 00010850 .LESS ANOP 00010900 BA&SYSNDX DC CL&CVAR.'&VAR.' 00010950 .* DEFINE STORAGE FOR THE FORMAT LIST SYMBOLS. 00011000 .MAC6 ANOP 00011050 &CFMT SETA (K'&FMT+1)/2*2 00011100 CA&SYSNDX DC CL10'&FMT.' 00011150 .* DEFINE SAVEAREA FOR REGISTERS IF REQUESTED. 00011200 AIF (&FLG NE 2).MAC7 00011250 DS 0F 00011300 DA&SYSNDX DS 4F . *SAVEAREA FOR REGISTERS. 00011350 .* END OF STORAGE DEFINITION - CONTINUE EXECUTION. 00011400 .MAC7 ANOP 00011450 EA&SYSNDX EQU * . *CONTINUE EXECUTION AFTER ARG LIST. 00011500 AIF (&C2 EQ 0).MAC11 00011550 .* MUST LOAD ADDRESS OF REGISTER NOTATION ARGUMENTS. 00011600 &C1 SETA 1 00011650 &C5 SETA 8 00011700 .MAC8 AIF ('&VAR(&C1)'(1,1) NE '*').MAC10 00011750 &NAM1 SETC '&VAR(&C1)'(2,8) 00011800 &NAM2 SETC ' ' 00011850 AIF (K'&VAR(&C1)-9 LE 0).MAC9 00011900 &NAM2 SETC '&VAR(&C1)'(10,8) 00011950 .MAC9 LA 0,&NAM1&NAM2 . *LOAD ADDRESS OF VARIABLE. 00012000 ST 0,AA&SYSNDX.+&C5 . *STORE ADDRESS IN ARGUMENT LIST. 00012050 &C2 SETA &C2-1 00012100 .MAC10 ANOP 00012150 &C5 SETA &C5+4 00012200 &C1 SETA &C1+1 00012250 AIF (&C2 GT 0).MAC8 00012300 .* FINISHED LOADING ARGUMENT LIST - SET END OF LIST FLAG. 00012350 .* SEE IF AN ORG INSTRUCTION CAN MARK END OF ARGLIST. 00012400 .* IF PRINTING MESSAGES DURING EXECUTION, CAN USE ORG TO MARK LIST. 00012450 .MAC11 AIF ('&MSG'(1,1) EQ '$').MAC13 00012500 .* SET LOC COUNTER BACK TO MARK LIST END. 00012550 .MAC12 ORG AA&SYSNDX.+&C3. 00012600 DC X'80' . *TAG END END OF ARGUMENT LIST. 00012650 ORG 00012700 AGO .MAC14 00012750 .* IF LAST ARG IS NON-REGISTER NOTATION - CAN USE ORG TO TAG LIST. 00012800 .MAC13 AIF ('&VAR(&NV)'(1,1) NE '*').MAC12 00012850 .* LAST ARG USING REG NOTATION - GENERATE EXEC INSTR TO TAG LIST. 00012900 MVI AA&SYSNDX.+&C3.,X'80' . *TAG END OF LIST DURING EXEC. 00012950 .* PRINT READ MESSAGE DURING EXECUTION. 00013000 .MAC14 AIF (&C4 NE 1).MAC15 00013050 *** SET UP MESSAGE TO BE OUTPUT DURING THE READ OPERATION. 00013100 MVI &MSG.+52,C' ' . *BLANK OUT THE WORKAREA. 00013150 MVC &MSG.+53(79),&MSG.+52 00013200 MVC &MSG.(52),=CL52' **READ IN AFTER STATEMENT . INX00013250 FORMATION FOR' 00013300 MVC &MSG.+52(&CVAR.),BA&SYSNDX. . *MOVE IN VAR SYMBOLS. 00013350 MVC &MSG.+105(7),=CL7'FORMAT=' . *MOVE FORMAT INFO. 00013400 MVC &MSG.+113(&CFMT.),CA&SYSNDX. . *MOVE FORMAT SYMBOLS. 00013450 .MAC15 ANOP 00013500 *** BRANCH TO THE READ ROUTINE TO PERFORM THE READ OPERATION. 00013550 LA 1,AA&SYSNDX. . *LOAD ADDRESS OF ARGUMENT LIST. 00013600 L 15,=V(REID) . *LOAD ADDRESS OF SREID. 00013650 BALR 14,15 . *EXECUTE THE READ ROUTINE. 00013700 AIF ('&LEN'(1,1) EQ '$').MAC16 00013750 ST 0,&LEN . *RETURN LENGTH OF DATA TO USER. 00013800 .MAC16 AIF (&FLG EQ 2).MAC17 00013850 .* RELOAD REGISTERS FROM &SAV (USER SAVEAREA). 00013900 LM 14,1,&SAV . *RELOAD I/O REGISTERS. 00013950 AGO .MAC18 00014000 .* RELOAD REGISTERS FROM SAVEAREA DEFINED IN THIS ROUTINE. 00014050 .MAC17 LM 14,1,DA&SYSNDX. . *RELOAD I/O REGISTERS. 00014100 AGO .MAC18 00014150 .* ERROR IN ARGUMENT LIST - DO NOT GENERATE READ ROUTINE CODE. 00014200 .ARGERR MNOTE 2,'ARGUMENT LIST IMPROPERLY FORMED.' 00014250 AGO .ERR1 00014300 .* ERROR IN LIST OF VARIABLES - DO NOT GENERATE READ CODE. 00014350 .VARERR MNOTE 2,'NUMBER OF VARIABLES TO READ EXCEEDS LIMITS.' 00014400 .ERR1 ANOP 00014450 *** READ STATEMENT WILL BE REPLACED BY A 'NOPR 1' INSTRUCTION 00014500 *** DUE TO THE ERROR IN DEFINING MACRO PROTOTYPE. 00014550 &J NOPR 1 . *REPLACES THE READ STATEMENT. 00014600 .MAC18 ANOP 00014650 *XXXXXXXXXXXXXXXXXXXXXXXXXXXX END REIDC XXXXXXXXXXXXXXXXXXXXXXXXXXXX 00014700 SPACE 2 00014750 MEND 00014800 ******************************** REIDC ******************************** 00014850 USING *,15 00014900 REIDC *I,(X,Y,Z),LEN=JI,SAV=SAVEAREA,MSG=MESSAGE 00014950 JI DS F 00015000 X DS F 00015050 Y DS F 00015100 Z DS F 00015150 SAVEAREA DC 18F'0' 00015200 MESSAGE DS 33F 00015250 ENTRY REID 00015300 REID DS F 00015350 END 00015400 $JOB ASSIST MACRO=F 00015450 * ***NOTE*** ILLUSTRATES ERROR IN HANDKING OF KEYWORD DEFAULTS 00015500 * WHICH ARE ALSO SUBLISTS. 00015550 * EARLY ASSIGNMENT - CMPSC 411 - STUDENT-WRITTEN PROGRAM 00015600 * - DAVID COLEMAN - SUMMER 1972. 00015650 TITLE 'MACRO QSAVE' 00015700 MACRO 00015750 &NAME QSAVE ®S=(14,12),&BASE=12,&SA=* 00015800 .* 00015850 .********************************************************************** 00015900 .* 00015950 .* MACRO QSAVE - CS411 - SUMMER 72. 00016000 .* QSAVE IS A LINKAGE MACRO WRITTEN ACCORDING TO SPECS 00016050 .* IN CS411MC1. 00016100 .* &SA IS SPECIFIED AS IN PSU MACRO 'XSAVE'. 00016150 .* 00016200 .********************************************************************** 00016250 .* 00016300 GBLC &SAVE &SAVE USED BY QRETURN. 00016350 LCLA &LENGTH,&DISP,&LENGTH1 00016400 LCLC &NAME1,&BASER,&A 00016450 SPACE 00016500 USING *,15 . TEMPORARY BASE REGISTER. 00016550 .********************************************************************** 00016600 .* 00016650 .* GENERATE IDENTIFICATION FIELD. 00016700 .* 00016750 .********************************************************************** 00016800 &LENGTH SETA K'&NAME OBTAIN COUNT OF NAME FIELD. 00016850 &NAME1 SETC '&NAME' STORE NAME FIELD. 00016900 AIF (&LENGTH NE 0).ID BRANCH IF &NAME EXISTED. 00016950 &NAME1 SETC '&SYSECT' USE CSECT NAME INSTEAD. 00017000 .* COUNT CHARACTERS IN CSECT NAME. 00017050 .TOP ANOP 00017100 &LENGTH SETA (&LENGTH+1) ADD 1 TO COUNT. 00017150 AIF ('&SYSECT'(1,&LENGTH) EQ '&SYSECT'(1,&LENGTH+1)).ID 00017200 AGO .TOP LOOK FOR NEW CHARACTER. 00017250 .ID ANOP 00017300 &LENGTH1 SETA (&LENGTH/2*2+1) MAKE LENGTH ODD. 00017350 &NAME B 5+&LENGTH1.(,15) . BRANCH AROUND ID. 00017400 DC X'&LENGTH1' . ID CONVENTION. 00017450 DC CL&LENGTH1'&NAME1' 00017500 .********************************************************************** 00017550 .* 00017600 .* SAVE PASSED REGISTERS - ONLY ONE PAIR IS ALLOWED. 00017650 .* 00017700 .********************************************************************** 00017750 &DISP SETA (®S(1)-14) EXTABLISH DISPLACEMENT OF 1ST REG. 00017800 AIF (&DISP GE 0).POSITIV 00017850 &DISP SETA (&DISP+16) MAKE # POSITIVE. 00017900 .POSITIV ANOP 00017950 &DISP SETA (&DISP*4+12) THIS IS DISPLACEMENT. 00018000 STM ®S(1),®S(2),&DISP.(13) . SAVE PASSED REGISTERS. 00018050 .********************************************************************** 00018100 .* 00018150 .* LINK SAVE AREAS 00018200 .* 00018250 .********************************************************************** 00018300 &SAVE SETC '&SA' TO BE USED BY QRETURN. 00018350 AIF ('&SAVE' EQ 'NO').BASE 'NO'=NO SA LINKAGE. 00018400 AIF ('&SAVE' NE '*').LINK BRANCH IF NAME GIVEN. 00018450 &SAVE SETC '&SYSECT'(1,3).'&SYSNDX'.'S' GENERATE SAVE AREA NAME. 00018500 .LINK LA 15,&SAVE . GET SAVE AREA ADDRESS. 00018550 ST 15,8(13) . POINTER TO LOW SAVE AREA. 00018600 ST 13,4(15) . POINTER TO HIGH SAVE AREA. 00018650 LR 13,15 . ADDRESS OF LOW SAVE AREA. 00018700 .BASE ANOP 00018750 &BASER SETC '&BASE' 00018800 AIF (&BASE LE 12).USING BRANCH IF B.R. IS LEGAL. 00018850 MNOTE 4,'***WARNING*** REGISTER &BASE CANNOT BE USED AS A BASEX00018900 REGISTER: REGISTER 12 USED INSTEAD' 00018950 &BASER SETC '12' 00019000 .USING BALR &BASER,0 . SET UP NEW BASE. 00019050 DROP 15 DELETE TEMPORARY. 00019100 USING *,&BASER . NEW USING. 00019150 SPACE 00019200 MEND 00019250 TITLE 'MACRO QCALL' 00019300 MACRO 00019350 &NAME QCALL &ENTRY,&ARGS 00019400 .* 00019450 .********************************************************************** 00019500 .* 00019550 .* MACRO QCALL - CS411 - SUMMER 72. 00019600 .* QCALL IS A LINKAGE MACRO WRITTEN ACCORDING TO SPECS IN CS411MA 00019650 .* QCALL IS A LINKAGE MACRO WRITTEN ACCORDING TO SPECS 00019700 .* GIVEN IN CS411MC19 00019750 .* GIVEN IN CS411MC1. 00019800 .* 00019850 .********************************************************************** 00019900 .* 00019950 LCLA &KOUNT,&TEMPA 00020000 LCLC &LSTNAME 00020050 SPACE 00020100 &NAME DS 0H . PROVIDE LABEL IN GENERATED CODE. 00020150 .********************************************************************** 00020200 .* 00020250 .* DECIPHER ARGUMENT (2ND) OPERAND. 00020300 .* 00020350 .********************************************************************** 00020400 AIF (N'&ARGS EQ 0).BRANCH BRANCH IF 2ND OPERAND MISSINGC 00020450 AIF ('&ARGS'(1,1) NE '(').ADDNAME BRANCH IF NOT A SUBLIST. 00020500 &LSTNAME SETC 'LIST'.'&SYSNDX' CREATE UNIQUE ADDRESS LIST NAME. 00020550 AGO .LR1 00020600 .ADDNAME ANOP 00020650 &LSTNAME SETC '&ARGS' USE ADDRESS LIST NAME FROM MACRO. 00020700 .LR1 LA 1,&LSTNAME . R1==>ADDRESS OF ADDRESS LIST. 00020750 .********************************************************************** 00020800 .* 00020850 .* IS TRANSFER OF CONTROL WANTED. 00020900 .* 00020950 .********************************************************************** 00021000 .BRANCH AIF (N'&ENTRY EQ 0).STORE BRANCH IF NO TRANSFER WANTED. 00021050 L 15,=V(&ENTRY) . SUBROUTINE ADDRESS. 00021100 BALR 14,15 . CALL ROUTINE. 00021150 .********************************************************************** 00021200 .* 00021250 .* DECIDE IF ADDRESS MUST BE CREATED. 00021300 .* 00021350 .********************************************************************** 00021400 AIF (N'&ARGS EQ 0).END BRANCH IF NO ARGUMENTS PASSED. 00021450 .STORE AIF ('&ARGS'(1,1) NE '(').END BRANCH IF ARGS NOT LISTED. 00021500 &TEMPA SETA (4*N'&ARGS) SIZE OF ADDRESS LIST. 00021550 B &LSTNAME+&TEMPA . BRANCH AROUND ADDRESS LIST. 00021600 &KOUNT SETA 1 COUNTER FOR LOOP. 00021650 &LSTNAME DS 0F . TOP OF ADDRESS LIST. 00021700 .TOP AIF (&KOUNT EQ N'&ARGS).LAST BRANCH FOR NO MORE ARGS. 00021750 DC A(&ARGS(&KOUNT)) . PUT ADDRESS OF ARGUMENT INTO LIST. 00021800 &KOUNT SETA &KOUNT+1 00021850 AGO .TOP 00021900 .LAST DC X'80',AL3(&ARGS(&KOUNT)) . FLAG LAST ADDRESS. 00021950 .END ANOP 00022000 SPACE 00022050 MEND 00022100 TITLE 'MACRO QRETURN.' 00022150 MACRO 00022200 &NAME QRETURN ®S=(14,12),&SA= 00022250 .* 00022300 .********************************************************************** 00022350 .* MACRO QRETURN - CS411 - SUMMER 72. 00022400 .* QRETURN IS A LINKAGE MACRO WRITTEN ACCORDING TO SPECS 00022450 .* GIVEN IN CS411MC1. 00022500 .* SA IS APECIFIED SAME AS IN PSU MACRO 'XRETURN'. 00022550 .* 00022600 .********************************************************************** 00022650 .* 00022700 GBLC &SAVE CONTAINS INFO FROM MACRO QSAVE. 00022750 LCLA &DISP 00022800 SPACE 00022850 &NAME DS 0H . DEFINE LABEL. 00022900 AIF ('&SA' EQ 'NO').RGS BRANCH IF NO SAVE AREA PRESENT. 00022950 L 13,4(13) . RESTORE PREVIOUS SA POINTER. 00023000 .********************************************************************** 00023050 .* 00023100 .* RESTORE CALLING PROGRAM'S REGISTERS. 00023150 .* 00023200 .********************************************************************** 00023250 .RGS ANOP 00023300 &DISP SETA (®S(1)-14) ESTABLISH DISPLACEMENT IN SAVE AREA. 00023350 AIF (&DISP GE 0).POSITIV 00023400 &DISP SETA (&DISP+16) MAKE # POSITIVE. 00023450 .POSITIV ANOP 00023500 &DISP SETA (&DISP*4+12) THIS IS DISPLACEMENT. 00023550 LM ®S(1),®S(2),&DISP.(13) . RESTORE PASSED REGISTER. 00023600 MVI 12(13),X'FF' . FLAG RET IN HSA. 00023650 BR 14 . RETURN CONTROL TO CALLING PROGRAM. 00023700 .********************************************************************** 00023750 .* 00023800 .* DECIDE IF A SAVE AREA IS TO BE GENERATED. 00023850 .* 00023900 .********************************************************************** 00023950 AIF ('&SA' EQ 'NO').END BRANCH FOR NO. 00024000 AIF (K'&SA EQ 0).END DEFAULT 00024050 AIF ('&SA' EQ '*' OR '&SA' EQ '&SAVE').SKIP NEW LABEL? 00024100 &SA DS 0F . LABEL FROM QRETURN. 00024150 .SKIP ANOP 00024200 &SAVE DC 18F'0' DEFINE SAVE AREA. 00024250 .END ANOP 00024300 SPACE 00024350 MEND 00024400 TITLE 'TEST OF LINKAGE MACROS.' 00024450 MAINPRG CSECT 00024500 QSAVE REGS=(14,12) USE VALUES 00024550 QCALL SUBX,ADDRX 00024600 QCALL SUBY 00024650 GOBACK QRETURN SA=* 00024700 ADDRX QCALL ,(MAINPRG,GOBACK) 00024750 LTORG 00024800 SUBXCS CSECT 00024850 ENTRY SUBX,SUBY 00024900 SUBX QSAVE SA=SUBXSA 00024950 CNOP 2,4 CNOP FOR NASTINESS 00025000 QCALL SUB1,(SUBX) 00000050 QCALL SUB2 00000100 SUBRET QRETURN SA=SUBXSA 00000150 SUBY QSAVE SA=NO 00000200 XPRNT =CL50'0*** AT SUBY *****',50 00000250 QRETURN SA=NO 00000300 LTORG 00000350 SUB1 CSECT 00000400 QSAVE BASE=13 00000450 QRETURN SA=* 00000500 SUB2 CSECT 00000550 QSAVE BASE=15,REGS=(2,12) 00000600 QRETURN SA=*,REGS=(2,12) 00000650 $ENTRY 00000700 $JOB ASSIST MACRO=F 00000750 *********************************************************************** 00000800 *********************************************************************** 00000850 ********************************************************************** 00000900 * * 00000950 * FOLLOWING DECKS ILLUSTRATE MACROS FROM ASSEMBLER * 00001000 * MANUAL OR ELSE VARIOUS CONDTIONAL ASSEMBLY OPERATION. * 00001050 * * 00001100 ********************************************************************** 00001150 ********************************************************************** 00001200 ********************************************************************** 00001250 TITLE 'ILLUSTRATE MACROS: ASSEMBLER MANUAL SECTION 6' 00001300 MACRO 00001350 &NAME MOVE &TO,&FROM 00001400 &NAME ST 2,SAVE 00001450 L 2,&FROM 00001500 ST 2,&TO 00001550 L 2,SAVE 00001600 MEND 00001650 SPACE 1 00001700 MACRO 00001750 &NAME MOVE1 &TY,&P,&TO,&FROM 00001800 &NAME ST&TY 2,SAVEAREA 00001850 L&TY 2,&P&FROM 00001900 ST&TY 2,&P&TO 00001950 L&TY 2,SAVEAREA 00002000 MEND 00002050 SPACE 1 00002100 MACRO 00002150 &NAME MOVE2 &P,&S,&R1,&R2 00002200 &NAME ST &R1,&S.(&R2) 00002250 L &R1,&P.B 00002300 ST &R1,&P.A 00002350 L &R1,&S.(&R2) 00002400 MEND 00002450 SPACE 1 00002500 USING *,15 00002550 HERE MOVE FIELDA,FIELDB 00002600 LABEL MOVE IN,OUT 00002650 SAVE DS F 00002700 FIELDA DS D 00002750 FIELDB DS D 00002800 IN DS F 00002850 OUT DS F 00002900 SPACE 1 00002950 MOVE1 D,FIELD,A,B 00003000 SAVEAREA DS D 00003050 SPACE 2 00003100 HERE2 MOVE2 FIELD,SAVE,2,4 00003150 END 00003200 $JOB ASSIST MACRO=F 00003250 MACRO 00003300 ADDX &NUMBER,® 00003350 .* ILLUSTRATES SETA, SUBLISTS. 00003400 LCLA &LAST 00003450 &LAST SETA N'&NUMBER 00003500 L ®,&NUMBER(1) 00003550 A ®,&NUMBER(&LAST) 00003600 ST ®,&NUMBER(1) 00003650 MEND 00003700 SPACE 1 00003750 USING *,15 00003800 ADDX (A,B,C,D,E),3 00003850 A DS F 00003900 E DS F 00003950 END 00004000 $JOB ASSIST MACRO=F 00004050 MACRO 00004100 ATTRIB &ARG 00004150 .* THIS MACRO ILLUSTRATES ATTRIBUTES ALLOWED: 00004200 .* T' (N,O, OR U ONLY); K'; AND N' 00004250 LCLA &K,&N 00004300 LCLC &T 00004350 &T SETC T'&ARG 00004400 &K SETA K'&ARG 00004450 &N SETA N'&ARG 00004500 MNOTE '&&ARG = &ARG: T'' = &T; K'' = &K; N'' = &N.' 00004550 MEND 00004600 SPACE 1 00004650 ATTRIB , OMITTED ARGUMENT 00004700 ATTRIB 20 SELF-DEFINING TERM 00004750 ATTRIB X'20' ANOTHER SELF-DEFINING TERM 00004800 ATTRIB FULLWORD TYPE IS U, UNLIKE STNDRD ASMS 00004850 FULLWORD DS F 00004900 ATTRIB () NULL SUBLIST 00004950 ATTRIB (1,2,3,4,5) 00005000 ATTRIB (FULLWORD,1) NOTE TYPE ATTRIBUTE 00005050 ATTRIB 2(10,12) 00005100 ATTRIB A(2) 00005150 ATTRIB 'A''B' 00005200 ATTRIB ' ' 00005250 ATTRIB '' 00005300 SPACE 1 00005350 ATTRIB (A,B,C,D,E) 00005400 ATTRIB (A,,C,D,E) 00005450 ATTRIB (A,B,C,D) 4 OPERANDS 00005500 ATTRIB (A,B,C,D,,) 6 OPERANDS 00005550 END 00005600 $JOB ASSIST MACRO=F 00005650 TITLE 'ILLUSTRATE SETX STATEMENTS' 00005700 MACRO 00005750 &LABEL SET &ARG1,&ARG2,&ARG3 00005800 .* ILLUSTRATE SETX STATEMENTS. 00005850 LCLA &A1,&A2 00005900 LCLB &B1,&B2 00005950 LCLC &C1,&C2 00006000 MNOTE *,'INITIAL VALUES: &A1,&A2; &B1,&B2; &C1,&C2' 00006050 AIF (T'&ARG1 NE 'N').X1 00006100 &A1 SETA &ARG1(1) NOTE T' TAKEN FROM 1ST OF SUBLIST 00006150 .X1 AIF (T'&ARG2 NE 'N').X2 00006200 &A1 SETA &A1+&ARG2(1) 00006250 .X2 AIF (T'&ARG3 NE 'N').X3 00006300 &A1 SETA &A1+&ARG3(1) 00006350 .X3 MNOTE *,'&&A1 = &&ARG1+&&ARG2+&&ARG3 = &A1.' 00006400 .* 00006450 &A2 SETA (K'&ARG1+K'&ARG2+K'&ARG3)*N'&ARG1 00006500 MNOTE *,'&&A2 = &A2' 00006550 &C1 SETC 'ABC'.'DEF' 00006600 &C2 SETC '&ARG1&ARG2&ARG3' 00006650 MNOTE *,'&&C1 = &C1; &&C2 = &C2.' 00006700 &C1 SETC '&C1'(2,4) 00006750 &C2 SETC 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(26,1) 00006800 MNOTE *,'&&C1 = &C1; &&C2 = &C2' 00006850 &C1 SETC 'ABCDE'.'&C1'(2,2) 00006900 &C2 SETC 'ABCDE&C1'(2,2) 00006950 MNOTE *,'&&C1 = &C1; &&C2 = &C2' 00007000 &B1 SETB ('&ARG1' EQ '&ARG2' AND '&ARG3' EQ '0') 00007050 &B2 SETB (&B1 OR 0) 00007100 MNOTE *,'&&B1 = &B1; &&B2 = &B2' 00007150 &B1 SETB (&A1 EQ &A1) 00007200 &B2 SETB (&A1 GT &A1) 00007250 MNOTE *,'&&B1 = &B1; &&B2 = &B2 (0,1)' 00007300 MEND 00007350 SPACE 2 00007400 SET 1,3,5 00007450 SET (20,10),(20,10),X 00007500 SET =F'20',ABCDEFGHIJKLMNOPQRSTUVWXYZ,0 00007550 SET X'20',C'0',B'00000001' 00007600 END 00007650 $JOB ASSIST MACRO=F 00007700 TITLE 'ILLUSTRATE ARITHMETIC OPERATIONS IN SETA OPERATIONS' 00007750 MACRO 00007800 &LABEL SETAX &A 00007850 .* ILLUSTRATES ARITHMETIC OPERATIONS 00007900 .* IN SETA OPERATIONS. 00007950 GBLA &W,&X,&Y,&Z 00008000 LCLA &I,&J,&K,&L 00008050 MNOTE *,'INITIAL VALUES: W=&W; X=&X; Y=&Y; Z=&Z' 00008100 &W SETA &A+&W 00008150 &I SETA &I+1 00008200 MNOTE *,'W=A+W = &W; I = I+1 = &I' 00008250 .* SUBTRACTION 00008300 &X SETA &X-&A 00008350 &J SETA &J-1 00008400 MNOTE *,'X=X-A = &X; J=J-1 = &J' 00008450 .* MULTIPLICATION 00008500 &Y SETA (&Y+1)*&A 00008550 &K SETA 2*(&K+1) 00008600 MNOTE *,'Y=(Y+1)*A = &Y; K=2*(K+1) = &K' 00008650 .* DIVISION 00008700 &Z SETA (&Z+20)/&A 00008750 &L SETA 10/(&L+2) SHOULD = 5 00008800 MNOTE *,'Z=(Z+20)/A = &Z; L = 10/(L+2) = &L' 00008850 .* PARENTHESES. 00008900 &I SETA (((((0))))) 00008950 &J SETA 1+2*3 =7 00009000 &K SETA (1+2)*3 =9 00009050 &L SETA (((&J+&K)/4+1)+0*&L)+10 = 5+10 = 15 00009100 MNOTE *,'I,J,K,L = &I,&J,&K,&L' 00009150 MNOTE *,'END VALUES: W,X,Y,Z: &W,&X,&Y,&Z' 00009200 MEND 00009250 SPACE 2 00009300 SETAX 10 00009350 SETAX X'A' 00009400 SETAX B'00001010' 00009450 END 00009500 $JOB ASSIST MACRO=F 00009550 TITLE 'TEST SETB INSTRUCTION' 00009600 MACRO 00009650 SETBX &A,&B,&C 00009700 GBLB &W,&X,&Y,&Z 00009750 LCLB &D,&E,&F,&TRUE,&FALSE 00009800 LCLA &I,&J 00009850 LCLC &Q,&R 00009900 .* 00009950 MNOTE *,'INITIAL VALUES: W,X,Y,Z = &W,&X,&Y,&Z' 00010000 &FALSE SETB 0 FALSE VALUE 00010050 &TRUE SETB 1 TRUE VALUE 00010100 &W SETB (NOT &W) INVERSION 00010150 &X SETB (&W AND &TRUE) 00010200 &Y SETB (&W OR &FALSE) 00010250 &Z SETB ( 00010300 1M 7150 00010350 &Z SETB (&TRUE OR &TRUE AND NOT &TRUE) SHOULD BE 0 00010400 MNOTE *,'W,X,Y,Z = &W,&X,&Y,&Z' 00010450 .* COMPARISONS, CHARACTER OPERATIONS 00010500 &D SETB ('&Q' EQ '&R') COMPARE NULL STRINGS 00010550 &Q SETC 'ABCDEFGH' 00010600 &E SETB ('&Q' EQ 'ABCDEFGH') TRUE 00010650 &R SETC '&Q' 00010700 &F SETB ('&Q'(1,3) EQ '&R'(1,3)) 00010750 MNOTE *,'D,E,F = &D,&E,&F (1,1,1)' 00010800 &D SETB ('&Q'(2,5) GT '&Q'(1,4)) FALSE 00010850 &E SETB (&I+1 EQ &J+1) TRUE 00010900 &F SETB (&I+1 GT &J) TRUE 00010950 MNOTE *,'D,E,D = &D,&E,&F (0,1,1) 00011000 MEND 00011050 SPACE 1 00011100 SETBX 1 00011150 END 00011200 $JOB ASSIST MACRO=F 00011250 TITLE 'DEMONSTRATE SETC' 00011300 MACRO 00011350 &LABEL SETCX &A,&B,&C 00011400 GBLC &W,&X,&Y 00011450 LCLC &D,&E,&F 00011500 LCLA &I,&J 00011550 MNOTE *,'INITIAL VALUES: W/X/Y: &W/&X/&Y' 00011600 .* TRANSFER, CONCATENATION. 00011650 &D SETC '&A' TRANSFER 00011700 &E SETC '&A&B' CONCAT, NO PERIODS 00011750 &F SETC '&A.&B' CONCAT, WITH PERIOD' 00011800 MNOTE *,'D/E/F = &D/&E/&F' 00011850 &W SETC '&A'.'&W' CONCAT, QUOTES EACH 00011900 &X SETC '&A&X' 00011950 &Y SETC '&A&A&A&A&A&A&A&A&A&A' LONGGER THAN 8 BYTES 00012000 MNOTE *,'W/X/Y = &W/&X/&Y' 00012050 .* SUBSTRING OPERATIONS 00012100 &D SETC '123456789'(8,2) 89 00012150 &I SETA &C 89 ALSO 00012200 &D SETC '123456789'(97-&I,2+1*&I-&I) 89 ALSO 00012250 &E SETC '123456789'(9,2) JUST 9 00012300 MNOTE *,'C/I/D/E = &C/&I/&D/&E (89/89/89/9)' 00012350 MEND 00012400 SPACE 1 00012450 SETCX A,B,C 00012500 SETCX D,E,F 00012550 SETCX (1,2,3,4,5,6,7,8,9),,ABCDEF 00012600 END 00012650 $JOB ASSIST MACRO=F 00012700 TITLE 'AIF, AGO, ACTR' 00012750 MACRO 00012800 ATRAN &I 00012850 LCLA &J,&K 00012900 ACTR &I LIMIT ON # 00012950 AGO .X DEFINITE 00013000 MNOTE *,'SHOULD NOT BE PRINTED' 00013050 .X AIF (&I NE &I).Y DEFINITELY NOT 00013100 MNOTE *,'THIS MUST BE PRINTED' 00013150 .Y AIF (&I EQ &I).Z DEFINITE GO 00013200 MNOTE *,'MUST NOT BE PRINTED' 00013250 .Z ANOP 00013300 MNOTE *,'AT THIS PT, THERE HAVE BEEN 2 SUCCESSFUL AGO/AIF' 00013350 .LOOP ANOP 00013400 &J SETA &J+1 00013450 MNOTE *,'J = &J' 00013500 AGO .LOOP LOOP UNTIL ACTR GETS IT 00013550 MEND 00013600 ATRAN 8 00013650 END 00013700 $JOB ASSIST MACRO=F 00013750 *********************************************************************** 00013800 *********************************************************************** 00013850 ********************************************************************** 00013900 * * 00013950 * IN NEXT GROUP OF JOBS, ERRORS, WEIRD STATEMENTS, * 00014000 * ETC ARE SHOWN. * 00014050 * * 00014100 *********************************************************************** 00014150 ********************************************************************** 00014200 ********************************************************************** 00014250 TITLE 'ZERO DIVIDE, OVERFLOW TEST - DURING EXPANSION' 00014300 MACRO 00014350 TESTZDIV 00014400 .* TESTS ZERO DIVIDE AND FIXED POINT OVERFLOW ERROR CONDITIONS 00014450 LCLA &I,&J 00014500 &I SETA 2147483647 00014550 MNOTE *,' FOLLOWING MESSAGE OCCURS WHEN ZERO DIVIDE OCCURS' 00014600 &J SETA &I/&J 00014650 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN FXD PNT OVRFLW OCCURS' 00014700 &J SETA &I+1 00014750 MEND 00014800 SPACE 1 00014850 TESTZDIV 00014900 END 00014950 $JOB ASSIST MACRO=F 00015000 TITLE 'SHOW COMBINED EDIT / EXPANSION ERRORS' 00015050 MACRO 00015100 TESTSUBS &A 00015150 .* TESTS VARIOUS SUBSCRIPT ERROR CONDITIONS 00015200 LCLA &ARRAY(10) 00015250 LCLC &C 00015300 .* FOLLOWING MESSAGE OCCURS WHEN DIMENSION EXCEEDS LIMIT OF 2500 00015350 LCLA &EXCEED(2501) 00015400 .* FOLLOWING MESSAGE OCCURS WHEN DUPLICATE VARIABLE SYMBOL NAME IS 00015450 .* USED 00015500 LCLB &ARRAY 00015550 .* FOLLOWING MESSAGE OCCURS WHEN SUBSCRIPT OMITTED FROM DIMENSIONED 00015600 .* VARIABLE 00015650 &ARRAY SETA 13 00015700 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN INDEX VALUE EXCEEDS ARR#00015750 AY SIZE' 00015800 &ARRAY(20) SETA 20 00015850 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN SUBSCRIPT VALUE IS NON#00015900 ARITHMETIC' 00015950 &ARRAY(&A) SETA 100 00016000 .* FOLLOWING MESSAGE OCCURS WHEN ILLEGAL SUBSCRIP IS USED IN 00016050 .* DIMENSIONED VARIABLE 00016100 &ARRAY(3) SETA &ARRAY(/E) 00016150 .* FOLLOWING MESSAGES OCCUR WHEN WRONG NUMBER OF SUBSCRIPTS USED 00016200 &C SETC '&A'(3) 00016250 &C SETC '&A(2,2)' 00016300 MEND 00016350 SPACE 1 00016400 TESTSUBS NONDECIMALSTRING 00016450 END 00016500 $JOB ASSIST MACTR=10,MNEST=5,MACRO=F 00016550 TITLE 'ILLUSTRATE MACTR,MNEST OPTIONS' 00016600 MACRO 00016650 TESTXCED 00016700 .* THIS MACRO TESTS EXCESSIVE NESTED MACRO CALLS 00016750 GBLB &FLAG 00016800 AIF (&FLAG).SKIP 00016850 &FLAG SETB (1) 00016900 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN NUMBER OF NESTED MACRO #00016950 CALLS EXCEEDS MSTMG' 00017000 .SKIP ANOP 00017050 TESTXCED 00017100 MNOTE *,'NEVER PRINT - WHOLE NEST CANCELED' 00017150 MEND 00017200 SPACE 1 00017250 MACRO 00017300 LOOPER 00017350 LCLA &I 00017400 .LOOP ANOP 00017450 &I SETA &I+1 INCREMENT NOW 00017500 MNOTE *,'&&I = &I' 00017550 AGO .LOOP LOOP UNTIL ACTR GETS US 00017600 MEND 00017650 SPACE 1 00017700 TESTXCED 00017750 SPACE 1 00017800 LOOPER 00017850 END 00017900 $JOB ASSIST MACRO=F,MSTMG=20 00017950 TITLE 'ILLUSTRATE MSTMG OPTION' 00018000 MACRO 00018050 GEN6 00018100 MNOTE *,'1' 00018150 MNOTE *,'2' 00018200 MNOTE *,'3' 00018250 MNOTE *,'4' 00018300 MNOTE *,'5' 00018350 MNOTE *,'6' 00018400 MEND 00018450 GEN6 00018500 GEN6 00018550 GEN6 00018600 GEN6 00018650 GEN6 00018700 END 00018750 $JOB ASSIST MACRO=F 00018800 MACRO 00018850 TESTCHAR &A 00018900 LCLA &I 00018950 LCLB &B 00019000 LCLC &C 00019050 .* FOLLOWING MESSAGE OCCURS WHEN CHAR EXPRESSION DOES NOT START 00019100 .* WITH QUOTE 00019150 &C SETC ABCDE 00019200 .* FOLLOWING MESSAGE OCCURS WHEN CHAR EXPRESSION DOES NOT END 00019250 .* WITH QUOTE 00019300 &C SETC 'ABCDE 00019350 .* FOLLOWING MESSSAGE OCCURS WHEN TYPES ARE MIXED IN SET STMT 00019400 &C SETA 12 00019450 .* FOLLOWING MESSAGES OCCUR WHEN OPERAND NOT COMPATIBLE WITH 00019500 .* OPERATOR 00019550 &B SETB (NOT &C) 00019600 &B SETB (&B AND &I*&A) 00019650 MEND 00019700 END 00019750 $JOB ASSIST MACRO=F 00019800 MACRO 00019850 TESTDNAM 00019900 MEND 00019950 SPACE 1 00020000 MACRO 00020050 TESTDNAM 00020100 .* ABOVE MESSAGE OCCURS WHEN DUPLICATE NAME IS USED IN 00020150 .* MACRO PROTOTYPE STMT. DUMMY NAME SUBBED AND ASSEMBLY CONTINUES 00020200 MEND 00020250 SPACE 1 00020300 MACRO 00020350 AB*X 00020400 .* ABOVE MESSAGE OCCURS WHEN ILLEGAL SYMBOL IS USED FOR MACRO 00020450 .* NAME. DUMMY NAME IS SUBBED AND ASSEMBLY CONTINUES. 00020500 MEND 00020550 SPACE 1 00020600 MACRO 00020650 TESTOPR1 &A=3427,&B 00020700 .* ABOVE MESSAGE OCCU9S WHEN POSITIONAL OPRND FOLLOWS KEYWORD 00020750 MEND 00020800 SPACE 1 00020850 MACRO 00020900 TESTOPR2 &A=Z=347 00020950 .* ABOVE MESSAGE OCCURS WHEN OPERAND VALUE IN PROTOTYPE STMT OR 00021000 .* MACRO CALL DOES NOT CONFORM TO IBM GC28-6514 SECTION 8. 00021050 MEND 00021100 SPACE 1 00021150 MACRO 00021200 &LABEL TESTLABL 00021250 MNOTE *,'ABOVE MESSAGE OCCURS WHEN OPERAND VALUE ASSIGNED TO #00021300 LABEL FIELD SYMBOLIC PARAMETER IS NOT ORDINARY SYMBOL' 00021350 MEND 00021400 SPACE 1 00021450 (234) TESTLABL 00021500 END 00021550 $JOB ASSIST MACRO=F 00021600 MACRO 00021650 TESTSEQ 00021700 .* FOLLOWING MESSAGE OCCURS WHEN ILLEGAL SEQUENCE SYMBOL IS USED 00021750 AGO LOOP1 00021800 AGO .LOOP1 00021850 AGO .LOOP1 UNDEFINED 00021900 AGO .OOP2 ALSO UNDEFINED 00021950 .* FOLLOWING MESSAGE OCCURS WHEN SEQUENCE SYMBOL IS UNDEFINED 00022000 MEND 00022050 END 00022100 $JOB ASSIST MACRO=F 00022150 MACRO 00022200 TESTXPND &A 00022250 LCLA &I 00022300 LCLB &B 00022350 LCLC &C 00022400 .* FOLLOWING MESSAGE OCCURS WHEN SET SYMBOL DEFINITIONS OCCUR 00022450 .* OUT OF ORDER 00022500 GBLA &Z 00022550 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN ILLEGAL CONVERSION - #00022600 CHAR TO BINARY - IS ATTEMPTED.' 00022650 &C SETC 'ABCD' 00022700 &I SETA &C 00022750 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN ILLEGAL CONVERSION - #00022800 CHAR TO BOOLEAN - IS ATTEMPTED' 00022850 &B SETB (&A) 00022900 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN ILLEGAL CONVERSION - #00022950 BINARY TO BOOLEAN - IS ATTEMPTED.' 00023000 &I SETA 100 00023050 &B SETB (&I) 00023100 MNOTE *,'FOLLOWING MESSAGE OCCURS WHEN ILLEGAL ATTRIBUTE USE #00023150 IS ATTEMPTED.' 00023200 &B SETB (T'&A) 00023250 MEND 00023300 SPACE 1 00023350 TESTXPND WXYZ 00023400 END 00023450 $JOB ASSIST MACRO=F 00023500 MACRO 00023550 TESTCONT &A=1234,&B=2345, #00023600 &C=5000,&D=6000, #00023650 &E=7000,&F=8000, #00023700 &G=9000,&H=9000, #00023750 &I=12000, #00023800 &J=13000, #00023850 &K=14000, #00023900 &L=15000 AN INDEFINITE NBR OF CONT CARDS ARE OKAY 00023950 MNOTE *,' PARAM VALUES ARE &A, &B, &C, &D, &E, &F, &G, &H, &I,#00024000 &J, &K AND &L' 00024050 MEND 00024100 SPACE 1 00024150 TESTCONT A=12,B=30,C=20, #00024200 D=45,F=34, #00024250 E=6, #00024300 G=78,H=90, #00024350 I=99, #00024400 J=17, #00024450 K=74, #00024500 L=43 00024550 END 00024600 $JOB ASSIST MACRO=F 00024650 MACRO 00024700 TSTCONT1 &A=(AAAAAAAAAAAAAAAAAAA,BBBBBBBBBBBBBB,CCCCCCCCCCCCC#00024750 CCC,DDDDDDDDDDDDDDDDDD,EEEEEEEEEEEEE,FFFFFFFFFFFFF,GGGGG#00024800 GGGGGGGGG,HHHHHHHHHHH,IIIIIIIIIIIIIIIIII,JJJJJJJJJJJJJJJ#00024850 JJJJJ,KKKKKKKKKKK) 00024900 .* ABOVE ERROR MESSAGE ILLUSTRATES RESTRICTION ON ASSIST CONTINUATION 00024950 .* CARDS, I.E. THE 3RD, 6TH, 9TH ETC CONTINUATION CARDS CANNOT END IN 00025000 .* THE MIDDLE OF AN OPERAND, THEY MUST BE OF THE NON-STANDARD CONTIN- 00000050 .* UATION FORMAT 00000100 MEND 00000150 MACRO 00000200 TSTCONT2 &A=(AAAAAAAAAAA,BBBBBBBBB,CCCCCCCCCC,DDDDDDDDDD,UVVV#00000250 VVVVVVVVV,WWWWWWWWWWW,XXXXXXXXXXXXXXXXX,YYYYYYYYYYYYY,ZZ#00000300 ZZZZZZZZZZZZZZ),&B=ABCDEFGHIJKLIMONPQRSTUVWXYZ, #00000350 &C=(111111111,222222222,333333333,444444444,555555555,66#00000400 6666666,777777777,888888888,999999999,123456789,23456789#00000450 0,345678901,456789012) 00000500 .* ABOVE EXAMPLE ILLUSTRATES HOW EVERY 3RD CARD SHOULD END ON WITH 00000550 .* NON-STANDARD FORMAT. REGULAR CONTINUATION CAN THEN PICK UP AGAIN 00000600 .* FOR SUCCEEDING TWO CARDS 00000650 .* THE SAME RESTRICTION APPLIES TO A MACRO CALL AS TO THE PROTOTYPE 00000700 .* STATEMENT 00000750 MEND 00000800 TSTCONT2 A=1,B=2,C=3 00000850 TSTCONT1 A=1 00000900 END 00000950 $JOB ASSIST MACRO=F 00001000 TITLE 'TEST FOR NASTY COMMENTS, CONTINUATIONS' 00001050 MACRO 00001100 TESTCMMT &A=20,&B=30, #00001150 &C=40, #00001200 &D=50,&E=60 00001250 LCLA &I 00001300 MNOTE *,' SYM PARAMS ARE &A, &B, &C, &D AND &E.' 00001350 MEND 00001400 MACRO 00001450 TESTCMMU &A=, PARAMATER A #00001500 &B=10,&C=20 PARMS B,C 00001550 DC C' &&A = &A, &&B = &B, &&C = &C . XXXXXXXXXXXX XXXXXXXX#00001600 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXABCDEFGHIJKL#00001650 MNOPQRSTUVWXYZ' 00001700 MNOTE *,'*****************************************************#00001750 &A,&B,&C ***********************************************#00001800 X ' 00001850 TESTCMMT B=10,C=105, THIS IS A COMMENT ON INNER MAC #00001900 A=&A 00001950 MEND 00002000 SPACE 2 00002050 TESTCMMT A=100,B=200, #00002100 C=300,D=400, #00002150 E=500 00002200 TESTCMMU A=X,B=Y, ANOTHER COMMENT #00002250 C=500 COMMENT 00002300 TESTCMMT A=101,B=#00002350 102,C=103 00002400 TESTCMMT A=101, #00002450 C=102, #00002500 B=103 00002550 TESTCMMU A=1000,S=2000,C=3000 COMMENTS 00002600 END 00002650 $JOB ASSIST MACRO=F 00002700 ********************************************************************** 00002750 ********************************************************************** 00002800 ********************************************************************** 00002850 ********************************************************************** 00002900 ********************************************************************** 00002950 ********************************************************************** 00003000 ********************************************************************** 00003050 ********************************************************************** 00003100 ********************************************************************** 00003150 * * 00003200 * WARNING: FOLLOWING JOBS REQUIRE THE MACRO LIBRARY * 00003250 * PROCESSOR, AND SOME MAY REQUIRE CERTAIN MACROS TO BE * 00003300 * AVAILABEL (SUCH AS XSAVE, XRETURN, ETC). * 00003350 * * 00003400 * JOBS USING IBM MACROS MAY REQUIRE EXORBITANT AMOUNTS * 00003450 * OF MEMORY, DUE ESPECIALLY TO IHBERMAC, ETC. * 00003500 * HOWEVER, THEY DO ASSEMBLE IN 280 K REGION OR LESS * 00003550 * AND WE HAVE ACTUALLY RUN THEM. * 00003600 ********************************************************************** 00003650 *********************************************************************** 00003700 *********************************************************************** 00003750 ********************************************************************** 00003800 ********************************************************************** 00003850 ********************************************************************** 00003900 TITLE 'ILLUSTRATE XSAVE,XRETURN' 00003950 MACRO 00004000 GETMAIN 00004050 .* FAKE GETAMIN, SINCE WHILE XSAVE CALLS IT, IT IS NOT * 00004100 .* GOING TO USE IT. IF GETMAIN COMES IN, SO WILL IHBERMAC. * 00004150 MEND 00004200 MACRO 00004250 FREEMAIN 00004300 .* FAKE FREEMAIN, FOR XRETURN, SAME AS GETMAIN. 00004350 MEND 00004400 SPACE 1 00004450 MACRO 00004500 &LABEL XCALL &ENTRY,&ADLIST 00004550 .* SIMPLE CALL, GET AROUND REGUALR CALL 00004600 &LABEL DS 0H DEFINE LABEL 00004650 AIF ('&ADLIST' EQ '').X 00004700 L 15,=V(&ENTRY) 00004750 LA 1,=A&ADLIST REQUIRES WHOLE LIST 00004800 .X BALR 14,15 CALL ROUTINE 00004850 MEND 00004900 *SYSLIB XSAVE,XRETURN MENTION, SINCE NOT BEFORE 00004950 SPACE 2 00005000 MAIN CSECT 00005050 XSAVE 00005100 XCALL SUB1,(MAIN1,MAIN2) 00005150 XRETURN SA=* 00005200 MAIN1 DS F 00005250 MAIN2 DS F 00005300 LTORG 00005350 SUB1 CSECT 00005400 XSAVE TR=NO,BR=13 00005450 SUB1RET XRETURN 00005500 END 00005550 $ENTRY EXECUTE THE PROGRAM 00005600 $JOB ASSIST MACRO=F 00005650 TITLE 'QSAM I/O MACROS' 00005700 * THIS PROGRAM GOBBLES CORE. 00005750 MACRO 00005800 &LABEL IHBERMAC &A,&B,&C,&D,&E,&F,&G 00005850 .* STUPID FAKE IHBERMAC 00005900 MNOTE *,'IHBERMAC: &A,&B,&C,&D,&E,&F,&G' 00005950 MEND 00006000 * NOTE: MACROS CALLED FOR SPEARATELY, SO CAN SEE HOW 00006050 * LONG THEY ARE WITHOUT LISTING THEM. 00006100 *SYSLIB OPEN 00006150 *SYSLIB CLOSE 00006200 *SYSLIB GET 00006250 *SYSLIB PUT 00006300 *SYSLIB DCB 00006350 USING *,15 00006400 OPEN (XDCB,INPUT) 00006450 OPEN (YDCB,OUTPUT) 00006500 GET XDCB 00006550 PUT YDCB,(0) OUTPUT 00006600 CLOSE (XDCB,,YDCB) 00006650 XDCB DCB DDNAME=X,MACRF=GL,EODAD=XDCB,LRECL=80,DSORG=PS 00006700 YDCB DCB DDNAME=Y,DSORG=PS,MACRF=PM,LRECL=133,RECFM=FA,BUFNO=4 00006750 END 00006800 $JOB ASSIST MACRO=F 00006850 * 00006900 * THESE PROGRAMS TEST THE ERROR DETECTIO CODE AS WELL AS 00006950 * THE NORMAL RETRIEVAL LOGIC INCORPORATED INTO MOCOMSYS 00007000 * THESE ROUTINES ALSO TEST THE XXIOCO RETRIEVAL LOGIC 00007050 * 00007100 * 00007150 * INNER MACRO CALL NOT ON THE SYSLIB CARD 00007200 * 00007250 * 00007300 MACRO 00007350 MCALL &RTNE 00007400 CALL &RTNE 00007450 MEND 00007500 SPACE 5 00007550 * NEXT STMT PULLS IN: CALL,SAVE,RETURN,IHBERMAC, ETC. 00007600 *SYSLIB SAVE,RETURN 00007650 EJECT 00007700 TEST1 CSECT 00007750 USING TEST1,15 00007800 SAVE (14,12) 00007850 ST 13,TEST1SV+12 00007900 LA 13,TEST1SV 00007950 MCALL SUB1 00008000 L 13,TEST1SV+12 00008050 RETURN (14,12) 00008100 TEST1SV DS 18F 00008150 LTORG 00008200 DROP 15 00008250 SUB1 CSECT 00008300 USING SUB1,15 00008350 SAVE (14,12) 00008400 ST 13,SUB1SV+12 00008450 LA 13,SUB1SV 00008500 * NEXT STMT MUST BE FLAGGED, DID NOT MENTION XSNAP. 00008550 XSNAP LABEL='SUB1 ENTERED' 00008600 L 13,SUB1SV+12 00008650 RETURN (14,12) 00008700 SUB1SV DS 18F 00008750 DROP 15 00008800 END 00008850 $JOB ASSIST MACRO=F 00008900 * THIS PROGRAM IS COMPLETELY UNEXECUTABLE 00008950 * IT TEST THE LIBRARY SEARCH FACILITY AND THE 00009000 * MACRO DEFINITION AND EXPANSION PHASES OF THE ASSIST 00009050 * ASSEMBLER SYSTEM 00009100 * 00009150 * 00009200 * MACROS USED FOR THE TEST: 00009250 EJECT 00009300 *SYSLIB ATTACH USES ENTRY1 AND DCBDUMMY 00009350 EJECT 00009400 *SYSLIB CHAP USES NO LOCAL ADDRESS 00009450 EJECT 00009500 *SYSLIB CHKPT USES NO LOCAL ADDRESS 00009550 EJECT 00009600 *SYSLIB DELETE USES ENTRY1 00009650 EJECT 00009700 *SYSLIB 9XR TESTS MOCOMSYS SCAN LOGIC 00009750 * FOR ILLEGAL FIRST CHARACTER 00009800 EJECT 00009850 *SYSLIB DXR USES NO LOCAL ADDRESSES 00009900 *SYSLIB EXTRACT USES A 7-WORD, ALINED AREA, ANSER 00009950 *SYSLIB GTRACE USES GDATA ADDRESS 00010000 *SYSLIB LINK USES ENTRY1 00010050 *SYSLIB SEGLD USES EXTERN 00010100 *SYSLIB SPIE USES INTERADD 00010150 *SYSLIB STATUS USES TCBDUM 00010200 *SYSLIB STATUE TEST MOCOMSYS NO FIND ERROR 00010250 *SYSLIB XCTL USES ENTRY1 AND DCBDUMMY 00010300 *SYSLIB DETACH USES TCBDUM 00010350 * 00010400 * 00010450 * NEXT TEST THE ACTION OF A BLANK SYSLIB CARD 00010500 * 00010550 MACRO 00010600 MCALL &RTNE 00010650 CALL &RTNE 00010700 MEND 00010750 *SYSLIB 00010800 *SYSLIB SAVE.RETURN BAD DELIMITER 00010850 *SYSLIB SAVE,RETURN FOR LINKAGE AND ADDRESSABILITY 00010900 * 00010950 WIERD CSECT 00011000 USING TEST,15 SET UP ADDRESSABILITY 00011050 SAVE (14,12) 00011100 * BEGIN TEST OF MACRO EXPANSION CODE 00011150 MCALL SUB1 00011200 ATTACH EP=ENTRY1,DCB=DCBDUMMY,HIARCHY,1,SZERO=YES 00011250 ATTACH EP=ENTRY1,DCB=DCBDUMMY,HIARCHY=1,SZERO=YES 00011300 CHAP -1,'S' 00011350 CHKPT CANCEL,(3),'S' 00011400 DELETE EP=ENTRY1 00011450 DETACH TCBDUM,STAE=YES 00011500 DXR 0,4 00011550 EXTRACT ANSER,'S',FIELDS=ALL 00011600 GTRACE DATA=GDATA,LNG=4,ID=7,FID=0 00011650 LINK EP=ENTRY1,EPLOC=(5),ID=57,HIARCHY=0 00011700 SEGLD EXTERN 00011750 SPIE INTERSDD,((1,14)) 00011800 SPIE INTERADD,((1,14)) 00011850 STATUS STOP,TCB=TCBDUM 00011900 XCTL (2,12),EP=ENTRY1,DCB=DCBDUMMY,HIARCHY=1 00011950 *SYSLIB DCB GET THE DCB MACRO 00012000 RETURN (14,12) 00012050 DS 0F 00012100 DCBDUMMY DS F 00012150 ENTRY1 DS F 00012200 TCBDUM DS F 00012250 ANSER DS 7F 00012300 EXTERN DS F 00012350 INTERADD DS F 00012400 * 00012450 * END 00012500 * END OF WIERD MACRO TEST PROGRAM 00012550 * 00012600 SUB1 CSECT 00012650 USING SUB1,14 00012700 SAVE (14,12) 00012750 *SYSLIB CHAP MORE WIERD TESTING 00012800 RETURN 00012850 END WIERD 00012900 $JOB 00012950 * THE FOLLOEING CODE MULTIPLIES TWO SPARSE MATRICES WHICH ARE 00013000 * LOADED INTO STORAGE AS ORTHAGONAL ARRAYS. IF A MATRIX ELEMENT 00013050 * IS ZERO, IT IS NOT KEPT AND ITS ABSENCE INDICATES A VALUE 00013100 * OF ZERO FOR THAT NODE. 00013150 * MATRIX NODES HAVE THE FOLLOWING FORM: 00013200 * WORD 1-->THE MATRIX VALUE 00013250 * WORD 2-->THE ROW LINK 00013300 * WORD 3-->THE COLUMN LINK 00013350 * WORD 4-->SUBSCRIPT VALUES OF THE NODE 00013400 * THE ROW HEADERS LOOK LIKE: 00013450 * WORD 1-->THE HEADER FLAG 00013500 * WORD 2-->THE LINK(TO THE LAST NODE 00013550 * IN THE ROW). 00013600 * WORD 3-->ROW SUBSCRIPT 00013650 * WORD 4-->UNUSED 00013700 * THE COLUMN HEADERS LOOK LIKE: 00013750 * WORD 1-->HEADER FLAG 00013800 * WORD 2-->THE LINK(AS ABOVE) 00013850 * WORD 3-->COLUMN SUBSCRIPT 00013900 * WORD 4-->UNUSED 00013950 * THE OUTPUT STACK HEADERS LOOK LIKE: 00014000 * WORD 1-->UNUSED 00014050 * WORD 2-->HEADER FLAG 00014100 * WORD 3-->SUBSCRIPT VALUES 00014150 * WORD 4-->THE RIGHT LINK 00014200 * THE OUTPUT STACK NODES LOOK LIKE: 00014250 * WORD 1-->LEFT LINK 00014300 * WORD 2-->PARTIAL VALUE 00014350 * WORD 3-->SUBSCRIPT VALUES 00014400 * WORD 4-->THE RIGHT LINK 00014450 * AS THE MULTIPLY PORTION OF THE PROGRAM DEVELOPES A PARTIAL 00014500 * PRODUCT OF THE PRODUCT MATRIX, IT IS PUSHED ONTO THE FRONT 00014550 * OF A STACK. THE STACK IS A RIGHT CIRCULAR, DOUBLY LINKED 00014600 * LIST. SINCE THE MULTIPLY ALGORITHM DEVELOPS THE PRODUCT 00014650 * MATRIX FROM LAST ELEMENT TO FIRST, LOADING THE STACK FROM THE 00014700 * FRONT DEVELOPES THE PRODUCT MATRIX IN STORAGE IN THE PROPER 00014750 * ORDER. 00014800 * DATA TO THE PROGRAM: 00014850 * 1. 'M' IN COL. 1 OF A CARD(OMIT FOR FIRST MATRIX PAIR) 00014900 * 2. MATRIX DIMENSIONS(INTEGER NUMBERS 051, SEPARATED BY 00014950 * AT LEAST ONE BLANK) 00015000 * 3. ROW 1 OF MATRIX 'A', EACH VALUE SEPARATED BY A BLANK 00015050 * LAST VALUE FOLLOWED BY: A BLANK, AND THE CHARACTER 'E' 00015100 * 4. ROW 2 AS ABOVE, ETC. 00015150 * 5. '*' IN COL. 1 TO DELIMIT MATRICES 00015200 * 6. VALUES OF MATRIX 'B' AS ABOVE 00015250 * 7. SAME AS 1 ABOVE TO DELIMIT MATRICES 00015300 * 00015350 * 00015400 * 00015450 * 00015500 * 00015550 MAIN CSECT 00015600 BALR 12,0 00015650 USING *,12 00015700 ST 14,SAV14 00015750 * 00015800 * 00015850 * GENERATE A LIST OF AVAILABLE SPACE LINKED THRU AVAIL 00015900 * 00015950 * 00016000 BEGIN XPRNT =CL5'1',5 00016050 XPRNT =CL22'0MATRIX DIMENSIONS ARE',22 00016100 LA 4,500 LOOP CONTROL FOR INITIAL LINKAGE 00016150 LA 2,WORKAREA R2<--ADDRESS OF WORKING AREA 00016200 ST 2,AVAIL STORE START OF AVAILABLE NODES 00016250 LR 3,2 COPY FOR CORRECT LINKAGE 00016300 START LA 3,16(3) INCREMENT TO NEXT NODE FOR LINK 00016350 ST 3,4(2) LINK WITH PREVIOUS NODE 00016400 LA 2,16(2) ACCESS NEXT NODE FOR LINKUP 00016450 BCT 4,START LOOP 00016500 MVC 0(4,2),=X'00000000' GROUND LAST NODE 00016550 * 00016600 * 00016650 * INPUT, CONVERT, AND SAVE EACH MATRIX PARAMETER CARD 00016700 * CHECK FOR MATRIX COMPATIBILITY 00016750 * ECHO PRINT EACH PARAMETER CARD 00016800 * 00016850 * 00016900 XREAD CARD,80 READ MATRIX PARAMETER CARD 00016950 XPRNT CARD-1,50 ECHO PRINT INPUT 00017000 XPRNT =CL50'0ECHO CHECK ON INPUT MATRICES',50 00017050 BM STOP ON LAST CARD OF DECK END EXECUTION 00017100 XDECI 2,CARD COVERT ROW PARAM. MATRIX A 00017150 XDECI 3,0(1) CONVERT COL. PARAM MATRIX A 00017200 XDECI 4,0(1) CONVERT ROW PARAM. MATRIX B 00017250 XDECI 5,0(1) CONVERT COL. PARAM. MATRIX B 00017300 STM 2,5,ROWA STORE FOR LATER USE 00017350 ST 4,ROWBI STORE ROWB FOR LATER USE 00017400 CR 3,4 ARE MATRICES COMPATIBLE 00017450 BE SKIP YES-- SKIP ERROR OUTPUT 00017500 XPRNT =CL100'***ERROR*** MARICES ARE NOT COMPATIBLE; AND CANNOT00017550 T BE MULTIPLIED',100 00017600 XPRNT =CL50' MATRIX DIMENSIONS ARE:',50 00017650 XDECO 2,EMESS+26 CONVERT MATRIX DIMENSIONS FOR OUTPUT 00017700 XDECO 3,EMESS+43 00017750 XDECO 4,EMESS+77 00017800 XDECO 5,EMESS+94 00017850 XPRNT EMESS,106 PRINT MATRIX DIMENSIONS 00017900 DUMP XREAD CARD,1 LOOK FOR MATRIX DELIMITER 00017950 CLI CARD,C'M' 00018000 BE BEGIN 00018050 B DUMP 00018100 * 00018150 * 00018200 * DEVELOPE TABLES OF ARRAY HEADER ADDRESSES 00018250 * TABRA-->ROW HEADER TABLE MATRIX 'A' 00018300 * TABCA-->COLUMN HEADER TABLE MATRIX 'A' 00018350 * TABRB-->ROW HEADERS OF MATRIX 'B' 00018400 * TABCB-->COLUMN HEADERS TABLE OF MATRIX 'B' 00018450 * 00018500 * 00018550 SKIP L 3,AVAIL SET AVAIL TO FIRST NODE 00018600 LA 10,ROWA ADDRESS OF IMAX,JMAX,KMAX,LMAX 00018650 LA 11,TABRA ADDRESS OF HEADER TABLES 00018700 LA 4,4 OUTER LOOP CONTROL 00018750 OUTER LR 9,11 NEW REG. TO INDEX INTO EACH TABLE 00018800 SR 1,1 COUNTER FOR EACH INDEX 00018850 L 2,0(10) SUCCESIVE DIMENSIONS IN R2 00018900 INNER LA 1,1(1) INCREMENT INDEX 00018950 L 3,AVAIL P<--AVAIL 00019000 CLC 4(3),=F'0' LOOK FOR LAST NODE 00019050 BE OVFLOW IF FOUND OVERFLOW HAS OCCURRED 00019100 MVC AVAIL(4),4(3) OTHERWISE; AVAIL<--LINK(AVAIL) 00019150 ST 3,0(9) HEADER ADDRESS IN HEADER TABLE 00019200 ST 1,8(3) INDEX VALUE IN HEADER 00019250 MVC 0(4,3),=C'HEAD' VALUE(HEADER)<--HEADER FLAG 00019300 ST 3,4(3) LINK HEADER TO ITSELF(EMPTY LIST) 00019350 LA 9,4(9) NEXT CELL OF HEADER TABLE 00019400 BCT 2,INNER LOOP TO INNER LOOP 00019450 LA 10,4(10) GET NEXT DIMENSION 00019500 LA 11,200(11) GET NEXT HEADER TABLE 00019550 BCT 4,OUTER LOOP TO OUTER ATEP 00019600 * 00019650 * 00019700 * DEVELOPE A TABLE OF OUTPUT STACK HEADER ADDRESSES 00019750 * TABSTK--> STACK HEADER TABLE 00019800 * 00019850 * 00019900 LA 5,TABSTK REFERENCE STACK HEADER TABLE 00019950 LA 1,0 ZERO R1 FOR ROW INDEX 00020000 L 2,ROWA NUMBER OF STACKS=ROWA 00020050 STACK LA 1,1(1) INCREMENT INDEX COUNTER 00020100 L 3,AVAIL P<--AVAIL 00020150 CLC 4(3),=F'0' IS IT LAST NODE? 00020200 BE OVFLOW YES--OVERFLOW 00020250 MVC AVAIL(4),4(3) N/-- AVAIL<--LINK(AVAIL) 00020300 ST 3,0(5) PUT HEADER ADDRESS IN TABLR 00020350 STH 1,8(3) PUT ROW INDEX IN HEADER 00020400 MVC 4(4,3),=C'HEAD' PUT HEADER FLAG IN HEADER 00020450 ST 3,12(3) LINK HEADER TO ITSELF FOR EMPTY LIST 00020500 LA 5,4(5) GET NEXT PLACE IN TABLE 00020550 BCT 2,STACK CONTINUE UNTILL ROWA=0 00020600 * 00020650 * 00020700 * INPUT, CONVERT, AND STORE THE MATRIX ELEMENTS INTO 00020750 * THE ORTHAGONAL ARRAY 00020800 * IF AN ELEMENT EQUALS ZERO NO SPACE IS SAVED FOR THAT 00020850 * ELEMENT 00020900 * 00020950 * 00021000 LA 5,TABRA INITIALIZE FOR ARRAY LOADING 00021050 LR 6,5 OPERATIONS ON MATRIX 'A' 00021100 LA 8,TABCA 00021150 LR 9,8 00021200 NEWMTRX L 10,0(9) COL. HEADER ADDRESS IN R10 00021250 STRTNWR L 7,0(6) ROW HEADER ADDRESS IN R7 00021300 NEWCARD LA 4,CARD USE R4 FOR MULTIPLE READ OFF A CARD 00021350 XREAD 0(4),80 READ A DATA CARD 00021400 XPRNT CARD-1,81 ECHO PRINT THE ROW OF A MATRIX 00021450 CLI CARD,C'M' HAS MATRIX INPUT ENDED 00021500 BE MULT YES--THEN MULTIPLY THE MATRICES 00021550 CLC 0(1,4),=C'*' LOOK FOR MATRIX SEPARATER 00021600 BE MATRIXB IF FOUND--LOAD ARRAY 'B' 00021650 NEXTELEM XDECI 11,0(4) CONVERT FROM CARD TO HEX 00021700 LR 4,1 KEEP XDECI MOVING IN CARD 00021750 BO NEWROW END OF CURRENT ROW, GET NEW ROW 00021800 LTR 11,11 IS VALUE ZERO? 00021850 BZ NEWCOL YES<- GOTO NEXT COLUMN OF THIS ROW 00021900 L 2,AVAIL TEMP<--AVAIL 00021950 MVC AVAIL(4),4(2) AVAIL<--LINK(AVAIL) 00022000 ST 11,0(2) VALUE(AVAIL)<--ELEMENT 00022050 MVC 4(4,2),4(7) ROWLINK(AVAIL)<--LINK(ROWHEADER 00022100 MVC 8(4,2),4(10) COLLINK(AVAIL)<--LINK(COLHEADER) 00022150 ST 2,4(7) LINK(ROWHEADER)<--AVAIL 00022200 ST 2,4(10) LINK(COLHEADER)<--AVAIL 00022250 MVC 14(2,2),10(7) ROWINDEX(AVAUL)<-- ROW INDEX 00022300 MVC 12(2,2),10(10) COLINDEX(AVAIL)<--COL. INDEX 00022350 NEWCOL LA 9,4(9) DISPLACE TO NEXT HEADER IN COL. TABLE 00022400 L 10,0(9) RETREIVE NEW HEADER ADDRESS IN R10 00022450 B NEXTELEM 00022500 NEWROW LR 9,8 RESTART ROW ACCESSING TABCA 00022550 LA 6,4(6) GET NEXT ROW HEADER FROM LIST 00022600 B NEWMTRX RESTART LOADING LOOP 00022650 MATRIXB LA 5,TABRB INITIALIZE FOR ARRAY LOADING 00022700 LR 6,5 OPERATIONS ON ARRAY 'B' 00022750 LA 8,TABCB 00022800 LR 9,8 00022850 B NEWMTRX 00022900 * 00022950 * 00023000 * THIS SECTION USES THE HEADER TABLES AS A STARTING POINT 00023050 * AND MULTIPLIES THE TWO SPARSE MATRICES. IF A ROW OF 00023100 * MATRIX 'A' OR A COLUMN OF MATRIX 'B' ARE ALL ZEROS 00023150 * OR IF A CORRESPONDING NODE DOES NOT EXIST IN EITHER 00023200 * MATRIX, THAT NODE OR ROW OF OUTPUT IS SKIPPED AND THE 00023250 * NEXT ROW-COLUMN PAIR OR NODE-NODE PAIR IS CONSIDERED. 00023300 * 00023350 * 00023400 MULT XPRNT =CL50'0THE PRODUCT MATRIX IS',50 00023450 TEMP EQU 14 EQUATE THESE REGISTERS TO LABLES AT 00023500 RESULT EQU 2 LEFT FOR EASE IN IMPLEMENTING 00023550 I EQU 3 MULTIPLY OPERATION 00023600 J EQU 4 00023650 K EQU 5 00023700 L EQU 6 00023750 SR 14,14 TEMP<--0 00023800 LR RESULT,TEMP RESULT<--0 00023850 LM I,L,ROWA I<-IMAX,J<-JMAX,K<-KMAX,L<-LMAX 00023900 LA 7,TABRA REFERENCE HEADER TABLES FOR 00023950 LA 8,TABCB INDEXING INTO THE MATRICES 00024000 SLL L,2 DISPLACEMENT INTO THE TABLES 00024050 AR 8,L DISPLACE INTO TABLE 00024100 S 8,=F'4' CORRECT DISPLACEMENT FOR LAST ENTRY 00024150 SRL L,2 FOR LOOPING PURPOSES 00024200 BOTTOM SLL I,2 CORRECT TO BYTES,IMAX&LMAX FOR PROPER 00024250 AR 7,I DISPLACE INTO TABLES 00024300 S 7,=F'4' CORRECT DISPLACEMENT FOR LAST ENTRY 00024350 SRL I,2 RESTORE TO DECIMAL EQUIVALENT 00024400 L 10,0(8) R10<--HEADER (LMAX) ADDRESS 00024450 L 13,4(10) GET LAST NODE OF LIST 00024500 ST 13,LASTNODE SAVE FOR USE IN LOOP 00024550 START1 L 9,0(7) R9<--HEADER(IMAX) ADDRESS 00024600 L 11,4(9) INDEX I TH NODE OF MATRIX A 00024650 CHECK CR 10,13 IS COL(I) OF MATRIX B EMPTY 00024700 BE COLNULL YES--CONTINUE AT COLNULL 00024750 CR 9,11 IS ROW(I) OF MATRIX A EMPTY 00024800 BE ROWNULL YES--CONTINUE TA ROWNULL 00024850 CH I,14(11) IS NODE THE I,J TH NODE OF A 00024900 BNE ROWZIP NO--RECOVER AT ROWZIP 00024950 CH J,12(11) 00025000 BNE ROWZIP 00000050 CH K,14(13) IS NODE K,L TH NODE OF B 00000100 BNE COLZIP NO--RECOVER AT COLZIP 00000150 CH L,12(13) 00000200 BNE COLZIP 00000250 MULTPLY L 15,0(11) TEMP<--A(I,J)*B(K,L) 00000300 M TEMP,0(13) 00000350 AR RESULT,15 RESULT<--RESULT+TEMP 00000400 BCTR J,0 DECREMENT J & K FOR NEXT STAGE 00000450 BCTR K,0 00000500 LTR J,J IS J ZERO 00000550 BNP JUMP1 YES--THEN GO TO JUMP FOR OUTPUT 00000600 TAKLINK L 11,4(11) TAKE LINK TO NEXT NODE IN BOTH MAT. 00000650 L 13,8(13) 00000700 B CHECK CHECKK IF THESE NODES ARE CORRECT 00000750 JUMP1 LTR RESULT,RESULT IF RESULT=0 00000800 BZ DECI SKIP INSERTING RESULT IN OUT LIST 00000850 BAL 15,INSERT IF NOT--GO TO INSERT & OUTPUT RESULT 00000900 DECI L J,COLA J<--JMAX 00000950 L K,ROWB K<--KMAX 00001000 SR RESULT,RESULT RESULT<--0 00001050 L 13,LASTNODE PREPARE MATRIX B FOR NEXT OPERATION 00001100 BCTR I,0 DECREMENT I FOR OPERATION CONTROL 00001150 LTR I,I IS I=0 00001200 BZ DECL GO TO DECL AND GET NEW COL IN B 00001250 S 7,=F'4' OTHERWISE GET NEXT ROW OF A 00001300 B START1 AND CONTINUE 00001350 COLNULL CR 9,11 SINCE ROW(I) OF A IS EMPTY TESTTO 00001400 * SEE IF CORRISPONDING COL OF B IS 00001450 * ALSO EMPTY 00001500 BE DECL IF IT IS GO TO DECL AND CONTINUE 00001550 B DECI OTHERWISE--GO TO DECI AND CONTINUE 00001600 COLZIP CH I,14(11) SINCE CORRECT NODE EXISTS IN MATRIX A 00001650 * BUT NOT IN MATRIX B, TEST FOR AT 00001700 * LEAST ONE NODE IN ROW(I) OF A 00001750 BE ROWLINK IF IT EXISTS, TAKE A LINK IN A 00001800 COUT BCTR J,0 IF NOT, DECREMENT J & K AND CONTINUE 00001850 BCTR K,0 00001900 B CHECK 00001950 ROWLINK L 11,4(11) TAKE A LINK IN MATRIX A AND 00002000 B COUT MAINTAIN LOOP CONTROLS AT COUT 00002050 * 00002100 * 00002150 * SAME LOGIC FOR THE CASE WHEN THE CORRECT NODE EXISTS IN 00002200 * MATRIX B BUT NOT IN MATRIX A 00002250 * 00002300 * 00002350 ROWZIP CH K,14(13) 00002400 BE COLINK 00002450 ROUT BCTR J,0 00002500 BCTR K,0 00002550 B CHECK 00002600 COLINK L 13,8(13) 00002650 * 00002700 BCTR J,0 00002750 BCTR K,0 00002800 B CHECK 00002850 * 00002900 * LOGIC FOR ROWNULL IS THE SAME AS USED IN SECTION HEADED BY 00002950 * COLNULL 00003000 * 00003050 * 00003100 ROWNULL BCTR J,0 00003150 BCTR K,0 00003200 LTR J,J 00003250 BNP JUMP1 00003300 B TAKLINK 00003350 * 00003400 * 00003450 * LOGIC USED IN DECL SAME AS IN DECI 00003500 * 00003550 * 00003600 DECL BCTR L,0 00003650 LTR L,L 00003700 BZ OUTPUT 00003750 S 8,=F'4' 00003800 LA 7,TABRA 00003850 L I,ROWA 00003900 B BOTTOM 00003950 * 00004000 * 00004050 * WHEN MULT DEVELOPES A PARTIAL PRODUCT, IT IS GIVEN TO 00004100 * INSERT AND IS PUSHED ON THE FRONT OF THE OUTPUT STACK 00004150 * 00004200 * 00004250 INSERT STM 0,9,SAVMAIN PROTECT SOME REGS. TO USE LOCALLY 00004300 L 1,TABSTK ACCESS FIRST TABLE ENTRY 00004350 LOOK CH I,8(1) IS HEADER THE I TH HEADER 00004400 BE LOCATED YES--GO TO LOCATED 00004450 LA 1,16(1) NO--FIND NEXT HEADER 00004500 B LOOK CONTINUE 00004550 LOCATED L 7,AVAIL P<--AVAIL 00004600 CLC 4(4,7),=F'0' IF LINK(P)=0 00004650 BE OVFLOW THEN OVERFLOW 00004700 MVC AVAIL(4),4(7) AVAIL<--LINK(AVAIL) 00004750 C 1,12(1) DOES LINK(HEADER)=HEADER ADDRESS 00004800 BE OPEN YES--THEN OPEN THE LIST 00004850 ST 1,0(7) OTHERWISE; LLINK(P)<--HEADER ADDRESS 00004900 MVC 12(4,7),12(1) RLINK(P)<--RLINK(HEADER) 00004950 L 3,12(1) LINK TO NEXT AVAIL NODE IN R3 00005000 ST 7,0(3) RLINK(LLINK(HEADER))<--P 00005050 ST 7,12(1) RLINK(HEADER)<--P 00005100 BACK ST RESULT,4(7) VALUE(P)<--RESULT 00005150 STH I,8(7) ROWINDEX(P)<--I 00005200 STH L,10(7) COLINDEX(P)<--L 00005250 LM 0,9,SAVMAIN RESTORE REGS. FOR RETURN 00005300 BR 15 RETURN 00005350 OPEN MVC 12(4,7),12(1) RLINK(P)<--RLINK(HEADER) 00005400 MVC 0(4,7),12(1) LLINK(P)<--RLINK(HEADER) 00005450 ST 7,12(1) RLINK(HEACER)<--P 00005500 B BACK RETURN VIA BACK 00005550 * 00005600 * 00005650 * WHEN MULTIPLICATION OPERATIONS ARE COMPLETEED, THE NEXT 00005700 * SECTION OUTPUTS THE PRODUCT MATRIX AS STORED IN THE 00005750 * ROW STACKS DEVELOPED AT INSERT 00005800 * 00005850 * 00005900 OUTPUT L 1,TABSTK ACCESS TABLE OF STACK HEADERS 00005950 LA 2,ROWOUT2+3 R2<--ADD. OF BUFFER TO OUTPUT 00006000 LA 10,COLOUT2+3 PRODUCT MATRIX 00006050 L 3,ROWA R3= NUMBER OF ROWS IN PRODUCT MATRIX 00006100 OUTLOOP C 1,12(1) IS LIST FOR ROW(I) EMPYT 00006150 LR 14,1 COPY HEADER ADD. FOR EMPTY TEST 00006200 BE NOVALUES YES--PRINT MESS AND CONTINUE 00006250 L 9,12(1) GET FIRST NODE OF CURRENT ROW 00006300 OUTNEXT L 6,4(9) TEMP<--VALUE(NODE) 00006350 XDECO 6,OUTTEMP CONVERT FOR OUTPUT 00006400 MVC 0(4,2),OUTTEMP+8 PUT SIGNIFICANT PORTIOM OF NUMBER 00006450 * INTO OUTPUT BUFFER 00006500 LA 2,4(2) GET NEXT USABLE PORTION OF BUFFER 00006550 LH 6,10(9) R6<--COL. INDEX 00006600 XDECO 6,OUTTEMP CONVERT FOT OUTPUT 00006650 MVC 1(2,10),OUTTEMP+10 MOVE TO RIGHT IN COL BUFFER 00006700 LA 10,4(10) GET NEXT PORTION OF COL. BUFFER 00006750 C 14,12(9) ARE WE DONE--RLINK(NODE)=HEADER 00006800 BE DONE YES--PRINT COMPLETED ROW & CONTINUE 00006850 L 9,12(9) ACCESS JTH NODE OF CURRENT ROW 00006900 B OUTNEXT DO ABOVE FOR ALL NODES(I) OF EACH 00006950 * ROW 00007000 DONE LH 6,8(1) R6<--ROW VALUE OF CURRENT ROW 00007050 XDECO 6,OUTTEMP CONVERT TO OUTPUT 00007100 MVC ROWOUT+3(2),OUTTEMP+10 MOVE INDEX INTO BUFFER 00007150 XPRNT COLOUT,133 PRINT COL. INDICATOR 00007200 XPRNT ROWOUT,133 PRINT COMPLETED ROW 00007250 MVC ROWOUT2(130),BLANK BLANK OUT WORKIG AREA OF BUFFER 00007300 MVC COLOUT2(130),BLANK BLANK OUT WORKIG AREA OF BUFFER 00007350 XPRNT SKIP,3 SKIP 3 LINES 00007400 LA 1,16(1) ACCESS NEXT HEADER IN HEADER TABLE 00007450 LA 2,ROWOUT2+3 RE-INITIALIZE OUTPUT AREA 00007500 LA 10,COLOUT2+3 RE-INITIALIZE OUTPUT AREA 00007550 JUMP BCT 3,OUTLOOP LOOP IMAX TIMES 00007600 XREAD CARD,10 LOOK FOR CONTROL CARDS OF NEXT 00007650 BM STOP MATRIX OPERATION...IF /* FOUND STOP 00007700 B BEGIN IF NOT--RESTART PROGRAM AT BEGIN 00007750 STOP L 14,SAV14 PUT ASSIST RETURN ADDRESS IN R14 00007800 XPRNT =CL5'1',5 SKIP A PAGE TO CLEAR OUTPUT 00007850 BR 14 RETURN TO ASSIST 00007900 NOVALUES XPRNT =CL50'0NO NON-ZERO ELEMENTS IN NEXT ROW',50 00007950 B DONE 00008000 OVFLOW XPRNT =CL50'0OVERFLOW HAS OCCURRED, STOP EXECUTION',50 00008050 B STOP 00008100 LTORG 00008150 SAV14 DS F 00008200 AVAIL DS F 00008250 LASTNODE DS F 00008300 ROWA DS F 00008350 COLA DS F 00008400 ROWB DS F 00008450 COLB DS F 00008500 ROWBI DS F 00008550 SAVMAIN DS 18F 00008600 TABRA DS 50F 00008650 TABCA DS 50F 00008700 TABRB DS 50F 00008750 TABCB DS 50F 00008800 TABSTK DS 50F 00008850 DC CL8' ' PROVIDE BLANKS FOR PRINTING 00008900 CARD DS 80C 00008950 OUTTEMP DS 12C 00009000 COLOUT DC C'0J=' 00009050 COLOUT2 DC 130C' ' 00009100 ROWOUT DC C'0I=' 00009150 ROWOUT2 DC 130C' ' 00009200 SKIP3 DC C'0 ' 00009250 EMESS DC C'0 MATRIX ONE----> ROW= ;COL= 100009300 ;MATRIX TWO-----> ROW= ;COL= ' 00009350 BLANK DC 130C' ' 00009400 DS 0D 00009450 WORKAREA DS 9000C 00009500 END 00009550 $ENTRY 00009600 3 2 2 4 00009650 1 0 E 00009700 3 4 E 00009750 0 6 E 00009800 * 00009850 0 8 9 10 E 00009900 0 12 0 14 E 00009950 M 00010000 00010050 3 3 3 3 00010100 0 0 0 E 00010150 4 5 6 E 00010200 7 8 9 E 00010250 * 00010300 9 0 7 E 00010350 6 0 4 E 00010400 3 0 1 E 00010450 M 00010500 M 00010550 3 3 3 3 00010600 1 2 3 E 00010650 4 5 6 E 00010700 7 8 9 E 00010750 * 00010800 9 8 7 E 00010850 6 5 4 E 00010900 3 2 1 E 00010950 M 00011000 M 00011050 3 2 2 3 00011100 1 2 E 00011150 3 4 E 00011200 5 6 E 00011250 * 00011300 7 8 9 E 00011350 10 11 12 E 00011400 M 00011450 M 00011500 1 3 3 1 00011550 1 2 3 E 00011600 * 00011650 4 E 00011700 5 E 00011750 6 E 00011800 M 00011850 M 00011900 1 1 1 1 00011950 4 E 00012000 * 00012050 4 E 00012100 M 00012150 M 00012200 1 8 8 1 00012250 0 0 0 0 0 0 0 0 E 00012300 * 00012350 1 E 00012400 0 E 00012450 0 E 00012500 0 E 00012550 0 E 00012600 0 E 00012650 0 E 00012700 0 E 00012750 M 00012800 M 00012850 3 2 2 5 00012900 1 2 E 00012950 3 4 E 00013000 5 6 E 00013050 * 00013100 1 2 3 4 5 E 00013150 6 7 8 9 10 E 00013200 M 00013250 M 00013300 $JOB ASSIST MACRO=F 00000050 MACRO 00000100 &LABEL QSAVE ®S=(14,12),&BASE=12,&SA=* 00000150 GBLC &SAVADDR 00000200 LCLA &DISP,&CNTR,&TBASE 00000250 LCLC &NAME 00000300 &LABEL DS 0F . DEFINE LABEL, ALLIGN 00000350 AIF (&BASE EQ 13).ERROR . IF BASE IS R13,R14, OR R15 00000400 AIF (&BASE EQ 14).ERROR . ILLEGAL, SET DEFAULT VALUE 00000450 AIF (&BASE NE 15).OKAY 00000500 .ERROR MNOTE 'ILLEGAL BASE REGISTER' 00000550 &TBASE SETA 12 00000600 AGO .SKIP 00000650 .OKAY ANOP 00000700 &TBASE SETA &BASE 00000750 .SKIP USING *,15 00000800 &CNTR SETA 0-1 00000850 AIF ('&LABEL' EQ '').CSECTNM 00000900 .AGAIN ANOP 00000950 &CNTR SETA &CNTR+2 00001000 AIF ('&LABEL'(1,&CNTR) LT '&LABEL').AGAIN 00001050 &NAME SETC '&LABEL' 00001100 AGO .IDFIELD 00001150 .CSECTNM ANOP 00001200 &CNTR SETA &CNTR+2 00001250 AIF ('&SYSECT'(1,&CNTR) LT '&SYSECT').CSECTNM 00001300 &NAME SETC '&SYSECT' 00001350 .IDFIELD B 1+&CNTR+4(,15) 00001400 DC X'&CNTR',CL.&CNTR'&NAME' 00001450 AIF (®S(1) EQ 14).ASPECAL .IS ®S(1) 14 OR 15 00001500 AIF (®S(1) NE 15).AREGULR .IF YES GO TO ASPECAL 00001550 .ASPECAL ANOP 00001600 &DISP SETA ((®S(1)-14)*4)+12 . DISPLACEMENT FOR R14&R15 00001650 AGO .ARESUME 00001700 .AREGULR ANOP 00001750 &DISP SETA (®S(1)*4)+20 . DISPLACEMENT FOR R0-R12 00001800 .ARESUME STM ®S(1),®S(2),&DISP.(13). SAVE REGISTERS 00001850 AIF ('&SA' EQ 'NO').NOSAVE .SIP SAVE AREA 00001900 AIF ('&SA' EQ '*').DEFAULT 00001950 &SAVADDR SETC '&SA' 00002000 AGO .AROUND 00002050 .DEFAULT ANOP 00002100 &SAVADDR SETC '&SYSECT'(1,3).'&SYSNDX'(2,3).'S' .GENERATE NAME 00002150 .AROUND LA &TBASE,&SAVADDR . GET SAVE AREA ADDR 00002200 ST &TBASE,8(13) . PTR TO NEW SAVE AREA 00002250 ST 13,4(&TBASE) . PTR TO OLD SAVE AREA 00002300 LR 13,&TBASE . GET IN RIGHT SAVE AREA 00002350 .NOSAVE BALR &TBASE,0 00002400 DROP 15 . DELETE TEMP BASE REG 00002450 USING *,&TBASE . USING NEW BASE REG 00002500 MEND 00002550 SPACE 5 00002600 MACRO 00002650 &LABEL QRETURN ®S=(14,12),&SA=* 00002700 GBLC &SAVADDR 00002750 LCLA &DISP 00002800 &LABEL DS 0H . DEFINE LABEL, ALLIGN 00002850 AIF (®S(1) EQ 14).BSPECAL .IS REG(1) 14 OR 15 00002900 AIF (®S(1) NE 15).BREGULR .IF YES GO TO BSPECAL 00002950 .BSPECAL ANOP 00003000 &DISP SETA ((®S(1)-14)*4)+12 . DISPLACDMENT FOR R14&R15 00003050 AGO .BRESUME 00003100 .BREGULR ANOP 00003150 &DISP SETA (®S(1)*4)+20 . DISPLACEMENT FOR R0-R12 00003200 .BRESUME AIF ('&SA' EQ 'NO').NORESTR 00003250 L 13,4(13) . RESTORE PREVIOUS SA PTR 00003300 LM ®S(1),®S(2),&DISP.(13) .STANDARD REG RESTORA 00003350 BR 14 . RETURN TO CALLER 00003400 &SAVADDR DC 18F'0' . SAVE AREA, USING GENERATED 00003450 MEXIT 00003500 .NORESTR LM ®S(1),®S(2),&DISP.(13) .STANDARD REG RESTORA 00003550 BR 14 . RETURN TO CALLER 00003600 MEND 00003650 SPACE 5 00003700 MACRO 00003750 &LABEL FREEHDR &NUMBER,&LENGTH 00003800 GBLA &FREENUM(20),&FREELEN(20),&FREECTR 00003850 GBLB &FREEOFF 00003900 AIF (&FREEOFF).ERROR2 00003950 AIF (&FREECTR GE 20).ERROR1 00004000 &FREECTR SETA &FREECTR+1 00004050 &LABEL DC A(FR&FREECTR) 00004100 &FREENUM(&FREECTR) SETA &NUMBER 00004150 &FREELEN(&FREECTR) SETA &LENGTH 00004200 MEXIT 00004250 .ERROR1 MNOTE 8,'***MORE THAN 20 CALLS MADE ON FREEHDR**' 00004300 &FREEOFF SETB 1 00004350 MEXIT 00004400 .ERROR2 MNOTE *,'***FREEHDR HAS BEEN DISABLED**' 00004450 MEND 00004500 SPACE 3 00004550 MACRO 00004600 FREEAREA 00004650 GBLA &FREENUM(20),&FREELEN(20),&FREECTR,&FRCTR 00004700 AIF (&FREECTR GT &FRCTR). MORE 00004750 MNOTE *,'**CALL TO FREEAREA RESULTED IN NO PROCESSING**' 00004800 MEXIT 00004850 .MORE ANOP 00004900 &FRCTR SETA &FRCTR+1 00004950 FR&FRCTR DS 0F 00005000 .NEXT AIF (&FREENUM(&FRCTR) LE 1).LAST 00005050 DC A(*+4*(&FREELEN(&FRCTR)+1)),&FREELEN(&FRCTR)F'0' 00005100 &FREENUM(&FRCTR) SETA &FREENUM(&FRCTR)-1 00005150 AGO .NEXT 00005200 .LAST DC A(0),&FREELEN(&FRCTR)F'0' 00005250 AIF (&FRCTR LT &FREECTR).MORE 00005300 MEND 00005350 SPACE 3 00005400 MACRO 00005450 &LABEL LISTHDR 00005500 &LABEL DC 4F'0' 00005550 MEND 00005600 SPACE 3 00005650 MACRO 00005700 &LABEL GETFREE &FRHDR,®,&END 00005750 &LABEL L ®,&FRHDR . GET PTR TO TOP 00005800 LTR ®,® . IS LIST EMPTY 00005850 BZ &END . YES, TAKE EXCEPTION EXIT 00005900 MVC &FRHDR.(4),0(®) . NO, DELINK 00005950 MEXIT 00006000 &END SR 0,0 00006050 MEND 00006100 SPACE 3 00006150 MACRO 00006200 &LABEL PUTFREE &FRHDR,® 00006250 &LABEL MVC 0(4,®),&FRHDR . RETURN NODE 00006300 ST ®,&FRHDR . TO TOP OF FREE LIST 00006350 MEND 00006400 SPACE 3 00006450 MACRO 00006500 &LABEL PUTNODE &HDR,®,&KEY=4,&KEYLEN=4,&LENGTH=0,&MSG= 00006550 GBLB &NOTRC 00006600 LCLC &SVAREA,&LAB 00006650 &SVAREA SETC '&SYSECT'(1,3).'&SYSNDX'.'S' 00006700 &LAB SETC '&SYSECT'(1,3).'&SYSNDX'.'L' 00006750 STM 1,3,&SVAREA . SAVE R1, R2, R3 00006800 LR 3,® . ADDR OF NODE TO BE PUT IN 00006850 LA 1,&HDR 00006900 L &KEYLEN,&KEY.(1) 00006950 LA &KEYLEN,1(&KEYLEN) . ADD 1 TO CURRENT LEN CNTR 00007000 ST &KEYLEN,&KEY.(1) 00007050 C &KEYLEN,&LENGTH.(1) . IF CURRENT LENGTH 00007100 BNH *+8 . IS GREATER THAN MAX 00007150 ST &KEYLEN,&LENGTH.(1) . THEN CHANGE MAX 00007200 &LAB LR &KEYLEN,1 . TRANSVERSE LIST 00007250 L 1,0(1) 00007300 LTR 1,1 . IF WE ARE AT END 00007350 BZ *+14 . PUT NEW NODE HERE 00007400 CLC &KEY.(2,1),&KEY.(3) . SHOULD NODE GO IN 00007450 BNH &LAB . NOT YET 00007500 ST 1,0(3) . PUT IN NEW NODE 00007550 ST 3,&HDR 00007600 LR ®,3 00007650 LM 1,3,&LAB . RESTORE R1,R2,R3 00007700 AIF (&NOTRC EQ 1).NOTRACE . OMIT TRACE 00007750 AIF (K'&MSG EQ 0).HDR . PRINT HDR IF NO MSG 00007800 XPRNT =CL(13+K'&MSG)'0ADDITION TO &MSG',13+K'&MSG 00007850 AGO .DUMP 00007900 .HDR XPRNT =CL(13+K'&HDR)'0ADDITION TO &HDR',13+K'&HDR 00007950 .DUMP XDUMP &KEY.(®),&LENGTH 00008000 XDUMP 00008050 .NOTRACE B &SVAREA+12 00008100 &SVAREA DC 3F'0' 00008150 MEND 00008200 SPACE 3 00008250 MACRO 00008300 &LABEL DELETE &HDR,®,&END,&LENGTH=0,&MSG= 00008350 GBLB &NOTRC 00008400 LCLC &SVAREA,&LABM,&LABE,&LABL 00008450 &SVAREA SETC '&SYSECT'(1,3).'&SYSNDX'.'S' 00008500 &LABM SETC '&SYSECT'(1,3).'&SYSNDX'.'M' 00008550 &LABE SETC '&SYSECT'(1,3).'&SYSNDX'.'E' 00008600 &LABL SETC '&SYSECT'(1,3).'&SYSNDX'.'L' 00008650 STM 1,3,&SVAREA . SAVE R1, R2, R3 00008700 LR 3,® 00008750 LA 1,&HDR 00008800 &LABL LR &HDR,1 . TRANSVERSE LIST 00008850 L 1,0(1) 00008900 LTR 1,1 . IF DONE, ITEM 00008950 BZ &LABM . WAS NOT IN LIST 00009000 CR 1,3 00009050 BNE &LABL . TRY NEXT NODE 00009100 MVC 0(4,®),0(1) . GOT IT NOW DELINK 00009150 LA 1,&HDR . UPDATE LENGTH 00009200 L ®,4(1) 00009250 BCTR ®,0 00009300 ST ®,4(1) 00009350 LM 1,3,&SVAREA . RESTORE R1, R2, R3 00009400 AIF (&NOTRC EQ 1).NO 00009450 XPRNT =CL(15+K'&HDR)'0DELETION FROM &HDR',15+K'&HDR 00009500 .NO XDUMP 00009550 B &LABE 00009600 &SVAREA DC 3F'0' 00009650 &LABM LM 1,3,&SVAREA . RESTORE R1, R2, R3 00009700 B &END 00009750 &LABE EQU * 00009800 &END SR 0,0 00009850 MEND 00009900 SPACE 3 00009950 MACRO 00010000 &LABEL POP &HDR,®,&END,&LENGTH=0,&MSG= 00010050 &LABEL L ®,&HDR . ADDR OF NODE TO REMOVE 00010100 &LABEL DELETE &HDR,®,&END,LENGTH=&LENGTH,MSG=&MSG 00010150 MEND 00010200 MACRO 00010250 SETGBL &CATNO=1,&IONO=1,&NOTRACE=NO 00010300 GBLA &CAT,&ION 00010350 GBLB &NOTRC 00010400 &CAT SETA &CATNO 00010450 &ION SETA &IONO 00010500 &NOTRC SETB 0 00010550 AIF ('&NOTRACE' EQ 'NO').DONE 00010600 &NOTRC SETB 1 00010650 .DONE MEND 00010700 SPACE 3 00010750 MACRO 00010800 LISTS 00010850 GBLA &CAT,&ION 00010900 .* GENERATE LIST HEADERS 00010950 CRLISTS CATHDR,&CAT 00011000 CRLISTS IOQHDR,&ION 00011050 MEND 00011100 SPACE 3 00011150 MACRO 00011200 CRLISTS &PREFIX,&NUM 00011250 LCLA &COUNT 00011300 .MORE ANOP 00011350 &COUNT SETA &COUNT+1 00011400 &PREFIX&COUNT LISTHDR 00011450 AIF (&COUNT LT &NUM).MORE 00011500 MEND 00011550 SETGBL 00011600 DATA CSECT 00011650 EVQFR FREEHDR 3,3 00011700 DQFR FREEHDR 18,3 00011750 LISTS 00011800 RJQHDR LISTHDR 00011850 EVQHDR LISTHDR 00011900 FREEAREA 00011950 DQEL DSECT 00012000 DQLINK DS F 00012050 DQKEY DS CL8 00012100 EVQEL DSECT 00012150 EVQLINK DS F 00012200 EVQKEY DS CL8 00012250 TITLE 'TEST' 00012300 PRINT GEN 00012350 TEST CSECT 00012400 QSAVE , 00012450 L 11,DATAADR 00012500 USING DATA,11 00012550 USING EVQEL,1 00012600 USING DQEL,3 00012650 GETFREE EVQFR,ERROR 00012700 MVC EVQKEY,EVENT1 00012750 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00012800 GETFREE EVQFR,1,ERROR 00012850 MVC EVQKEY,EVENT2 00012900 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00012950 GETFREE EVQFR,1,ERROR 00013000 MVC EVQKEY,EVENT1 00013050 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00013100 LR 2,1 00013150 GETFREE EVQFR,1,UNDER1 00013200 B ERROR 00013250 UNDER1 XDUMP EVQHDR,16 00013300 DELETE EVQHDR,2,ERROR,LENGTH=8 00013350 PUTFREE EVQFR,2 00013400 DELETE EVQFR,2,OK 00013450 B ERROR 00013500 OK GETFREE EVQHDR,1,ERROR 00013550 MVC EVQKEY,EVENT3 00013600 SETGBL NOTRACE=YES 00013650 PUTNODE EVQHDR,1,KEYLEN=6 00013700 SETGBL NOTRACE=NO 00013750 CONTINUE POP EVQHDR,1,DONE,LENGTH=8 00013800 PUTFREE EVQFR,1 00013850 B CONTINUE 00013900 DONE LA 5,JQE1 00013950 GETMORE GETFREE DQFR,3,UNDER2 00014000 MVC DQKEY,0(5) 00014050 PUTNODE CATHDR1,3,KEYLEN=2,LENGTH=8,MSG='CAT' 00014100 SETGBL NOTRACE=YES 00014150 GETFREE DQFR,3,ERROR 00014200 MVC DQKEY,0(5) 00014250 PUTNODE RJQHDR,3,KEY=6,KEYLEN=2 00014300 GETFREE DQFR,3,ERROR 00014350 MVC DQKEY,0(5) 00014400 PUTNODE IOQHDR1,3,KEY=8,KEYLEN=2 00014450 LA 5,8(5) 00014500 B GETMORE 00014550 SETGBL NOTRACE=NO 00014600 UNDER2 POP CATHDR1,1,ALLDONE,LENGTH=8 00014650 POP RJQHDR,1,ERROR,LENGTH=8 00014700 POP IOQHDR1,1,ERROR,LENGTH=8 00014750 B UNDER2 00014800 ERROR XPRNT =CL6'0ERROR',6 00014850 ALLDONE XDUMP CATHDR1,64 00014900 QRETURN SA=* 00014950 EVENT1 DC F'5',H'1,2' 00015000 EVENT2 DC F'6',H'0,0' 00015050 EVENT3 DC F'5',H'0,0' 00015100 JQE1 DC H'1,2,3,1' 00015150 DC H'2,3,1,2' 00015200 DC H'3,1,2,3' 00015250 DC H'3,2,1,4' 00015300 DC H'2,1,3,5' 00015350 DC H'1,3,2,6' 00015400 DATAADR DC V(DATA) 00015450 END TEST 00015500 $JOB ASSIST MACRO=F 00015550 MACRO 00015600 &LABEL QRETURN ®S=(14,12),&SA=* 00015650 GBLC &SAVL 00015700 LCLA &D 00015750 &LABEL DS 0H . LABEL 00015800 AIF ('&SA' EQ 'NO').NOSAV 00015850 L 13,4(13) . GET OLD POINTER 00015900 .NOSAV AIF (T'®S(1) NE 'N').EREG 00015950 &D SETA ®S(1)*4+20 00016000 AIF (&D LE 75).LOADA 00016050 &D SETA &D-64 00016100 .LOADA AIF (N'®S NE 2).LOAD1 00016150 LM ®S(1),®S(2),&D.(13) . RESTORE REGS 00016200 AGO .RET 00016250 .LOAD1 AIF (N'®S NE 1).EREG 00016300 L ®S(1),&D.(13) . SAVE ONLY ONE REG 00016350 .RET BR 14 . RETURN 00016400 AIF ('&SA' NE 'NO').GOON 00016450 MEXIT 00016500 .GOON AIF ('&SA' NE '*').USEN 00016550 &SAVL DC 18F'0' . SAVE AREA 00016600 MEXIT 00016650 .USEN ANOP 00016700 &SA DC 18F'0' . SAVE AREA 00016750 MEXIT 00016800 .EREG MNOTE 8,'***REGISTERS CANNOT BE RETURNED-SPECIFICATION ERROR' 00016850 MEND 00016900 MACRO 00016950 &LABEL QSAVE ®S=(14,12),&BASE=12,&SA=* 00017000 GBLA &GINS 00017050 GBLC &SAVL 00017100 LCLA &LABLN,&BRDIST,&D 00017150 LCLC &LAB2,&BAS2 00017200 &LAB2 SETC '&LABEL' 00017250 &LABLN SETA K'&LABEL 00017300 &BAS2 SETC '&BASE' 00017350 USING *,15 . SET UP TEMP ADDS 00017400 AIF (&LABLN NE 0).LAB 00017450 CSTLNG &SYSECT 00017500 &LABLN SETA &GINS 00017550 .LAB ANOP 00017600 &LAB2 SETC '&SYSECT' 00017650 &BRDIST SETA (&LABLN+2)/2*2+4 00017700 &LABEL B &BRDIST.(,15) . CONVENTIONS FOR NAME 00017750 DC X'&LABLN',CL(&LABLN)'&LAB2' 00017800 AIF (T'®S(1) NE 'N').EREG 00017850 &D SETA ®S(1)*4+20 00017900 AIF (&D LE 75).STOREA 00017950 &D SETA &D-64 00018000 .STOREA AIF (N'®S NE 2).STORE1 00018050 STM ®S(1),®S(2),&D.(13) . SAVE CALLERS REGS 00018100 AGO .SAVE 00018150 .STORE1 AIF (N'®S NE 1).EREG 00018200 ST ®S(1),&D.(13) .***ONLY ONE REG SAVED 00018250 .SAVE AIF ('&BAS2' LE '12').OK 00018300 MNOTE 4,'***REG &BASE NOT A LEGAL BASE REG-REG 12 USED' 00018350 &BAS2 SETC '12' 00018400 .OK AIF ('&SA' EQ 'NO').NOSAV 00018450 AIF ('&SA' NE '*').USEN 00018500 &SAVL SETC '&SYSECT'(1,3).'&SYSNDX.S' 00018550 LA &BAS2,&SAVL 00018600 AGO .SETSAV 00018650 .USEN LA &BAS2,&SA . SAVE AREA CONVENTIONS 00018700 .SETSAV ST &BAS2,8(13) 00018750 ST 13,4(&BAS2) 00018800 LR 13,&BAS2 00018850 .NOSAV BALR &BAS2,0 . ADDRESSABILITY 00018900 DROP 15 00018950 USING *,&BAS2 00019000 MEXIT 00019050 .EREG MNOTE 8,'***REGISTERS NOT SAVED DUE TO SPEDC ERROR' 00019100 MEND 00019150 MACRO 00019200 CSTLNG &NAME 00019250 GBLA &GINS 00019300 &GINS SETA K'&NAME 00019350 MEND 00019400 MACRO 00019450 SETGBL &TR 00019500 GBLB &NOTRC 00019550 AIF ('&TR' NE 'NO').GOON 00019600 &NOTRC SETB 1 00019650 .GOON MEND 00019700 MACRO 00019750 &LABEL FREEHDR &NUMBER,&LENGTH 00019800 GBLA &FREENUM(20),&FREELEN(20),&FREECTR 00019850 GBLB &FREEOFF 00019900 AIF (&FREEOFF).ERROR2 00019950 AIF (&FREECTR GE 20).ERROR1 00020000 &FREECTR SETA &FREECTR+1 00020050 &LABEL DC A(FR&FREECTR) 00020100 &FREENUM(&FREECTR) SETA &NUMBER 00020150 &FREELEN(&FREECTR) SETA &LENGTH 00020200 MEXIT 00020250 .ERROR1 MNOTE 8,'**MORE THAN 20 CALLS MADE ON FREEHDR**' 00020300 &FREEOFF SETB 1 00020350 MEXIT 00020400 .ERROR2 MNOTE *,'**FREEHDR HAS BEEN DISABLED**' 00020450 MEND 00020500 MACRO 00020550 FREEAREA 00020600 GBLA &FREENUM(20),&FREELEN(20),&FREECTR,&FRCTR 00020650 AIF (&FREECTR GT &FRCTR).MORE 00020700 MNOTE *,'**CALL TO FREEAREA RESULTED IN NO PROCESSING**' 00020750 MEXIT 00020800 .MORE ANOP 00020850 &FRCTR SETA &FRCTR+1 00020900 FR&FRCTR DS 0F 00020950 .NEXT AIF (&FREENUM(&FRCTR) LE 1).LAST 00021000 DC A(*+4*(&FREELEN(&FRCTR)+1)),&FREELEN(&FRCTR)F'0' 00021050 &FREENUM(&FRCTR) SETA &FREENUM(&FRCTR)-1 00021100 AGO .NEXT 00021150 .LAST DC A(0),&FREELEN(&FRCTR)F'0' 00021200 AIF (&FRCTR LT &FREECTR).MORE 00021250 MEND 00021300 MACRO 00021350 &LABEL LISTHDR 00021400 &LABEL DC 4F'0' 00021450 MEND 00021500 MACRO 00021550 &LABEL GETFREE &FRHDR,®,&END 00021600 &LABEL L ®,&FRHDR .GET LINK TO NODE 00021650 LTR ®,® . IS IT THE NULL LIKN 00021700 BZ &END . IF SO THERE IS NO LINL 00021750 MVC &FRHDR.(4),0(®) . DELINK 00021800 MEND 00021850 MACRO 00021900 &LABEL PUTFREE &FRHDR,® 00021950 &LABEL MVC 0(4,®),&FRHDR . RETURN NODE 00022000 ST ®,&FRHDR . NEW TOP LINK 00022050 MEND 00022100 MACRO 00022150 &LABEL PUTNODE &HDR,®,&KEY=4,&KEYLEN=4,&LENGTH=0,&MSG= 00022200 GBLB &NOTRC 00022250 LCLA &KONT 00022300 LCLC &CHAR 00022350 &LABEL DS 0H . DEFINE LABEL 00022400 CNOP 0,4 . ASSURE CORRECT ALIGNMENT 00022450 STM 14,0,EP&SYSNDX.A+4 . SAVE WORKING REGS 00022500 LA 0,&HDR . PARAMETER 00022550 ST 0,EP&SYSNDX.A+16 . STORE PARAM 00022600 LR 0,® TRANSFER FOR CALL 00022650 L 15,EP&SYSNDX.A . ENTRYPOINT 00022700 BALR 14,15 . GO TO SUBR 00022750 EP&SYSNDX.A DC V(PUTNODE) 00022800 DC 4F'0' . SAVE AREA 00022850 DC AL1(&KEYLEN) 00022900 DC AL3(&KEY) 00022950 LM 14,0,4(14) . RESTORE SECOND SET OF REGS 00023000 AIF (&NOTRC).NOTR 00023050 &CHAR SETC '&HDR' 00023100 &KONT SETA K'&HDR 00023150 AIF (K'&MSG EQ 0).GENP 00023200 &CHAR SETC '&MSG' 00023250 &KONT SETA K'&MSG 00023300 .GENP ANOP 00023350 &KONT SETA &KONT+13 00023400 XPRNT =CL&KONT' ADDITION TO &CHAR',&KONT 00023450 AIF (&LENGTH EQ 0).REGO 00023500 XDUMP 4(®),&LENGTH . DUMP THE NODE 00023550 .REGO XDUMP , . DUMP REGS 00023600 .NOTR MEND 00023650 MACRO 00023700 &LABEL DELETE &HDR,®,&END,&LENGTH=0,&MSG= 00023750 GBLB &NOTRC 00023800 LCLA &KONT 00023850 LCLC &CHAR 00023900 &LABEL DS 0H 00023950 CNOP 0,4 . ASSURE CORRECT ALIGNMENT 00024000 STM 14,0,ENT&SYSNDX.D+4 . SAVE FIRST REGS 00024050 LA 0,&HDR 00024100 ST 0,ENT&SYSNDX.D+16 00024150 LR 0,® . SAVE REG TO CSECT 00024200 L 15,ENT&SYSNDX.D . ENTRYPOINT 00024250 BALR 14,15 . CALL SUBR 00024300 ENT&SYSNDX.D DC V(DELETE) 00024350 DC 4F'0' . CONTROL BLOCK SAVE AREA 00024400 LTR 15,15 . TEST FOR RESULTS 00024450 LM 14,0,4(14) . RETURN TOP LEVEL REGS 00024500 BNZ &END IF WAS NOT GO TO END 00024550 AIF (&NOTRC).NOTR 00024600 &CHAR SETC '&HDR' 00024650 &KONT SETA K'&HDR 00024700 AIF (K'&MSG EQ 0).GENP 00024750 &CHAR SETC '&MSG' 00024800 &KONT SETA K'&MSG 00024850 .GENP ANOP 00024900 &KONT SETA &KONT+15 00024950 XPRNT =CL&KONT' DELETION FROM &CHAR',&KONT 00025000 XDUMP , . DUMP REGS 00000050 .NOTR MEND 00000100 PRINT ON 00000150 MACRO 00000200 &LABEL POP &HDR,®,&END,&LENGTH=0,&MSG= 00000250 &LABEL L ®,&HDR . MAKE IT THE FIRAST NODE 00000300 DELETE &HDR,®,&END,LENGTH=&LENGTH,MSG=&MSG 00000350 MEND 00000400 MACRO 00000450 SETGBL &CATNO=1,&IONO=1,&NOTRACE=NO 00000500 GBLA &CAT,&ION 00000550 GBLB &NOTRC 00000600 &CAT SETA &CATNO 00000650 &ION SETA &IONO 00000700 &NOTRC SETB 0 00000750 AIF ('&NOTRACE' EQ 'NO').DONE 00000800 &NOTRC SETB 1 00000850 .DONE MEND 00000900 MACRO 00000950 LISTS 00001000 GBLA &CAT,&ION 00001050 .* GENERATE LIST HEADERS 00001100 CRLISTS CATHDR,&CAT 00001150 CRLISTS IOQHDR,&ION 00001200 MEND 00001250 MACRO 00001300 CRLISTS &PREFIX,&NUM 00001350 LCLA &COUNT 00001400 .MORE ANOP 00001450 &COUNT SETA &COUNT+1 00001500 &PREFIX&COUNT LISTHDR 00001550 AIF (&COUNT LT &NUM).MORE 00001600 MEND 00001650 PUTNODE CSECT 00001700 * ROUTINE TO PUT A NODE INTO A LIST BY KEYWORD 00001750 * USES SPECIAL NON-DESTRUSTIVE LINKAGE 00001800 USING PUTNODE,15 ADDRESSABILITY 00001850 STM 1,7,PUSAVE SAVE WORKING REGS 00001900 SR 7,7 CLEAR A EREG 00001950 IC 7,20(14) GET &KEYLEN 00002000 LR 3,0 TRANS R0 TO A USEABLE REG 00002050 L 4,20(14) GET KEY 00002100 LA 6,0(4,3) FOR OPERATIONAL EASE 00002150 L 1,16(14) ADDR OF &HDR 00002200 L 2,4(1) INCREMENT 00002250 LA 2,1(2) LENGTH CNTR 00002300 ST 2,4(1) STORE NEW CURRENT LENGTH 00002350 C 2,8(1) IS LENGTH>MAX 00002400 BNH PUNOCHNG IF NOT DONT CHANGE 00002450 ST 2,8(1) UPDATE MAX 00002500 PUNOCHNG LR 2,1 SAVE R1 00002550 L 1,0(1) GET LIMK 00002600 LTR 1,1 IS IT THE NULL LINK 00002650 BZ PUNEW0 IF SO WE ARE DONE 00002700 LA 5,0(1,4) SET UP ADDR FOR EX 00002750 EX 7,PUCLC COMPARE KEYS 00002800 BNH PUNOCHNG IF NOT HIGH TRY SOME MORE 00002850 PUNEW0 ST 1,0(3) PUT IN NEW NODE 00002900 ST 3,0(2) AND LINK UP 00002950 LM 1,7,PUSAVE RESTORE 00003000 B 28(14) RETURN 00003050 PUCLC CLC 0(0,5),0(6) USED BY EX 00003100 PUSAVE DC 7F'0' SAVE AREA 00003150 DELETE CSECT 00003200 * ROUTINE TO DELETE A GIVEN NODE FROM A LIST 00003250 * USES SPECIAL NON-DESTRUSTIVE LINKAGE 00003300 USING DELETE,15 ADDRESSABILITY 00003350 STM 1,3,DESAV SAVE WORKING REGS 00003400 L 1,16(14) ADDR OF &HDR 00003450 LR 3,1 COPY REG 1 00003500 DETOPL LR 2,1 COPY REG 1 00003550 L 1,0(1) LINK 00003600 LTR 1,1 IS IT END 00003650 BZ DENOTL IF SO WE ARE DONE 00003700 CR 1,0 IS IT THE ONE 00003750 BNE DETOPL IF NOT TRY AGAIN 00003800 MVC 0(4,2),0(1) DELINK NODE 00003850 L 2,4(3) UPDATE LENGCH 00003900 BCTR 2,0 BY DECREMENT BY 1 00003950 ST 2,4(3) STORE NEW LENGTH 00004000 SR 15,15 SET FLAG--NORMAL RETURN 00004050 DERETL LM 1,3,DESAV RETURN WORKING REGS 00004100 B 20(14) RETURN 00004150 DENOTL LA 15,1 SET RETUNR CODE--ITEM NOT IN LIST 00004200 B DERETL 00004250 DESAV DS 3F'0' SAVE AREA 00004300 SETGBL 00004350 DATA CSECT 00004400 EVQFR FREEHDR 3,3 00004450 DQFR FREEHDR 18,3 00004500 LISTS 00004550 RQJHDR LISTHDR 00004600 EVQHDR LISTHDR 00004650 FREEAREA 00004700 DQEL DSECT 00004750 DQLINK DS F 00004800 DQKEY DS CL8 00004850 EVQEL DSECT 00004900 EVQLINK DS F 00004950 EVQKEY DS CL8 00005000 TITLE 'TEST' 00005050 PRINT GEN 00005100 TEST CSECT 00005150 QSAVE 00005200 L 11,DATAADR 00005250 USING DATA,11 00005300 USING EVQEL,1 00005350 USING DQEL,3 00005400 GETFREE EVQFR,1,ERROR 00005450 MVC EVQKEY,EVENT1 00005500 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00005550 GETFREE EVQFR,1,ERROR 00005600 MVC EVQKEY,EVENT1 00005650 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00005700 GETFREE EVQFR,1,ERROR 00005750 MVC EVQKEY,EVENT1 00005800 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00005850 LR 2,1 00005900 GETFREE EVQFR,1,UNDER1 00005950 B ERROR 00006000 UNDER1 XDUMP EVQHDR,16 00006050 DELETE EVQHDR,2,ERROR,LENGTH=8 00006100 PUTFREE EVQFR,2 00006150 DELETE EVQHDR,2,OK 00006200 B ERROR 00006250 OK GETFREE EVQHDR,1,ERROR 00006300 MVC EVQKEY,EVENT3 00006350 SETGBL NOTRACE=YES 00006400 PUTNODE EVQHDR,1,KEYLEN=6 00006450 SETGBL NOTRACE=NO 00006500 CONTINUE POP EVQHDR,1,DONE,LENGTH=8 00006550 PUTFREE EVQFR,1 00006600 B CONTINUE 00006650 DONE LA 5,JQE1 00006700 GETMORE GETFREE DQFR,3,UNDER2 00006750 MVC DQKEY,0(5) 00006800 PUTNODE CATHDR1,3,KEYLEN=2,LENGTH=8,MSG='CAT' 00006850 SETGBL NOTRACE=YES 00006900 GETFREE DQFR,3,ERROR 00006950 MVC DQKEY,0(5) 00007000 PUTNODE RJQHDR,3,KEY=6,KEYLEN=2 00007050 GETFREE DQFR,3,ERROR 00007100 MVC DQKEY,0(5) 00007150 PUTNODE IOQHDR1,3,KEY=8,KEYLEN=2 00007200 LA 5,8(5) 00007250 B GETMORE 00007300 SETGBL NOTRACE=NO 00007350 UNDER2 POP CATHDR1,1,ALLDONE,LENGTH=8 00007400 POP RJQHDR1,1,ERROR,LENGTH=8 00007450 POP IOQHDR1,1,ERROR,LENGTH=8 00007500 B UNDER2 00007550 ERROR XPRNT =CL6'0ERROR',6 00007600 ALLDONE XDUMP CATHDR1,64 00007650 QRETURN 00007700 EVENT1 DC F'5',H'1,2' 00007750 EVENT2 DC F'6',H'0,0' 00007800 EVENT3 DC F'5',H'0,0' 00007850 JQE1 DC H'1,2,3,1' 00007900 DC H'2,3,1,2' 00007950 DC H'3,1,2,3' 00008000 DC H'3,2,1,4' 00008050 DC H'2,1,3,5' 00008100 DC H'1,3,2,6' 00008150 DATAADR DC V(DATA) 00008200 LTORG 00008250 END TEST 00008300 $JOASSIST MACRO=F 00008350 CSECT 00008400 BALR 11,0 00008450 USING *,11 00008500 SR 6,6 00008550 SR 7,7 00008600 XREAD CARD 00008650 XDUMP OVER,300 00008700 L 7,=A(CARD) 00008750 OVER CLI 0(7),C' ' 00008800 LA 7,1(7) 00008850 BE SS 00008900 B OVER 00008950 SS LA 6,LAST 00009000 OK MVC 0(1,6),0(7) 00009050 LA 6,1(6) 00009100 LA 7,1(7) 00009150 CLI 0(7),C' ' 00009200 BNE OK 00009250 L 7,=A(CARD) 00009300 IC 6,C' ' 00009350 LA 6,1(6) 00009400 ANEW MVC 0(1,6),0(7) 00009450 CLI 0(7),C' ' 00009500 PRNT XPRNT LAST-1,81 00009550 BE PRNT 00009600 LA 7,1(7) 00009650 LA 6,1(6) 00009700 B ANEW 00009750 BR 14 00009800 DC C'1' 00009850 LAST DS CL80' ' 00009900 CARD DS CL80 00009950 END 00010000 $ENTRY 00010050 LINDA BURNS 00010100 $JOASSIST MACRO=F 00010150 MACRO 00010200 &LABEL DEFLIST &N 00010250 LCLA &CNT 00010300 &CNT SETA &N-2 00010350 LISTHEAD DC A(&LABEL) 00010400 &LABEL DC A(*+80),72C' ',A(0) 00010450 .LOOP DC A(*+80),72C' ',A(*-76) 00010500 &CNT SETA &CNT-1 00010550 AIF (&CNT NE 0).LOOP 00010600 DC A(0),72C' ',A(*-76) 00010650 MEND 00010700 EJECT 00010750 MAIN CSECT 00010800 BEGIN STM 14,12,12(13) 00010850 BALR 12,0 00010900 USING *,12 00010950 SSN EQU 4 00011000 NAME EQU 16 00011050 STATUS EQU 14 00011100 ADDR EQU 46 00011150 FLINK EQU 0 00011200 BLINK EQU 76 00011250 LA 5,LISTHEAD 00011300 L 5,0(5) 00011350 MVC SSN(5),SELECT 00011400 READ XREAD CARD,80 00011450 BC 7,EOF 00011500 MVC TEMP(10),CARD 00011550 MVI TEMP+10,C' ' 00011600 XDECI 2,TEMP 00011650 ST 2,DULLW 00011700 C 2,SSN(5) 00011750 BC 8,ERROR 00011800 BC 2,HIGH 00011850 L 5,FLINK(5) 00011900 MOVE MVC SSN(5),DULLW 00011950 MVC STATUS(5),ISTATUS 00012000 MVC NAME(5),INAME 00012050 MVC ADDR(5),IADDR 00012100 B READ 00012150 HIGH MVC TCARD(72),0(5) 00012200 L 5,FLINK(5) 00012250 MVC 0(72,5),TCARD 00012300 L 5,BLINK(5) 00012350 B MOVE 00012400 EOF LR 4,5 00012450 LA 5,LIST1 00012500 PRINT MVC OSTATUS,STATUS(5) 00012550 MVC ONAME,NAME(5) 00012600 MVC OADDR,ADDR(5) 00012650 L 3,SSN(5) 00012700 CVD 3,DOUBLE 00012750 XPRNT LINE,132 00012800 L 5,0(5) 00012850 CR 5,4 00012900 BC 11,EOJ 00012950 B PRINT 00013000 ERROR MVC LINE,LINE-1 00013050 MVC LINE(16),=C'THIS IS AN ERROR' 00013100 XPRNT LINE,132 00013150 EOJ BR 14 00013200 DC C' ' 00013250 LINE DS 0CL132 00013300 DC 17C' ' 00013350 OSSN DC 10C' ' 00013400 DC 17C' ' 00013450 OSTATUS DC 2C' ' 00013500 DC 9C' ' 00013550 ONAME DC 30C' ' 00013600 DC 9C' ' 00013650 OADDR DC 30C' ' 00013700 DC 8C' ' 00013750 CARD DS 0CL80 00013800 ISSN DS CL10 00013850 ISTATUS DS CL2 00013900 INAME DS CL30 00013950 IADDR DS CL30 00014000 DS CL8 00014050 SELECT DC F'9999999999' 00014100 DULLW DS D 00014150 DOUBLE DS D 00014200 TEMP DS CL10 00014250 TCARD DS CL76 00014300 LTORG 00014350 LIST1 DEFLIST 50 00014400 END 00014450 $ENTRY 00014500 THIS IS ANY OLD CARD 00014550 $JOASSIST MACRO=F 00014600 MACRO 00014650 &LABEL POP &HDR,®,&END,&LENGTH,&MSG 00014700 .* 00014750 .* THIS IS MACRO POP. IT TAKES A NODE OFF OF THE TOP OF THE 00014800 .* LINKED LIST. 00014850 .* 00014900 .* &HDR -ADDRESS OF THE HEADER OF THE LINKED LIST. 00014950 .* ® -REGISTER WITH HEADER OF LINKED LIST. 00015000 .* &END -THIS IS THE LABEL OF SOME INSTRUCTION. 00015050 .* &LENGTH -NUMBER OF BYTES OF DATA PORTION OF NODE ADDED. 00015100 .* &MSG -A QUOTED STRING OF CHARACTERS. 00015150 .* 00015200 L ®,&HDR LOAD HDR INTO REG. 00015250 &LABEL DELETE &HDR,®,&END,&LENGTH,&MSG 00015300 MEND 00015350 MACRO 00015400 &LABEL GETFREE &FRHDR,®,&END 00015450 .* 00015500 .* THIS MACRO GETS A FREE NODE FROM THE FREE LIST WHOSE HEADER 00015550 .* IS AT &FRHDR. 00015600 .* 00015650 .* ® -REGISTER INTO WHICH ADDRESS OF NODE IS PLACED. 00015700 .* &END -AREA OF CODE TO BE GENERATED IF GETFREE FAILS TO GET 00015750 .* ANY FREE SPACE FROM THE LIST. 00015800 .* &LABEL -LABEL TO BE PLACED IN FIRST INSTRUCTION OF GEN. CODE. 00015850 .* &FRHDR -IS A RELOCATABLE EXPRESSION. 00015900 .* ® -ABSOLUTE EXPRESSION BETWEEN 1 AND 15. 00015950 .* &END -LABEL OF SOME INSTRUCTION. 00016000 .* 00016050 &LABEL L ®,&FRHDR GET POINTER TO THE TOP. 00016100 LTR ®,® TEST TO SEE IF LIST NULL. 00016150 BZ &END IF YES TAKE THE EXIT. 00016200 MVC &FRHDR.(4),0(®) NO DELINK TOP CELL. 00016250 MEND 00016300 MACRO 00016350 &LABEL PUTFREE &FRHDR,® 00016400 .* 00016450 .* THE PUTFREE MACRO RETURNS A NODE TO THE FREE LIST. THE 00016500 .* HEADER IS AT &FRHDR. THE ADDRESS OF THE NODE IS IN ®. 00016550 .* 00016600 .* ® -NUMBER BETWEEN 1 AND 15. 00016650 .* &FRHDR - THIS IS A RELOCATEABLE EXPRESSION. 00016700 .* 00016750 &LABEL DS OH 00016800 MVC 0(4,®),&FRHDR RETURN THE NODE TO LIST. 00016850 ST ®,&FRHDR PUT IT ON THE VERY FRONT. 00016900 MEND 00016950 MACRO 00017000 &LABEL PUTNODE &HDR,®,&KEY,&KEYLEN,&LENGTH,&MSG 00017050 .* 00017100 .* PUTNODE PUTS A NODE INTO LINKED LIST WITH HEADER AT &HDR. 00017150 .* THE NODES ADDRESS IS FOUND IN ®. THE INSERTION IS BY ASCEND 00017200 .* ING ORDER AT AN OFFSET OF &KEY BYTES FROM BEGINNING OF NODE. 00017250 .* LENGTH OF KEY IS SPECIFIED BY KEYLEN. THE LIST LENGTH WILL BE 00017300 .* UPDATED. 00017350 .* 00017400 .* &LABEL -THIS IS A LABEL. 00017450 .* ® - THIS IS ABSOLUTE EXPRESSION BETWEEN 1 AND 15. 00017500 .* &HDR - THIS TELLS WHERE HEADER IS. 00017550 .* &KEY - ABSOLUTE EXPRESSION AS DEFINED ABOVE 00017600 .* &KEYLEN -ABSOLUTE EXPRESSION AS DEFINED ABOVE. 00017650 .* &LENGTH -ABSOLUTE EXPRESSION AS DEFINED ABOVE. 00017700 .* &MSG - THIS IS A QUOTED STRING OF CHARACTERS. 00017750 .* 00017800 LCLC &PUT 00017850 &PUT SETC 'PUT0001' 00017900 &LABEL STM 1,3,&PUT.'S' SAVE REGISTERS 1,2,AND3. 00017950 LR 3,® LOAD REGISTER 3 INTO REGISTER 5. 00018000 LA 1,&HDR 00018050 L 2,4(1) ADD ONE TO CURRENT LENGTH COUNTER. 00018100 LA 2,1(2) 00018150 ST 2,4(1) 00018200 C 2,&LENGTH(1) IS CURRENT LENGTH GREATER THAN MAX. 00018250 BNH *+&LENGTH 00018300 ST 2,&LENGTH(1) YES, THEN CHANGE MAX. 00018350 &PUT.'L' LR 2,1 TRANSVERSE THE LIST. 00018400 L 1,0(1) 00018450 LTR 1,1 ARE WE AT THE END. 00018500 BZ *+14 END REACHED, PUT NEW NODE HERE. 00018550 CLC 4(KEYLEN,1),4(3) COMPARE TO SEE IF NODE GOES IN. 00018600 BNH &PUT.'L' FT DOES NOT GO IN YET. 00018650 ST 1,0(3) STORE REGISTER 1 ZERO BEYOND 3. 00018700 ST 3,&HDR STORE REGISTER 3 INTO &HDR. 00018750 LR ®,3 RELOAD REGISTER 3 INTO ®. 00018800 LM 1,3,&PUT.'S' RESTORE REGISTERS 1,2,AND3. 00018850 XPRNT =CL(13+3)' ADDITION TO &MSG ',13+3 00018900 XDUMP 4(®),&LENGTH 00018950 B &PUT.'S'+12 00019000 &PUT.'S' DC 3F'0' 00019050 MEND 00019100 MACRO 00019150 &LABEL DELETE &HDR,®,&END,&LENGTH,&MSG 00019200 .* 00019250 .* THE DELETE MACRO DELETES A NODE FROM THE LINKED LIST. 00019300 .* 00019350 .* ® -ADDRESS OF NODE TO BE DELETED. 00019400 .* &HDR -HEADER OF LINKED LIST. 00019450 .* &END -THIS IS LABEL OF SOME INSTRUCTION TO WHICH TO BRANCH. 00019500 .* &LENGTH -LENGTH OF BYTES OF NODE TO BE DELETED. 00019550 .* &MSG -THIS IS A MESSAGE. 00019600 .* 00019650 LCLC &PUT 00019700 &PUT SETC 'DEL0005' 00019750 STM 1,3,&PUT.'S' SAVE REGISTERS 1,2,AND3. 00019800 LR 3,® 00019850 LA 1,&HDR 00019900 &PUT.'L' LR ®,1 TRANSVERSE THE LIST. 00019950 L 1,0(1) 00020000 LTR 1,1 CHECK TO SEE IF DONE. 00020050 BZ &PUT.'M' YES,ITEM NOT IN LIST. 00020100 CR 1,3 00020150 BNE &PUT.'L' TRY THE NEXT NODE. 00020200 MVC 0(4,®),0(1) GOT THE NODE, NOW DELINK IT. 00020250 LA 1,&HDR UPDATE THE LENGTH NOW. 00020300 L ®,4(1) 00020350 BCTR ®,0 00020400 ST ®,4(1) 00020450 LM ',3,&PUT.'S' RESTORE REGISTERS 1,2,AND3. 00020500 XPRNT =CL(15+5)' DELETION FROM &HDR ',15+5 00020550 XDUMP JUST REGISTERS 00020600 B &PUT.'E' 00020650 &PUT.'S' DC 3F'0' 00020700 &PUT.'M' LM 1,3,&PUT.'S' RESTORE REGISTERS 1,2,AND3. 00020750 B &END 00020800 &PUT.'E' EQU * 00020850 MEND 00020900 MACRO 00020950 &LABEL DUMPLIST &HDR,&NUM,&LEN,&MSG 00021000 .* 00021050 .* THIS MACRO DUMPS THE FIRST &LEN BYTES BEYOND LINK OF EACH OF 00021100 .* THESE UP TO &NUM FIRST NODE IN LINKED LIST WHOSE HEADER=&HDR. 00021150 .* THE MESSAGE 'DUMP OF &HDR' OR 'DUMP OF MSG' IS PRINTED AS 00021200 .* PRELUDE TO DUMP. EACH NODE IS LABELED THRU XSNAP BY THE STRING 00021250 .* 'NEXT NODE' 00021300 .* 00021350 &LABEL XSNAP LABEL='DUMP OF PMSG' 00021400 LCLC &PUT 00021450 STM 1,2,DMP0007S SAVE REGISTERS 1 AND 2. 00021500 L 1,&HDR 00021550 LA 2,&NUM 00021600 &PUT SETC 'DMP0007' 00021650 &PUT.'L' LTR 1,1 IF AT THE END THEN QUIT. 00021700 BZ &PUT.'E' 00021750 XSNAP T=NO,LABEL='NEXT NODE',STORAGE-(*4(1),*&NUM(1)) 00021800 L 1,0(1) 00021850 BCT 2,&PUT.'L' GET THE NEXT NODE 00021900 B &PUT.'E' 00021950 &PUT.'S' DC 2F'0' 00022000 &PUT.'E' LM 1,2,&PUT.'S' 00022050 MEND 00022100 MACRO 00022150 SETGBL &NOTRACE=NO 00022200 GBLA &CAT,&ION 00022250 GBLB &NOTRC 00022300 &CAT SETA 1 00022350 &ION SETA 1 00022400 &NOTRC SETB 0 00022450 AIF ('&NOTRACE' EQ 'NO').DONE 00022500 &NOTRC SETB 1 00022550 .DONE MEND 00022600 MACRO 00022650 LISTS 00022700 GBLA &CAT,&ION 00022750 .* GENERATE LIST HEADERS 00022800 CRLISTS CATHDR,&CAT 00022850 CRLISTS IOQHDR,&ION 00022900 MEND 00022950 MACRO 00023000 CRLISTS &PREFIX,&NUM 00023050 LCLA &COUNT 00023100 .MORE ANOP 00023150 &COUNT SETA &COUNT+1 00023200 &PREFIX&COUNT LISTHDR 00023250 AIF (&COUNT LT &NUM).MORE 00023300 MEND 00023350 SETGBL 00023400 DATA CSECT 00023450 EVQFR FREEHDR 3,3 00023500 DQFR FREEHDR 18,3 00023550 LISTS 00023600 RJQHDR LISTHDR 00023650 EVQHDR LISTHDR 00023700 FREEAREA 00023750 DQEL DSECT 00023800 DQLINK DS F 00023850 DQKEY DS CL8 00023900 EVQEL DSCET 00023950 EVQLINK DS F 00024000 EVQKEY DS CL8 00024050 TITLE 'TEST' 00024100 PRINT GEN 00024150 TEST CSECT 00024200 QSAVE , OR WHAT HAVE (BR=12) 00024250 L 11,DATAADR 00024300 USING DATA,11 00024350 USING EVQEL,1 00024400 USING DQEL,3 00024450 GETFREE EVQFR,1,ERROR 00024500 MVC EVQKEY,EVENT1 00024550 PUTNODE EVQHDR,1,KENLEN=6,LENGTH=8 00024600 GETFREE EVQFR,1,ERROR 00024650 MVC EVQKEY,EVENT2 00024700 PUTNODE EVQHDR,1,KENLEN=6,LENGTH=8 00024750 GETFREE EVQFR,1,ERROR 00024800 MVC EVQKEY,EVENT1 00024850 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00024900 LR 2,1 00024950 GETFREE EVQFR,1,UNDER1 00025000 B ERROR 00000050 UNDER1 XDUMP EVQHDR,16 00000100 DELETE EVQHDR,2,ERROR,LENGTH=8 00000150 PUTFREE EVQFR,2 00000200 DELETE EVQHDR,2,OK 00000250 B ERROR 00000300 OK GETFREE EVQHDR,1,ERROR 00000350 MVC EVQKEY,EVENT3 00000400 SETGBL NOTRACE=YES 00000450 PUTNODE EVQHDR,1,KEYLEN=6 00000500 SETGBL NOTRACE=NO 00000550 CONTINUE POP EVQHDR,1,DONE,LENGTH=8 00000600 PUTFREE EVQFR,1 00000650 B CONTINUE 00000700 DONE LA 5,JQE1 00000750 GETMORE GETFREE DQFR,3,UNDER2 00000800 MVC DQKEY,0(5) 00000850 PUTNODE CATHDR1,3,KEYLEN=2,LENGTH=8,MSG='CAT' 00000900 SETGBL NOTRACE=YES 00000950 GETFREE DQFR,3,ERROR 00001000 MVC DQKEY,0(5) 00001050 PUTNODE RJQHDR,3,KEY=6,KEYLEN=2 00001100 GETFREE DQFR,3,ERROR 00001150 MVC DQKEY,0(5) 00001200 PUTNODE IOQHDR1,3,KEY=8,KEYLEN=2 00001250 LA 5,8(5) 00001300 B GETMORE 00001350 SETGBL NOTRACE=NO 00001400 UNDER2 POP CATHDR1,1,ALLDONE,LENGTH=8 00001450 POP RJQHDR,1,ERROR,LENGTH=8 00001500 POP IOQHDR1,1,ERROR,LENGTH=8 00001550 B UNDER2 00001600 ERROR XPRNT =CL6'OERROR',6 00001650 ALLDONE XDUMP CATHDR1,64 00001700 QRETURN SA=* 00001750 EVENT1 DC F'5',H'1,2' 00001800 EVENT2 DC F'6',H'0,0' 00001850 EVENT3 DC F'5',H'0,0' 00001900 JQE1 DC H'1,2,3,1' 00001950 DC H'2,3,1,2' 00002000 DC H'3,1,2,3' 00002050 DC H'3,2,1,4' 00002100 DC H'2,1,3,5' 00002150 DC H'1,3,2,6' 00002200 DC V(DATA) 00002250 END TEST 00002300 MACRO 00002350 &LABEL FREEHDR &NUMBER,&LENGTH 00002400 GBLA &FREENUM(20),&FREELEN(20),&FREECTR 00002450 GBLB &FREEOFF 00002500 AIF (&FREEOFF).ERROR2 00002550 AIF (&FREECTR GE 20).ERROR1 00002600 &FREECTR SETA &FREECTR+1 00002650 &LABEL DC A(FR&FREECTR) 00002700 &FREENUM(&FREECTR) SETA &NUMBER 00002750 &FREELEN(&FREECTR) SETA &LENGTH 00002800 MEXIT 00002850 .ERROR1 MNOTE 8,'**MORE THAN 20 CALLS MADE ON FREEHDR**' 00002900 &FREEOFF SETB 1 00002950 MEXIT 00003000 .ERROR2 MNOTE *,'**FREEHDR HAS BEEN DISABLED**' 00003050 MEND 00003100 MACRO 00003150 FREEAREA 00003200 GBLA &FREENUM(20),&FREELEN(20),&FREECTR,&FRCTR 00003250 AIF (&FREECTR GT &FRCTR).MORE 00003300 MNOTE *,'**CALL TO FREEAREA RESULTED IN NO PROCESSING**' 00003350 MEXIT 00003400 .MORE ANOP 00003450 &FRCTR SETA &FRCTR+1 00003500 FR&FRCTR DS 0F 00003550 .NEXT AIF (&FREENUM(&FRCTR) LE1).LAST 00003600 DC A(*+4*(&FREELEN(&FRCTR)+1)),&FREELEN(&FRCTR)F'0' 00003650 &FREENUM(&FRCTR) SETA &FREENUM(&FRCTR)-1 00003700 AGO .NEXT 00003750 .LAST DC A(0),&FREELEN(&FRCTR)F'0' 00003800 AIF (&FRCTR LT &FREECTR).MORE 00003850 MEND 00003900 DATA CSECT 00003950 FRLIST1 FREEHDR 200,10 00004000 FRLIST2 FREEHDR 75,3 00004050 FREEAREA 00004100 MAIN CSECT 00004150 XSAVE 00004200 L 11,=V(DATA) 00004250 USING DATA,11 00004300 END 00004350 $JOASSIST MACRO=F 00004400 MACRO 00004450 &LABEL GETFREE &FRHDR,®,&END 00004500 &LABEL L ®,&FRLIST1 GET POINTER TO TOP 00004550 LTR ®,® IS LIST EMPTY 00004600 BZ &END YES, TAKE ERROR RETURN 00004650 MVC &FRHDR(4),0(®) NO,DELINK 00004700 * TOP CELL 00004750 MEND 00004800 MACRO 00004850 &LABEL PUTFREE &FRHDR,® 00004900 &LABEL MVC 0(4,®),&FRHDR RETURN NODE 00004950 ST ®,&FRHDR NODE TO TOPE OF LIST 00005000 MEND 00005050 MACRO 00005100 &LABEL PUTNODE &HDR,®,&KEY, 00005150 &LABEL PUTNODE &HDR,®,&KEY=4,&KEYLEN=4,&LENGTH=0,&MSG= 00005200 &LABEL STM 1,3,PUT&SYSNDX.S SAVE R1,R2,R3 00005250 LR 3,&EEG 00005300 LR 3,® ADDR OF NODE TO BE ADDED 00005350 LA 1,&HDR ADDR OF HEADER TO LINKED LIST 00005400 L 2,4(1) GET CURRENT LENGTH COUNTER 00005450 LA 2,1(2) ADD 00005500 LA 2,1(2) ADD ONE TO CURRENT LENGTH COUNTER 00005550 ST 2,4(1) SAVE UPDATED LENGTH COUNTER 00005600 C 2,8(1) CONPARE CURRENT TO MAX LENGTH LIST 00005650 C 00005700 BNH *+8 00005750 ST 2,8(1) STRE 00005800 ST 2,8(1) STORE NEW MAX LIST LENGTH 00005850 PUT&SYSNDX.L LR 2,1 TRAVERSE LIST 00005900 L 1,0(1) 00005950 LTR 1,1 CHECK FOR END OF LIST 00006000 BZ *+14 00006050 BZ *+14 END, PUT NEW NODE HERE 00006100 CLC &KEY(&KEYLENG 00006150 CLC &KEY(&KEYLEN,1),&KEY(3) SHOULD NEW NODE GO IN 00006200 BNH PUT&SYSNDX.L NOT YET 00006250 00006300 ST 1,0(3) PUT IN NEW NODE 00006350 ST 3,0(2) 00006400 LR 5,3 00006450 LM 1,3,PUT&SYSNDX.S RESTORE R1,R2,R3 00006500 MEND 00006550 MACRO 00006600 &LABEL DELETE &HDR,®,&END,&LENGTH=0,&MSG= 00006650 &LABEL STM 1,3,DEL&SYSNDX.S SAVE R1,R2,R3 00006700 LR 3,2 NODE ADDR INTO REGISTER 00006750 L 00006800 LA 1,&HDR ADDR OF HEADER TO LINKED LIST 00006850 DEL&SYSNDX.L LR 2,1 TRAVERSE LIST 00006900 6 1,0(1) GET LINK 00006950 LTR 1,1 CHECK FOR NULL LINK - END OF LIST 00007000 BZ DEL&SYSNDX.M ITEM NOT IN LIST 00007050 CR 1,3 TEST LINKS 00007100 BNE DEL&SYSNDX.L TRY NEXT NODE 00007150 MVC 0(4,2),0(1) GOT IT, NOW DELETE 00007200 LA 1,&HDR HEADER ADDR 00007250 L 2,4(1) LIST LENGTH 00007300 BCTR 2,0 LENGTH=LENGTH-1 00007350 ST 2,4(1) 00007400 LM 1,3,DEL&SYSNDX.S RESTORE R1-R3 00007450 B DEL&SYSNDX.E BRANCH AROUND DC 00007500 DEL&SYSNDX.S DC 3F'0' REGISTER SAVE AREA 00007550 DEL&SYSNDX.M LM 1,3,DEL&SYSNDX.S RESTORE REG 00007600 B &END ERROR RETURN 00007650 DEL&SYSNDX.E EQU * 00007700 MEND 00007750 MACRO 00007800 &LABEL POP &HDR,®,&END,&LENGTH=0,&MSG= 00007850 &LABEL L ®,&HDR 00007900 &LABEL DELETE &HDR,®,&END,LENGTH=&LENGTH,MSG=&MSG 00007950 MEND 00008000 MACRO 00008050 &LABEL FREEHDR &NUMBER,&LENGTH 00008100 GBLA &FREENUM(20),&FREELEN(20),&FREECTR 00008150 GBLB &FREEOFF 00008200 AIF (&FREEOFF).ERROR2 00008250 AIF (&FREECTR GE 20).ERROR1 00008300 &FREECTR SET &FREECTR+1 00008350 &LABEL DC A(FR&FREECTR) 00008400 &FREENUM(&FREECTR) SETA &NUMBER 00008450 &FREELEN(&FREECTR) SETA &LENGTH 00008500 MEXIT 00008550 .ERROR1 MNOTE 8,'**MORE THAN 20 CALLS MADE ON FREEHDR**' 00008600 &FREEOFF SETB 1 00008650 MEXIT 00008700 .ERROR2 MNOTE *,'**FREEHDR HAS BEEN DISABLED**' 00008750 MEND 00008800 MACRO 00008850 FREEAREA 00008900 GBLA &FREENUM(20),&FREELEN(20),&FREECTR,&FRCTR 00008950 AIF (&FREECTR GT &FRCTR).MORE 00009000 MNOTE *,'**CALL TO FREEAREA RESULTED IN NO PROCESSING**' 00009050 MEXIT 00009100 .MORE ANOP 00009150 &FRCTR SETA &FRCTR+1 00009200 FR&FRCTR DC 0F 00009250 .NEXT AIF (&FREENUM(&FRCTR) LE 1).LAST 00009300 DC A(*+4*(&FREELEN(&FRCTR)+1)),&FREELEN(&FRCTR)F'0' 00009350 &FREENUM(&FRCTR) SETA &FREENUM(&FRCTR)-1 00009400 AGO .NEXT 00009450 .LAST DC A(0),&FREELEN(&FRCTR)F'0' 00009500 AIF (&FRCTR LT &FREECTR).MORE 00009550 MEND 00009600 MACRO 00009650 &LABEL LISTHDR 00009700 &LABEL DC 4F'0' 00009750 MEND 00009800 MACRO 00009850 SETGBL &CATNO=1,&IONO=1,&NOTRACE=NO 00009900 GBLA &CAT,&ION 00009950 GBLB &NOTRAC 00010000 &CAT SETA &CATNO 00010050 &ION SETA &IONO 00010100 &NOTRAC SETB 0 00010150 AIF ('&NOTRACE' EQ 'NO').DONE 00010200 &NOTRAC SETB 1 00010250 .DONE MEND 00010300 MACRO 00010350 LISTS 00010400 GBLA &CAT,&ION 00010450 .* GENERATE LIST HEADERS 00010500 CRLISTS CATHDR,&CAT 00010550 CRLISTS IOQHDR,&ION 00010600 MEND 00010650 MACRO 00010700 CRLISTS &PREFIX,&NUM 00010750 LCLA &COUNT 00010800 .MORE ANOP 00010850 &COUNT SETA &COUNT+1 00010900 &PREFIX&COUNT LISTHDR 00010950 AIF (&COUNT LT &NUM).MORE 00011000 MEND 00011050 SETGBL 00011100 DATA CSECT 00011150 EVQFR FREEHDR 3,3 00011200 DQFR FREEHDR 18,3 00011250 LISTS 00011300 RJQHDR LISTHDR 00011350 EVQHDR LISTHDR 00011400 FREEAREA 00011450 DQEL DSECT 00011500 DQLINK DS F 00011550 DQKEY DS CL8 00011600 EVQEL DSECT 00011650 EVQLINK DS F 00011700 EVQKEY DS CL8 00011750 TITLE 'TEST' 00011800 PRINT GEN 00011850 TEST CSECT 00011900 QSAVE , OR WHAT HAVE (BR=12) 00011950 L 11,DATAADR 00012000 USING DATA,11 00012050 USING EVQEL,1 00012100 USING DQEL,3 00012150 GETFREE EVQFR,1,ERROR 00012200 MVC EVQKEY,EVENT1 00012250 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00012300 GETFREE EVQFR,1,ERROR 00012350 MVC EVQKEY,EVENT2 00012400 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00012450 GETFREE EVQFR,1,ERROR 00012500 MVC EVQKEY,EVENT1 00012550 PUTNODE EVQHDR,1,KEYLEN=6,LENGTH=8 00012600 LR 2,1 00012650 GETFREE EVQFR,1,UNDER1 00012700 B ERROR 00012750 UNDER1 XDUMP EVQHDR,16 00012800 DELETE EVQHDR,2,ERROR,LENGTH=8 00012850 PUTFREE EVQFR,2 00012900 DELETE EVQHDR,2,OK 00012950 B ERROR 00013000 OK GETFREE EVQHDR,1,ERROR 00013050 MVC EVQKEY,EVENT3 00013100 SETGBL NOTRACE=YES 00013150 PUTNODE EVQHDR,1,KEYLEN=6 00013200 SETGBL NOTRACE=NO 00013250 CONTINUE POP EVQHDR,1,DONE,LENGTH=8 00013300 PUTFREE EVQFR,1 00013350 B CONTINUE 00013400 DONE LA 5,JQE1 00013450 GETMORE GETFREE DQFR,3,UNDER2 00013500 MVC DQKEY,0(5) 00013550 PUTNODE CATHDR1,3,KEYLEN=2,LENGTH=8,MSG='CAT' 00013600 SETGBL NOTRACE=YES 00013650 GETFREE DQFR,3,ERROR 00013700 MVC DQKEY,0(5) 00013750 PUTNODE RJQHDR,3,KEY=6,KEYLEN=2 00013800 GETFREE DQFR,3,ERROR 00013850 MVC DQKEY,0(5) 00013900 PUTNODE IOQHDR1,3,KEY=8,KEYLEN=2 00013950 LA 5,8(5) 00014000 B GETMORE 00014050 SETGBL NOTRACE=NO 00014100 UNDER2 POP CATHDR1,1,ALLDONE,LENGTH=8 00014150 POP RJQHDR,1,ERROR,LENGTH=8 00014200 POP IOQHDR1,1,ERROR,LENGTH=8 00014250 B UNDER2 00014300 ERROR XPRNT =CL6'0ERROR',6 00014350 ALLDONE XDUMP CATHDR1,64 00014400 QRETURN SA=* OR WHAT HAVE YOU 00014450 EVENT1 DC F'5',H'1,2' 00014500 EVENT2 DC F'6',H'0,0' 00014550 EVENT3 DC F'5',H'0,0' 00014600 JQE1 DC H'1,2,3,1' 00014650 DC H'2,3,1,2' 00014700 DC H'3,1,2,3' 00014750 DC H'3,2,1,4' 00014800 DC H'2,1,3,5' 00014850 DC H'1,3,2,6' 00014900 DATAADR DC V(DATA) 00014950 END TEST 00015000 $JOASSIST MACRO=F 00015050 MACRO 00015100 &NAME $TRT &FIELD,&TAB,&LEN=15 00015150 SPACE 3 00015200 .* 00015250 .* $TRT WILL 00015300 .* 1) DO A TRT STARTING AT &FIELD WHICH MAY BE ANY OPERAND 00015350 .* VALID AS SECOND OPERAND IN AN LA INSTRUCTION. 00015400 .* 2) THE NUMBER OF BYTES SCANNED WILL BE PLACED IN GPR 0. 00015450 .* 3) &TAB IS THE TABLE FOR THE TRT. 00015500 .* 4) THE NUMBER OF BYTES TO BE SCANNED IS IN THE REGISTER 00015550 .* SPECIFIED IN THE &LEN KEYWORD PARAMETER. AFTER THE $TRT 00015600 .* THIS REGISTER WILL HAVE THE NUMBER OF BYTES NOT SCANNED. 00015650 .* 5) THE CC , GPR 1, &GPR 2 HAVE THEIR USUAL VALUES AFTER A TRT. 00015700 .* 00015750 &NAME STM 2,3,$TRT&SYSNDX-8 . SAVE REGS 00015800 LA 3,&FIELD . 3 -> FIELD 00015850 LR 2,&LEN . GET LENGTH 00015900 BCTR 2,0 . SET FOR EXECUTE 00015950 B $TRT&SYSNDX . BR AROUND INST & SAVE AREA 00016000 CNOP 2,4 . GET PROPER ALIGNMENT 00016050 TRT 0(0,3),&TAB . ACT TRT 00016100 DS 2F . SAVEAREA 00016150 $TRT&SYSNDX EX 2,*-14 . DO TRT 00016200 BNZ *+18 . NON ZERO TAB BYTES? 00016250 LR 0,&LEN . NO 00016300 LA &LEN,0 . SET 0 AND &LEN TO PROPER VALS 00016350 LM 2,3,$TRT&SYSNDX-8 . RESTORE REGS 00016400 B *+22 . DONE 00016450 STC 2,$TRT&SYSNDX-5 . SAVE FUNCTION BYTE 00016500 BALR 2,0 . SAVE CC 00016550 SR 3,1 . COMPUTE -(LEN SCANNED) 00016600 LCR 0,3 . LEN SCANNED 00016650 SR &LEN,0 . LEN REMAINING 00016700 SPM 2 . RESET CC 00016750 LM 2,3,$TRT&SYSNDX-8 . SAVE REGS 00016800 SPACE 3 00016850 MEND 00016900 SPACE 5 00016950 MACRO 00017000 &NAME TRTAB &FILL,&TABLE= 00017050 LCLA &N,&I,&K,&N1 00017100 LCLC &A 00017150 SPACE 3 00017200 &NAME DC 256FL1'&FILL' 00017250 &I SETA 1 00017300 &N SETA N'&TABLE 00017350 AIF (&N/2*2 EQ &N).BACK 00017400 MNOTE 8,'ODD NUMBER OF ARGS FOR TABLE INVALID' 00017450 .BACK AIF (&I GE &N).END 00017500 &K SETA K'&TABLE(&I) 00017550 AIF (&K EQ 1).NOTSPEC 00017600 AIF ('&TABLE(&I)'(1,1) NE '@').STRING 00017650 &K SETA &K-1 00017700 &A SETC '&TABLE(&I)'(2,&K) 00017750 AIF (&K GT 2).NOT2DIG 00017800 AIF ('&A' EQ 'BL').BL 00017850 AIF ('&A' EQ 'LP').LP 00017900 AIF ('&A' EQ 'RP').RP 00017950 AIF ('&A' EQ 'QT').QT 00018000 AGO .INVALID 00018050 .BL ORG &NAME+C' ' 00018100 DC FL1'&TABLE(&I+1)' 00018150 AGO .BOT 00018200 .LP ORG &NAME+C'(' 00018250 DC FL1'&TABLE(&I+1)' 00018300 AGO .BOT 00018350 .RP ORG &NAME+C')' 00018400 DC FL1'&TABLE(&I+1)' 00018450 .QT ORG &NAME+C'''' 00018500 DC FL1'&TABLE(&I+1)' 00018550 AGO .BOT 00018600 .NOT2DIG AIF (&K GT 3).NOT3DIG 00018650 AIF ('&A' EQ 'NUM').NUM 00018700 AIF ('&A' EQ 'COM').COM 00018750 AIF ('&A' EQ 'AMP').AMP 00018800 AGO .INVALID 00018850 .NUM ORG &NAME+C'0' 00018900 DC 10FL1'&TABLE(&I+1)' 00018950 AGO .BOT 00019000 .COM ORG &NAME+C',' 00019050 DC FL1'&TABLE(&I+1)' 00019100 AGO .BOT 00019150 .AMP ORG &NAME+C'&&' 00019200 DC FL1'&TABLE(&I+1)' 00019250 AGO .BOT 00019300 .NOT3DIG AIF ('&A' NE 'ALPHA').INVALID 00019350 .ALPHA ORG &NAME+C'A' 00019400 DC 9FL1'&TABLE(&I+1)' 00019450 ORG &NAME+C'J' 00019500 DC 9FL1'&TABLE(&I+1)' 00019550 ORG &NAME+C'S' 00019600 DC 8FL1'&TABLE(&I+1)' 00019650 AGO .BOT 00019700 .STRING ANOP 00019750 &A SETC '&TABLE(&I)'(&K,1) 00019800 ORG &NAME+C'&A' 00019850 DC FL1'&TABLE(&I+1)' 00019900 &K SETA &K-1 00019950 AIF (&K GE 1).STRING 00020000 AGO .BOT 00020050 .NOTSPEC ORG &NAME+C'&TABLE(&I)' 00020100 DC FL1'&TABLE(&I+1)' 00020150 .BOT ANOP 00020200 &I SETA &I+2 00020250 AGO .BACK 00020300 .INVALID MNOTE 8,'INVALID KEYWORD OR MULTIPLE CHAR ARG IN LIST' 00020350 AGO .BOT 00020400 .END ORG 00020450 SPACE 3 00020500 MEND 00020550 SPACE 5 00020600 MACRO 00020650 CALL &NAME 00020700 CNOP 0,4 00020750 B *+8 00020800 I&SYSNDX DC V(&NAME) 00020850 L 15,I&SYSNDX 00020900 BALR 14,15 00020950 MEND 00021000 SPACE 5 00021050 MACRO 00021100 &NAME XBACK 00021150 LCLA &DISP,&N1,&N2,&N3,&N,&TEMP 00021200 SPACE 3 00021250 &NAME L 13,4(13) 00021300 &N SETA N'&SYSLIST 00021350 AIF (&N GT 0).BACK 00021400 L 14,12(13) 00021450 LM 2,12,28(13) 00021500 .DONE BR 14 00021550 LTORG 00021600 SPACE 3 00021650 MEXIT 00021700 .BACK ANOP 00021750 &N1 SETA &N1+1 00021800 AIF (&N1 GT &N).DONE 00021850 &N2 SETA N'&SYSLIST(&N1) 00021900 AIF (&N2 LE 0 OR &N2 GT 2).ERR1 00021950 &TEMP SETA &SYSLIST(&N1,1) 00022000 AIF (&TEMP LT 0 OR &TEMP GT 15).ERR2 00022050 AIF (&TEMP LT 14).LOW 00022100 &DISP SETA 12+(&TEMP-14)*4 00022150 AGO .X2 00022200 .LOW ANOP 00022250 &DISP SETA 20+&TEMP*4 00022300 .X2 AIF (&N2 EQ 2).A2 00022350 L &TEMP,&DISP.(13) 00022400 AGO .X3 00022450 .A2 LM &TEMP,&SYSLIST(&N1,2),&DISP.(13) 00022500 .X3 ANOP 00022550 &N2 SETA 0 00022600 AGO .BACK 00022650 .ERR1 MNOTE 8,'NUMBER OF ARGS IN SUBLIST MUST BE 1 OR 2' 00022700 MEXIT 00022750 .ERR2 MNOTE 8,'REGISTER SPECIFICATION NOT BETWEEN 0 AND 16' 00022800 MEND 00022850 SPACE 5 00022900 MACRO 00022950 &NAME XGO &ACONSA=,&ENTRY= 00023000 LCLA &###DISP 00023050 LCLB &ENT 00023100 SPACE 3 00023150 AIF ('&ENTRY' EQ 'ENTRY').ENTER 00023200 AIF ('&ACONSA' EQ '').X1 00023250 &ENT SETB 1 00023300 &###DISP SETA 4 00023350 .X1 TITLE '******** &NAME CSECT ***************************' 00023400 &NAME CSECT 00023450 B 14(0,15) 00023500 DC X'09',CL9'&NAME ' 00023550 STM 14,12,12(13) 00023600 LR 14,13 00023650 BAL 13,96+&###DISP.(15) 00023700 USING *,13 00023750 DC 18F'-1' 00023800 AIF (NOT &ENT).BACK 00023850 &ACONSA DC A(*-72) 00023900 .BACK ST 14,4(13) 00023950 ST 13,8(14) 00024000 L 14,12(14) 00024050 SPACE 3 00024100 MEXIT 00024150 .ENTER CNOP 0,4 00024200 TITLE '******** &NAME ENTRY ********************************' 00024250 &NAME DS 0H 00024300 ENTRY &NAME 00024350 B 0(0,15) 00024400 DC X'09',CL9'&NAME ' 00024450 STM 14,12,12(13) 00024500 LR 14,13 00024550 USING &SYSECT+24,13 00024600 L 13,28(15) 00024650 B *+8 00024700 &ACONSA DC A(&SYSECT+24) 00024750 AGO .BACK 00024800 MEND 00024850 SPACE 5 00024900 PRINT ON 00024950 PRINT NOGEN 00025000 *********************************************************************** 00000050 *********************************************************************** 00000100 * THIS PROGRAM CONTAINS EVERYTHING REQUIRED PLUS THE 00000150 * ADDED FEATURES OF A LINKED CLASS FIELD AND NOTIFICATION OF A 00000200 * DELETION OR A MODIFICATION. LIST HEADS ARE USED FOR THE CODE2, 00000250 * CLASS, MAGIC NUMBER, AND THE SEX FIELDS. THE ONLY LIMITATION 00000300 * IS THAT NON-BLANK FIELDS ARE ASSUMED FOR INITIAL READ IN. THIS 00000350 * PROGRAM HAS THE CAPABILITY TO LINK A FILE OF 200 CARDS, INDEX 00000400 * 25 DIFFERENT CODE 2 AND CLASS FIELDS. ALL ERRORS ARE DETECTED 00000450 * AND FLAGGED WITH ONLY THE SEVEREST CAUSING TERMINATION OF THE 00000500 * PROGRAM 00000550 *********************************************************************** 00000600 *********************************************************************** 00000650 MAIN XGO 00000700 *********************************************************************** 00000750 ******************* EQUATES REGISTERS TO SYMBOLIC NAMES *************** 00000800 *********************************************************************** 00000850 R0 EQU 0 00000900 R1 EQU 1 00000950 R2 EQU 2 00001000 R3 EQU 3 00001050 R4 EQU 4 00001100 R5 EQU 5 00001150 R6 EQU 6 00001200 R7 EQU 7 00001250 R8 EQU 8 00001300 R9 EQU 9 00001350 R10 EQU 10 00001400 R11 EQU 11 00001450 CONREG EQU 12 00001500 CLASSREG EQU R4 00001550 POINTREG EQU R5 00001600 AVAILREG EQU R6 00001650 ADVCDE2 EQU R7 00001700 NODELINK EQU R8 00001750 PREG EQU R9 00001800 MAGNOREG EQU R10 00001850 CLASINFO EQU 2 00001900 CLASSADD EQU 4 00001950 CODEINF2 EQU 0 00002000 CODELIK2 EQU 4 00002050 *********************************************************************** 00002100 ******************* SET UP A PSUEDO DSECT FOR SYMBOLIC *************** 00002150 ******************* ADDRESSING IN ASSIST ************** 00002200 *********************************************************************** 00002250 NAMELINK EQU 0 00002300 CODE2LL EQU 4 00002350 CODE2LR EQU 8 00002400 FSEXLINK EQU 12 00002450 MSEXLINK EQU 16 00002500 MAGNOL EQU 20 00002550 MAGNOR EQU 24 00002600 CLASSLIK EQU 28 00002650 NAME EQU 32 00002700 SEX EQU 51 00002750 MAGNUM EQU 52 00002800 CLASS EQU 61 00002850 CODE1 EQU 63 00002900 CODE2 EQU 68 00002950 *********************************************************************** 00003000 ******************* INITIALLY CLEARS THE REGISTERS ******************* 00003050 *********************************************************************** 00003100 SR R0,R0 00003150 SR R1,R1 00003200 SR R2,R2 00003250 SR R3,R3 00003300 SR R4,R4 00003350 SR R5,R5 00003400 SR R6,R6 00003450 SR R7,R7 00003500 SR R8,R8 00003550 SR R9,R9 00003600 SR R10,R10 00003650 SR R11,R11 00003700 *********************************************************************** 00003750 USING CONSTANT,CONREG,R11 00003800 L CONREG,=V(CONSTANT) 00003850 LA R11,4095(CONREG) 00003900 LA R11,1(R11) 00003950 LA POINTREG,LAMDA 00004000 LA R3,LAVS 00004050 LA PREG,P 00004100 LR AVAILREG,R3 00004150 ST POINTREG,PTR 00004200 ST R3,AVAIL 00004250 MVC P(4),LAMDA 00004300 MVI STATFLAG,C'0' INITIATIIZE STATE OF OPERATIONS FLAG 00004350 *********************************************************************** 00004400 ******************* LINKS AVAILABLE SPACE TOGETHER ******************** 00004450 *********************************************************************** 00004500 LINKLAVS CLC 0(3,R3),LAMDA 00004550 BE INIREAD 00004600 LA R3,72(R3) 00004650 ST R3,LAVS(R4) 00004700 LA R4,72(R4) 00004750 B LINKLAVS 00004800 INIREAD XREAD CARD,80 00004850 MVI FLAG,C'0' RESET THE FLAG 00004900 CLC CARD+1(5),STARS LOOK FOR END OF DATA SET 00004950 BE EOFPRINT PRINT OUT THE LISTS 00005000 *********************************************************************** 00005050 ******************* READS IN AND DETECTS OVERFLOW ******************** 00005100 ******************* AND EMPTY LIST TO SET LIST HEADS ***************** 00005150 *********************************************************************** 00005200 NAMEIN CLC LAMDA(4),AVAIL SEE IF STORAGE IS EXHAUSTED 00005250 BE OVERFLOW IT IS, SO GO TO OVERFLOW 00005300 CLC P(4),LAMDA SEE IF THE LIST IS EMPTY 00005350 BE LISTMT IT IS, SO GO TO LISTMT 00005400 MVC AVAIL(4),NAMELINK(AVAILREG) ADVANCE AVAIL 00005450 CALL MOVER INSERT INTO NODE FOR ADDING TO LIST 00005500 B SEXFIND 00005550 *********************************************************************** 00005600 *******************PRINTS LISTS FOR PARTS A&B************************* 00005650 *********************************************************************** 00005700 EOFPRINT EQU * 00005750 XPRNT NAMEHEAD,124 00005800 XPRNT SPECNAME,133 PRINT THE SECOND HEADER 00005850 EOFLOOP EQU * 00005900 MVC FILES+11(19),NAME(PREG) 00005950 MVC FILES+44(1),SEX(PREG) 00006000 MVC FILES+61(9),MAGNUM(PREG) 00006050 MVC FILES+86(2),CLASS(PREG) 00006100 MVC FILES+102(5),CODE1(PREG) 00006150 MVC FILES+121(3),CODE2(PREG) 00006200 L PREG,NAMELINK(PREG) 00006250 C PREG,P 00006300 BE FINPRINT 00006350 XPRNT FILES,133 NOW PRINT THE SEPARATE FILES 00006400 B EOFLOOP 00006450 FINPRINT EQU * 00006500 XPRNT FILES,133 PRINT ALL LISTS FORMED 00006550 XPRNT CD2HEAD,132 PRINT THE CODE2 HEADER 00006600 MVC NAMEDUMP+1(39),BLANKS CLEAR THE OUTPUT AREA 00006650 LA NODELINK,HDCODE2+4 00006700 ST NODELINK,STOREIN 00006750 L NODELINK,HDCODE2+4 00006800 ST NODELINK,NODLKST 00006850 PRINTCD2 MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE THE NAME IN 00006900 MVC NAMEDUMP+36(3),CODE2(NODELINK) MOVE THE CODE2 IN 00006950 XPRNT NAMEDUMP,40 00007000 CLC NODLKST(4),CODE2LR(NODELINK) 00007050 BE CREMENT 00007100 L NODELINK,CODE2LR(NODELINK) 00007150 B PRINTCD2 00007200 CREMENT L NODELINK,STOREIN 00007250 LA NODELINK,8(NODELINK) 00007300 ST NODELINK,STOREIN 00007350 L R2,STOREIN 00007400 MVC NODLKST(4),0(R2) 00007450 CLC 0(4,NODELINK),ZEROS 00007500 BE NOWEND 00007550 CLC 0(4,NODELINK),PLUSES 00007600 BE NOWEND 00007650 CLC 0(4,NODELINK),MINUS 00007700 BE CREMENT 00007750 L NODELINK,0(NODELINK) 00007800 XPRNT =C'-',1 00007850 BNE PRINTCD2 00007900 NOWEND EQU * 00007950 XPRNT MAGHEAD,128 PRINT THE MAGIC # HEADING 00008000 L NODELINK,HDMAGNO 00008050 MVC NAMEDUMP+1(39),BLANKS CLEAR THE OUTPUT AREA 00008100 MAGPRINT MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE NAME IN FOR OUTPT 00008150 MVC NAMEDUMP+30(9),MAGNUM(NODELINK) MOVE THE MAGIC # IN 00008200 XPRNT NAMEDUMP,40 00008250 CLC MAGNOR(4,NODELINK),HDMAGNO 00008300 BE MORE 00008350 L NODELINK,MAGNOR(NODELINK) 00008400 B MAGPRINT 00008450 MORE EQU * 00008500 CLC HDFSEX(4),LAMDA 00008550 BE NOFEM 00008600 XPRNT FEMHEAD,132 PRINT THE FEMALE HEADING 00008650 MVC NAMEDUMP+1(39),BLANKS CLEAR THE OUTPUT AREA 00008700 L NODELINK,HDFSEX 00008750 FEMLOOP MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE THE NAME IN 00008800 MVC NAMEDUMP+30(1),SEX(NODELINK) MOVE THE SEX IN 00008850 XPRNT NAMEDUMP,40 00008900 CLC FSEXLINK(4,NODELINK),LAMDA 00008950 BE NOWMALE GO TO PRINT THE MALE LIST 00009000 L NODELINK,FSEXLINK(NODELINK) 00009050 B FEMLOOP 00009100 NOFEM XPRNT NFEM,132 00009150 BE NOWMALE GO TO PRINT THE MALE LIST 00009200 NOWMALE EQU * 00009250 CLC HDMSEX,LAMDA SEE IF THE LIST IS EMPTY 00009300 BE NOMALE IT IS EMPTY 00009350 XPRNT MALEHEAD,128 PRINT THE MALE HEADER 00009400 MVC NAMEDUMP+1(39),BLANKS CLEAR OUTPUT AREA 00009450 L NODELINK,HDMSEX SET THE INDEX REGISTER 00009500 MALLOOP MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE THE NAME IN 00009550 MVC NAMEDUMP+30(1),SEX(NODELINK) MOVE THE SEX IN 00009600 XPRNT NAMEDUMP,40 00009650 CLC MSEXLINK(4,NODELINK),LAMDA SEE IF END OF LIST 00009700 BE NWCLASS NOW PRINT THE CLASS 00009750 L NODELINK,MSEXLINK(NODELINK) INCREMENT NODELINK REG 00009800 B MALLOOP CONTINUE 00009850 NOMALE XPRNT NMALE,131 00009900 BE NWCLASS NOW PRINT THE CLASS 00009950 NWCLASS EQU * 00010000 XPRNT CLASHEAD,127 00010050 MVC NAMEDUMP+1(39),BLANKS CLEAR THE OUTPUT AREA 00010100 LA CLASSREG,HDCLASS RESET THE CLASS REGISTER FOR OUTPUT 00010150 BIGCLOOP CLC CLASINFO(6,CLASSREG),ZEROS SEE IF DONE 00010200 BE UPDATEER 00010250 CLC 0(8,CLASSREG),PLUSES SEE IF DONE 00010300 BE UPDATEER 00010350 L NODELINK,CLASSADD(CLASSREG) INITIALIZE REGISTER 00010400 CLOOPRNT MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE THE NAME IN 00010450 MVC NAMEDUMP+31(2),CLASS(NODELINK) MOVE THE CLASS IN 00010500 XPRNT NAMEDUMP,40 00010550 CLC CLASSLIK(4,NODELINK),LAMDA 00010600 BE UPCLASS 00010650 L NODELINK,CLASSLIK(NODELINK) 00010700 B CLOOPRNT 00010750 UPCLASS LA CLASSREG,8(CLASSREG) 00010800 XPRNT =C'-',1 SPACE DOWN 3 00010850 B BIGCLOOP 00010900 *********************************************************************** 00010950 *******************FINAL PRINTER ************************************** 00011000 *********************************************************************** 00011050 FINALPTR EQU * 00011100 L NODELINK,HDFSEX INITIALIZE THE REGISTER 00011150 MVC NAMEDUMP+1(39),BLANKS 00011200 XPRNT FFEMPRIT,131 PRINT THE HEADER 00011250 FFEMLOOP CLC MAGNUM(9,NODELINK),FIVES SEE IF MAGIC # > 5'S 00011300 BH FEMFPRNT >, SET FLAG AND PRINT OUT 00011350 FINCFIN CLC FSEXLINK(4,NODELINK),LAMDA ALL GIRLS GONE ???? 00011400 BE CKFLAG WERE THERE ANY 00011450 L NODELINK,FSEXLINK(NODELINK) INCREMENT REGISTER 00011500 B FFEMLOOP TRY AGAIN 00011550 CKFLAG CLI FEMFLAG,C'0' WAS THERE ANY 00011600 BE NOCHICS NO!! 00011650 BNE NEXTFINA 00011700 NOCHICS XPRNT NOCHIC,131 00011750 B NEXTFINA NEXT FINAL OUTPUT 00011800 FEMFPRNT MVI FEMFLAG,C'1' SET A FLAG 00011850 MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE THE NAME IN 00011900 MVC NAMEDUMP+22(1),SEX(NODELINK) MOVE THE SEX IN 00011950 MVC NAMEDUMP+30(9),MAGNUM(NODELINK) MOVE THE MAGIC # IN 00012000 XPRNT NAMEDUMP,40 00012050 B FINCFIN SEE IF ANY MORE 00012100 NEXTFINA EQU * 00012150 MVI FEMFLAG,C'0' RESET THE FLAG 00012200 XPRNT FCLASOUT,132 PRINT THE HEADER 00012250 MVC NAMEDUMP+1(39),BLANKS CLEAR OUTPUT AREA 00012300 LA CLASSREG,HDCLASS INITIALIZE POINTER 00012350 ONEMT CLC CLASINFO(2,CLASSREG),SEVEN > 07 ??? 00012400 BH NACLASSP IF PRINT THE FILE 00012450 CLC CLASINFO(6,CLASSREG),ZEROS DONE ??? 00012500 BE CLFCHEC SEE IF THERE WERE ANY 00012550 CLC 0(8,CLASSREG),PLUSES DONE ????? 00012600 BE CLFCHEC WERE THERE ANY ??? 00012650 LA CLASSREG,8(CLASSREG) INCREMENT CLASS POINTER 00012700 B ONEMT TRY AGAIN 00012750 NACLASSP MVI FEMFLAG,C'1' SET A FLAG 00012800 L NODELINK,CLASSADD(CLASSREG) SET TO FIRST NODE 00012850 INCREMLP MVC NAMEDUMP+1(19),NAME(NODELINK) MOVE NAME IN 00012900 MVC NAMEDUMP+25(2),CLASS(NODELINK) MOVE CLASS IN 00012950 XPRNT NAMEDUMP,40 00013000 CLC CLASSLIK(4,NODELINK),LAMDA LAST ONE ??? 00013050 BE LOOPCREM GO BACK FOR MORE 00013100 L NODELINK,CLASSLIK(NODELINK) SET TO THE NEXT NODE 00013150 B INCREMLP GET NEXT ONE 00013200 LOOPCREM LA CLASSREG,8(CLASSREG) INCREMENT LIST HEAD 00013250 B ONEMT LOOK AGAIN 00013300 CLFCHEC CLI FEMFLAG,C'1' WHERE THERE ANY ??? 00013350 BL PRNTERCL NO, SO PRINT MESSAGE 00013400 B STOP FINISHED!!!!!!!!!!!!!!!!!!! 00013450 PRNTERCL XPRNT NOCHIC,131 00013500 B STOP FINISHED !!!!!!!!!!!!!!! 00013550 *********************************************************************** 00013600 ******************* BEGINNING OF PART B, INSERT, MODIFY ************** 00013650 ******************* AND DELETION FROM THE LIST ************** 00013700 *********************************************************************** 00013750 UPDATEER EQU * 00013800 UPREAD XREAD CARD,80 00013850 BNZ FINALPTR GO PRINT THE FINAL OUTPUT 00013900 SR R2,R2 CLEAR REGISTER 2 FOR INDEX BRANCH 00013950 CLC CARD+1(5),STARS SEE IF END OF UPDATING OF FILE 00014000 BE FPRINTND 00014050 MVC FAKENODE(72),BLANKS CLEAR THE NODE FOR UPDATING 00014100 *********************************************************************** 00014150 ******************* INDEX BRANCH TO TYPE OF OPERATION ************** 00014200 *********************************************************************** 00014250 TR CARD+41(1),OPTAB CHANGE LETTER INTO A NUMERIC 00014300 IC R2,CARD+41 INSERT FOR INDEX BRANCH 00014350 B *+0(R2) INDEX BRANCH TO OPERATION 00014400 B ADDER GO TO ADD ROUTINE 00014450 B DELETER GO TO DELETE ROUTINE 00014500 B MODFYER GO TO MODIFY ROUTINE 00014550 B DOWHAT UNDEFINED OPERATION IS SPECIFIED 00014600 *********************************************************************** 00014650 ******************* ADDITION PART OF PART B ****************** 00014700 *********************************************************************** 00014750 ADDER EQU * 00014800 MVI STATFLAG,C'1' SET TO ADD STATE 00014850 B NAMEIN 00014900 *********************************************************************** 00014950 ******************* DELETION PART WHICH IN CASE OF AN **************** 00015000 ******************* EMPTY LIST BYPASSES ANY DELETION **************** 00015050 ******************* UNTIL THERE IS SOMETHING TO DELETE ************** 00015100 ******************** AND GIVES NOTIFICATION OF COMPLETE ************** 00015150 ******************** EMPTYING OF THE LIST ************** 00015200 *********************************************************************** 00015250 DELETER EQU * 00015300 CLC P,LAMDA SEE IF EMPTY LIST 00015350 BE UPREAD LIST EMPTY, NO DELETIONS ALLOWED 00015400 L PREG,P RESET NEEDED REGISTERS 00015450 L POINTREG,PTR 00015500 CALL SAMENAME FIND NODE = AND ONE BEFORE 00015550 CLI DFFLAG,C'4' CHECK TO SEE IF IN LIST 00015600 BE UPREAD NOT IN LIST SO GET NEXT CARD 00015650 L R1,NMADSTOR LOAD FOR PRINT OUT 00015700 MVC NAMEDUMP+1(39),NAME(R1) 00015750 CLI DFFLAG,C'2' IS IT THE END NODE??? 00015800 BE PTCHANGE YES 00015850 BH SOLONG LAST NODE, SO TELL HIM 00015900 CLI DFFLAG,C'1' SEE IF FIRST NODE 00015950 BE PCHANGE IF YES, GO TO PCHANGE 00016000 CALLSTUF EQU * 00016050 CALL DNL NAME LINK DELETER 00016100 CALL DSL SEX LINK DELETER 00016150 CALL DM#L MAGIC NUMBER DELETER 00016200 CALL DCLASS CLASS LINK DELETER 00016250 CALL DC#2L CODE2 LINK DELETER 00016300 B INCLAVS NOW INCREMENT AVAILABLE SPACE 00016350 *********************************************************************** 00016400 ******************* CHANGES THE POSITION OF CRITICAL POINTERS ******** 00016450 *********************************************************************** 00016500 PCHANGE L PREG,NAMELINK(PREG) SET PREG TO NEXT NODE 00016550 ST PREG,P SAVE THIS ADDRESS 00016600 B CALLSTUF NOW DELETE 00016650 PTCHANGE L R2,TEMPNAME SET R2 TO THE NODE 00016700 ST PREG,NAMELINK(R2) SET THE NEW FIRST 00016750 LR POINTREG,R2 SET NEW END POINTER 00016800 ST POINTREG,PTR NOW SAVE IN PTR 00016850 B CALLSTUF 00016900 SOLONG MVC P,LAMDA SET P TO EMPTY LIST 00016950 XPRNT STAR,133 00017000 XPRNT GOODBYE,131 00017050 XPRNT STAR,133 00017100 B INCLAVS DON'T DELETE, JUST INCREMENT 00017150 *********************************************************************** 00017200 ******************* RETURNS THE NODES TO LAVS ************************ 00017250 *********************************************************************** 00017300 INCLAVS L NODELINK,NMADSTOR SET NODELINK FOR RETURN TO LAVS 00017350 MVC NAMELINK(4,NODELINK),AVAIL SET NAMELINK TO AVAIL 00017400 ST NODELINK,AVAIL UPDATE AVAIL 00017450 XPRNT =CL26' THE FILE BEING DELETED IS',26 00017500 XPRNT NAMEDUMP,40 00017550 B UPREAD WHATS NEXT UPDATE 00017600 *********************************************************************** 00017650 ******************* MODIFY SECTION WITH FEATURES OF NOTI- ************ 00017700 ******************* FICATION OF A BLANK MODIFY FIELD, AN ************ 00017750 ******************* UNDEFINED MODIFY CODE, AND ATTEMPTED ************ 00017800 ******************* MODIFICATION OF AN NONEXISTANT FILE ************ 00017850 *********************************************************************** 00017900 MODFYER EQU * 00017950 ST AVAILREG,AVADST SAVE NEXT NODE LOCATION 00018000 SR R2,R2 RECLEAR REGISTER 2 FOR INDEX BRANCH 00018050 CLC CARD+49(19),BLANKS SEE IF BLANK MOD FIELD 00018100 BE FDBLANK IF SO PRINT MESSAGE AND LEAVE 00018150 TR CARD+43(1),OPOP TRANSLATE BYTE FOR BRANCH 00018200 IC R2,CARD+43 INSERT FOR BRANCH 00018250 B *+0(R2) INDEX BRANCH 00018300 B FDNAME NAME MODIFICATION 00018350 B FDSEX SEX MODIFICATION 00018400 B FDMAGNO MAGIC # MODIFICATION 00018450 B FDCLASS CLASS MODIFICATION 00018500 B FDCODE1 CODE1 MODIFICATION 00018550 B FDCODE2 CODE2 MODIFICATION 00018600 B FDERROR INVALID MODIFICATION 00018650 FDERROR MVC NAMEDUMP+1(19),CARD+1 GET READY FOR MESSAGE 00018700 XPRNT ERFIELD,131 00018750 XPRNT NAMEDUMP,20 00018800 XPRNT =C'-',1 00018850 B UPREAD 00018900 FDBLANK MVC NAMEDUMP+1(19),CARD+1 00018950 XPRNT ERBLANK,129 00019000 XPRNT NAMEDUMP,20 00019050 XPRNT =C'-',1 00019100 B UPREAD 00019150 *********************************************************************** 00019200 ******************** MODIFIES THE NAME FIELD ************** 00019250 *********************************************************************** 00019300 FDNAME EQU * 00019350 CALL SAMENAME FIND THE NODE WITH SAME NAME FIELD 00019400 CALL DNL DELETE THE NAME 00019450 L AVAILREG,NMADSTOR SET AVAILREG TO NODE FOR SUBROUTINES 00019500 MVC NAME(19,AVAILREG),CARD+49 INSERT NEW NAME 00019550 CALL FINAPLAC NOW LINK THE NEW NAME 00019600 B MODBACK GET READY TO LEAVE 00019650 *********************************************************************** 00019700 ******************** MODIFIES THE SEX FIELD ************** 00019750 *********************************************************************** 00019800 FDSEX EQU * 00019850 CALL SAMENAME FIND THE NODE WITH SAME NAME FIELD 00019900 CALL DSL DELETE THE SEX 00019950 L AVAILREG,NMADSTOR SET AVAILREG TO NODE FOR SUBROUTINES 00020000 MVC SEX(1,AVAILREG),CARD+49 INSERT THE NEW SEX 00020050 CALL SEXLINK LINK THE NEW SEX TO THE LIST 00020100 B MODBACK GET READY TO LEAVE 00020150 *********************************************************************** 00020200 ******************** MODIFIES THE MAGIC NUMBER ************** 00020250 *********************************************************************** 00020300 FDMAGNO EQU * 00020350 CALL SAMENAME FIND THE NODE WITH SAME NAME FIELD 00020400 CALL DM#L DELETE THE MAGIC NUMBER 00020450 L AVAILREG,NMADSTOR SET AVAILREG TO NODE FOR SUBROUTINES 00020500 MVC MAGNUM(9,AVAILREG),CARD+49 INSERT THE NEW MAGIC # 00020550 CALL MAG#LINK NOW LINK IN THE NEW MAGIC NUMBER 00020600 B MODBACK GET READY TO LEAVE 00020650 *********************************************************************** 00020700 ******************** MODIFIES THE CLASS FIELD ************** 00020750 *********************************************************************** 00020800 FDCLASS EQU * 00020850 CALL SAMENAME FIND THE NODE WITH SAME NAME FIELD 00020900 CALL DCLASS DELETE THE CLASS STANDING 00020950 L AVAILREG,NMADSTOR SET AVAILREG TO NODE FOR SUBROUTINES 00021000 MVC CLASS(2,AVAILREG),CARD+49 INSERT THE NEW CLASS 00021050 CALL CLASLINK NOW LINK IT IN 00021100 B MODBACK GET READY TO LEAVE 00021150 *********************************************************************** 00021200 ******************** MODIFIES THE CODE1 FIELD ************** 00021250 *********************************************************************** 00021300 FDCODE1 EQU * 00021350 CALL SAMENAME FIND THE NODE WITH SAME NAME FIELD 00021400 L AVAILREG,NMADSTOR SET AVAILREG TO NODE FOR SUBROUTINES 00021450 MVC CODE1(5,AVAILREG),CARD+49 INSERT THE NEW CODE1 00021500 B MODBACK GET READY TO LEAVE 00021550 *********************************************************************** 00021600 ******************** MODIFIES THE CODE2 FIELD ************** 00021650 *********************************************************************** 00021700 FDCODE2 EQU * 00021750 CALL SAMENAME FIND THE NODE WITH SAME NAME FIELD 00021800 CALL DC#2L DELETE THE CODE2 OF THE NODE 00021850 L AVAILREG,NMADSTOR SET AVAILREG TO NODE FOR SUBROUTINES 00021900 MVC CODE2(3,AVAILREG),CARD+49 INSERT THE NEW CODE2 00021950 CALL COD2LINK LINK IT IN THE RIGHT PLACE 00022000 B MODBACK GET READY TO LEAVE 00022050 *********************************************************************** 00022100 ******************** PRINTS A MESSAGE TELLING OF MODIFICATION ******** 00022150 *********************************************************************** 00022200 MODBACK MVC NAMEDUMP+1(39),NAME(AVAILREG) MOVE IN FOR OUTPUT 00022250 XPRNT FDMOD,131 PRINT THE HEADING 00022300 XPRNT NAMEDUMP,40 PRINT THE FILE 00022350 L AVAILREG,AVADST RESET AVAILREG 00022400 B UPREAD GET THE NEXT CARD 00022450 DOWHAT EQU * 00022500 MVC NAMEDUMP+1(39),CARD MOVE THE NAME IN FOR ERROR MESSAGE 00022550 XPRNT WROP,131 PRINT ERROR MESSAGE 00022600 XPRNT NAMEDUMP,40 00022650 B UPREAD GET THE NEXT CARD 00022700 FPRINTND XPRNT STAR,133 TO DRAW ONE'S ATTENTION TO THE MESS. 00022750 XPRNT STAR,133 00022800 XPRNT UPDFILE,131 PRINT AN UPDATE COMPLETION MESSAGE 00022850 XPRNT STAR,133 00022900 XPRNT STAR,133 00022950 B EOFPRINT PRINT THE UPDATED LISTS 00023000 STOP DC H'0' 00023050 *********************************************************************** 00023100 *********************************************************************** 00023150 ******************** INITIALIZES THE LINKS AND LIST HEADS IN A ******** 00023200 ******************** COMPLETELY EMPTY LIST ************** 00023250 *********************************************************************** 00023300 LISTMT EQU * 00023350 SR CLASSREG,CLASSREG 00023400 MVC P,AVAIL EMPTY LIST, INITIALIZE POINTERS 00023450 L PREG,P 00023500 MVC PTR,AVAIL 00023550 L POINTREG,PTR 00023600 LR NODELINK,AVAILREG 00023650 MVC AVAIL(4),NAMELINK(POINTREG) ADVANCE AVAIL 00023700 MVC NAMELINK(4,AVAILREG),PTR SET PTR TO FIRST NODE 00023750 MVC NAME(19,AVAILREG),CARD+1 MOVE NAME IN 00023800 CLI CARD+20,C'M' CHECK FOR MALE SEX 00023850 BE MALEMT HE IS, SO GO TO MALEMT 00023900 ST NODELINK,HDFSEX SHE ISN'T, SO DO A FEMALE 00023950 MVC FSEXLINK(4,AVAILREG),LAMDA SET THE SEX LINK-LAMDA 00024000 MVI SEX(AVAILREG),C'F' PUT A F IN THE SEX FIELD 00024050 B NUMBMT NOW GO TO MAGIC NUMBER INSERTER 00024100 MALEMT ST NODELINK,HDMSEX STORE THE ADDRESS OF NODE 00024150 MVC MSEXLINK(4,AVAILREG),LAMDA SET SEXLINK TO LAMDA 00024200 MVI SEX(AVAILREG),C'M' SET SEX FIELD TO A M 00024250 NUMBMT ST NODELINK,MAGNOR(AVAILREG) SET DOUBLE LINKS 00024300 ST NODELINK,MAGNOL(AVAILREG) 00024350 ST AVAILREG,HDMAGNO SAVE NODE'S ADDRESS 00024400 MVC MAGNUM(9,AVAILREG),CARD+21 INSERT MAGIC NUMBER 00024450 CLASSMT LA CLASSREG,HDCLASS 00024500 MVC CLASS(2,AVAILREG),CARD+30 INSERT THE CLASS 00024550 MVC CLASINFO(2,CLASSREG),CARD+30 PUT IN CLASS INDEX 00024600 ST AVAILREG,CLASSADD(CLASSREG) PUT ADDRESS IN INDEX 00024650 MVC CLASSLIK(4,AVAILREG),LAMDA SET NODE LINK TO LAMDA 00024700 CODE1MT MVC CODE1(5,AVAILREG),CARD+32 INSERT THE CODE1 00024750 CODE2MT MVC HDCODE2+1(3),CARD+37 PUT CODE2 IN CODE2 INDEX 00024800 LA ADVCDE2,HDCODE2 PUT THE ADDRESS IN ADVANCE REGISTER 00024850 ST NODELINK,CODE2LR(AVAILREG) SET INITIAL LINKS 00024900 ST NODELINK,CODE2LL(AVAILREG) 00024950 ST NODELINK,CODELIK2(ADVCDE2) PUT ADDRESS IN INDEX 00025000 MVC CODE2(3,AVAILREG),CARD+37 PUT CODE2 IN NODE 00000050 LR POINTREG,AVAILREG UPDATE THE LINKAGE POINTERS 00000100 ST POINTREG,PTR 00000150 L AVAILREG,AVAIL 00000200 B INIREAD GET THE NEXT FILE 00000250 OVERFLOW XPRNT NOROOM,126 PRINT ERROR MESSAGE 00000300 DC H'0' TERMINATE WITH A SOC-1 00000350 *********************************************************************** 00000400 SEXFIND EQU * 00000450 *********************************************************************** 00000500 ******************** CALLS THE LINKING SUBROUTINES AND ************** 00000550 ******************** DETERMINES THE STATE OF OPERATION ************** 00000600 *********************************************************************** 00000650 CALL FINAPLAC LINK THE NAME FIELD 00000700 CLI FLAG,C'1' CHECK STATE OF FLAG 00000750 BE INIREAD 00000800 L PREG,P RESET FRONT POINTER 00000850 L POINTREG,PTR RESET THE END OF LIST POINTER 00000900 CALL SEXLINK CALL MY SEX LINKER 00000950 CALL MAG#LINK CALL MY MAGIC NUMBER LINKER 00001000 CALL CLASLINK LINK THE CLASS FIELD 00001050 CALL COD2LINK CALL MY CODE2 LINKER 00001100 L AVAILREG,AVAIL UPDATE THE POINTERS AND REGISTERS 00001150 LA ADVCDE2,HDCODE2 RESET ADVANCE REGISTER 00001200 CLI STATFLAG,C'1' SEE IF IN UPDATE STATE 00001250 BE UPDATEER YES, SO GO TO UPDATE 00001300 B INIREAD GET THE NEXT CARD 00001350 LTORG 00001400 *********************************************************************** 00001450 MOVER XGO 00001500 *********************************************************************** 00001550 * INSERT ALL INFORMATION FROM THE CARD INTO STORAGE 00001600 *********************************************************************** 00001650 MVC NAME(19,AVAILREG),CARD+1 00001700 MVC SEX(1,AVAILREG),CARD+20 00001750 MVC MAGNUM(9,AVAILREG),CARD+21 00001800 MVC CLASS(2,AVAILREG),CARD+30 00001850 MVC CODE1(5,AVAILREG),CARD+32 00001900 MVC CODE2(3,AVAILREG),CARD+37 00001950 XBACK 00002000 *********************************************************************** 00002050 *********************************************************************** 00002100 ******************** LINKS THE NAME FIELD IN CIRCULAR LIST ************ 00002150 *********************************************************************** 00002200 FINAPLAC XGO 00002250 CLC NAME(19,AVAILREG),NAME(POINTREG) COMPARE THE NAMES 00002300 BE OOPS IF THEY ARE EQUAL, THEN DOUBLE ENTRY 00002350 BH SETNALK 00002400 L POINTREG,NAMELINK(POINTREG) SET TO NEXT NODE 00002450 B NWCHECK 00002500 NWCHECK EQU * 00002550 CLC NAME(19,AVAILREG),NAME(POINTREG) COMPARE THE NAMES 00002600 BL FIRST 00002650 B INCRMNT 00002700 INCRMNT L POINTREG,NAMELINK(POINTREG) SET TO NEXT NODE 00002750 CLC NAME(19,AVAILREG),NAME(POINTREG) COMPARE THE NAMES 00002800 BL BEFORE1 FIND THE PRECEEDING NAME NODE 00002850 B INCRMNT 00002900 BEFORE1 ST POINTREG,TEMPNAME SAVE THE NEXT NODE > ADDRESS 00002950 LR POINTREG,PREG SET POINTER TO THE BEGINNING OF LIST 00003000 FOR1LOOP CLC NAMELINK(4,POINTREG),TEMPNAME FIND ONE BEFORE 00003050 BE RESET WHEN FOUND GO AND LINK IT 00003100 L POINTREG,NAMELINK(POINTREG) ADVANCE POINTER 00003150 B FOR1LOOP TRY AGAIN, PLEASE 00003200 FIRST EQU * 00003250 L PREG,P RESET THE FIRST POINTER 00003300 L POINTREG,PTR RESET THE POINTER REGISTER 00003350 ST AVAILREG,NAMELINK(POINTREG) LINK BETWEEN 00003400 ST PREG,NAMELINK(AVAILREG) LINK TO LAST FIRST 00003450 ST AVAILREG,P UPDATE THE FIRST POINTER 00003500 B NAMEBACK LEAVE 00003550 RESET MVC NAMELINK(4,AVAILREG),NAMELINK(POINTREG) 00003600 ST AVAILREG,NAMELINK(POINTREG) 00003650 B NAMEBACK LEAVE 00003700 SETNALK MVC NAMELINK(4,AVAILREG),NAMELINK(POINTREG) 00003750 ST AVAILREG,NAMELINK(POINTREG) 00003800 ST AVAILREG,PTR 00003850 B NAMEBACK 00003900 OOPS EQU * 00003950 MVC AGAINAME(19),CARD+1 00004000 XPRNT DOUBENTR,125 00004050 MVI FLAG,C'1' SET THE FLAG FOR DOUBENTRY 00004100 B NAMEBACK LEAVE 00004150 STORADD ST POINTREG,NMADSTOR 00004200 NAMEBACK EQU * 00004250 XBACK 00004300 *********************************************************************** 00004350 ******************** LINKS THE SEX FIELD IN A LIST ******************* 00004400 *********************************************************************** 00004450 SEXLINK XGO 00004500 LR NODELINK,AVAILREG SET NODELINK REGISTER FOR LINKING 00004550 CLI SEX(AVAILREG),C'M' IS IT A MALE ?? 00004600 BE CHCHDM YES, CHECK HDMSEX 00004650 CLI SEX(AVAILREG),C'F' SEE IF A FEMALE 00004700 BE CHCHDF YES IT IS 00004750 B AWHAT WHAT OR WHO IS IT??? 00004800 CHCHDM CLC HDMSEX,LAMDA SEE IF FIRST MALE 00004850 BE SETHDM YES, SO SET HDMSEX 00004900 L R4,HDMSEX NO, SO LOAD THE ADDRESS INTO R4 00004950 LA R4,MSEXLINK(R4) SET R4 TO THE LINK OF THE NEXT MALE 00005000 SEXLOOPM CLC 0(4,R4),LAMDA FIND THE LAST MALE 00005050 BE INSETMSX FOUND SO LINK NEW ENTRY 00005100 L R4,0(R4) NOT FOUND--->UPDATE ADDRESS 00005150 LA R4,MSEXLINK(R4) SET R4 TO THE LINK OF THE NEXT MALE 00005200 B SEXLOOPM TRY AGAIN 00005250 INSETMSX ST NODELINK,0(R4) LINK IN THE NEW ENTRY 00005300 MVC MSEXLINK(4,NODELINK),LAMDA 00005350 B SEXBACK FINISHED SO LEAVE 00005400 SETHDM ST NODELINK,HDMSEX SET MALE INDEX 00005450 MVC MSEXLINK(4,NODELINK),LAMDA SET NODE LINK TO LAMDA 00005500 B SEXBACK FINISHED, SO LEAVE 00005550 CHCHDF CLC HDFSEX,LAMDA SEE IF FIRST FEMALE 00005600 BE SETHDF YES, SET THE FEMALE INDEX 00005650 L R4,HDFSEX NO, FIND THE LAST FEMALE 00005700 LA R4,FSEXLINK(R4) SET R4 TO THE LINK OF NEXT FEMALE 00005750 SEXLOOPF CLC 0(4,R4),LAMDA IS THIS THE LAST FEMALE??? 00005800 BE INSETFSX YES,, INSERT AND LINK HER 00005850 L R4,0(R4) NOT FOUND--->UPDATE ADDRESS 00005900 LA R4,FSEXLINK(R4) SET R4 TO THE LINK OF NEXT FEMALE 00005950 B SEXLOOPF TRY AGAIN 00006000 SETHDF ST NODELINK,HDFSEX SET THE FEMALE SEX INDEX 00006050 MVC FSEXLINK(4,NODELINK),LAMDA SET NODE LINK TO LAMDA 00006100 B SEXBACK NOW LEAVE 00006150 INSETFSX ST NODELINK,0(R4) SET LINK TO NEW FEMALE 00006200 MVC FSEXLINK(4,NODELINK),LAMDA SET HER LINK TO LAMDA 00006250 B SEXBACK LEAVE 00006300 AWHAT MVC WHATSEX(19),NAME(AVAILREG) MOVE THE NAME IN 00006350 XPRNT NOSEX,131 00006400 SEXBACK EQU * 00006450 XBACK 00006500 *********************************************************************** 00006550 ******************** LINKS THE MAGIC NUMBER IN A DOUBLY ************** 00006600 ******************** LINKED CIRCULAR LIST ************** 00006650 *********************************************************************** 00006700 MAG#LINK XGO 00006750 L MAGNOREG,HDMAGNO SET # REGISTER TO THE FIRST NUMBER 00006800 CLC MAGNUM(9,AVAILREG),MAGNUM(MAGNOREG) COMPARE 1ST ORDER 00006850 BL NEWFIRST LESS THAN, GO TO NEWFIRST 00006900 B MAGCHECK 00006950 MAG#LOOP L MAGNOREG,MAGNOR(MAGNOREG) UPDATE ADDRESS 00007000 CLC MAGNUM(9,AVAILREG),MAGNUM(MAGNOREG) COMPARE FOR ORDER 00007050 BL MAG#INST IT <, SO LINK AND INSERT 00007100 MAGCHECK CLC MAGNOR(4,MAGNOREG),HDMAGNO SEE IF LAST ONE 00007150 BE LASTONE 00007200 BNE MAG#LOOP 00007250 LASTONE MVC MAGNOR(4,AVAILREG),MAGNOR(MAGNOREG) 00007300 ST MAGNOREG,MAGNOL(AVAILREG) 00007350 ST AVAILREG,MAGNOR(MAGNOREG) 00007400 L MAGNOREG,MAGNOR(AVAILREG) 00007450 ST AVAILREG,MAGNOL(MAGNOREG) 00007500 B MAG#OUT 00007550 MAG#INST ST MAGNOREG,MAGNOR(AVAILREG) 00007600 MVC MAGNOL(4,AVAILREG),MAGNOL(MAGNOREG) 00007650 ST AVAILREG,MAGNOL(MAGNOREG) SET LINKS 00007700 L MAGNOREG,MAGNOL(AVAILREG) 00007750 ST AVAILREG,MAGNOR(MAGNOREG) 00007800 B MAG#OUT LEAVE 00007850 NEWFIRST ST AVAILREG,HDMAGNO SET INDEX TO FIRST NUMBER 00007900 MVC MAGNOL(4,AVAILREG),MAGNOL(MAGNOREG) 00007950 ST MAGNOREG,MAGNOR(AVAILREG) 00008000 ST AVAILREG,MAGNOL(MAGNOREG) 00008050 L MAGNOREG,MAGNOL(AVAILREG) 00008100 ST AVAILREG,MAGNOR(MAGNOREG) 00008150 B MAG#OUT LEAVE 00008200 MAG#OUT EQU * 00008250 XBACK 00008300 *********************************************************************** 00008350 ******************** LINKS THE CLASS FIELD IN A LIST ************** 00008400 *********************************************************************** 00008450 CLASLINK XGO 00008500 LA CLASSREG,HDCLASS RESET THE CLASS REGISTER 00008550 CLASCHEC CLC 0(8,CLASSREG),PLUSES SEE IF INDEX IS FULL 00008600 BE NOCLASPE 00008650 CLC 0(8,CLASSREG),ZEROS SEE IF EMPTY SPACE IS PRESENT 00008700 BE INSTCLAS 00008750 CLC CLASINFO(2,CLASSREG),CLASS(AVAILREG) IS IT A OLD ONE 00008800 BE NOWCLAIN YES, SO INSERT 00008850 LA CLASSREG,8(CLASSREG) INCREMENT CLASS REGISTER 00008900 B CLASCHEC 00008950 NOCLASPE MVC CLASFILE(19),NAME(AVAILREG) MOVE NAME INTO CLASFLE 00009000 XPRNT NCLASPCE,113 00009050 XPRNT CLASFILE+19,131 00009100 ST AVAILREG,AVAIL UNSET ADVANCED AVAIL 00009150 DC H'0' TERMINATE WITH A SOC---1 00009200 INSTCLAS MVC CLASINFO(2,CLASSREG),CLASS(AVAILREG) PUT IN INDEX 00009250 ST AVAILREG,CLASSADD(CLASSREG) PUT ADDRESS IN INDEX 00009300 MVC CLASSLIK(4,AVAILREG),LAMDA SET NODE LINK TO LAMDA 00009350 B CLASBACK LEAVE 00009400 NOWCLAIN L R3,CLASSADD(CLASSREG) INITIALIZE R3 00009450 CLASLOOP CLC CLASSLIK(4,R3),LAMDA SEE IF LAST ONE 00009500 BE EARCLASS YES, SO NOW INSERT 00009550 L R3,CLASSLIK(R3) UPDATE SEARCH ADDRESS 00009600 B CLASLOOP TRY AGAIN 00009650 EARCLASS ST AVAILREG,CLASSLIK(R3) SET LAST NODE TO NEW NODE ADDRES 00009700 MVC CLASSLIK(4,AVAILREG),LAMDA SET NODE LINK TO LAMDA 00009750 B CLASBACK LEAVE 00009800 CLASBACK EQU * 00009850 XBACK 00009900 *********************************************************************** 00009950 *********************************************************************** 00010000 ******************** LINKS THE CODE2 FIELDS IN A DOUBLY ************** 00010050 ******************** LINKED CIRCULAR LIST ************** 00010100 *********************************************************************** 00010150 COD2LINK XGO 00010200 CDECHECK CLC 1(3,ADVCDE2),PLUSES SEE IF CODE2 INDEX IS FULL 00010250 BE NOSPACE IT IS, PRINT AN ERROR MESSAGE 00010300 CLC 1(3,ADVCDE2),ZEROS IS IT A NEW CODE ????? 00010350 BE INSTCOD2 YES, SO INSERT IT IN THE INDEX 00010400 CLC 1(3,ADVCDE2),CODE2(AVAILREG) IS IT A NEW CODE ?? 00010450 BE NOWINCD2 NO, SO PUT WITH OLD 00010500 LA ADVCDE2,8(ADVCDE2) KEEP LOOKING 00010550 B CDECHECK 00010600 NOSPACE MVC CD2FILE(19),NAME(AVAILREG) MOVE FOR OUTPUT 00010650 XPRNT CD2SPACE,123 00010700 ST AVAILREG,AVAIL UNSET THE NEW AVAIL ADDRESS 00010750 DC H'0' TERMINATE WITH A SOC--1 00010800 INSTCOD2 MVC 1(3,ADVCDE2),CODE2(AVAILREG) PUT CODE2 IN INDEX 00010850 ST AVAILREG,CODELIK2(ADVCDE2) SET LINKS 00010900 ST AVAILREG,CODE2LL(AVAILREG) 00010950 ST AVAILREG,CODE2LR(AVAILREG) 00011000 B CD#2OUT LEAVE 00011050 NOWINCD2 L ADVCDE2,CODELIK2(ADVCDE2) POINTS TO FIRST CODE2 00011100 ST ADVCDE2,TEMPCOD2 STORE FOR COMPARISON 00011150 CD2LOOP CLC TEMPCOD2,CODE2LR(ADVCDE2) FIND LAST SIMILIAR CD2 00011200 BE INCODE2 FOUND!!!!! 00011250 L ADVCDE2,CODE2LR(ADVCDE2) NO, LOOK AGAIN 00011300 B CD2LOOP 00011350 INCODE2 EQU * 00011400 MVC CODE2LR(4,AVAILREG),CODE2LR(ADVCDE2) SET LINKS 00011450 ST AVAILREG,CODE2LR(ADVCDE2) 00011500 ST ADVCDE2,CODE2LL(AVAILREG) 00011550 L ADVCDE2,TEMPCOD2 RESET CODE2 INDEX REGISTER 00011600 ST AVAILREG,CODE2LL(ADVCDE2) 00011650 B CD#2OUT LEAVE 00011700 CD#2OUT EQU * 00011750 XBACK 00011800 *********************************************************************** 00011850 *********************************************************************** 00011900 ******************** FINDS THE SAME NAME AND THE ONE ************** 00011950 ******************** BEFORE FOR DELETION OR MODIFICATION ************* 00012000 *********************************************************************** 00012050 SAMENAME XGO 00012100 LA AVAILREG,FAKENODE SET AVAILREG TO FAKE NODE ADDRESS 00012150 MVC NAME(19,AVAILREG),CARD+1 MOVE NAME ITO FAKE NOD 00012200 LR NODELINK,PREG SET NODELINK TO FIRST NODE IN LIST 00012250 CR PREG,POINTREG SEE IF LAST NODE 00012300 BE LASTNODE YES IT IS 00012350 SAMELOOP CLC NAME(19,AVAILREG),NAME(NODELINK) 00012400 BE CHEKPT IF =,CHECK FOR POSITION IN LIST 00012450 L NODELINK,NAMELINK(NODELINK) NOT =, SO COMPARE NEXT 00012500 CR PREG,NODELINK IS IT IN THE LIST?? 00012550 BE AHA NO IT IS NOT IN THE LIST 00012600 B SAMELOOP COMPARE AGAIN 00012650 CHEKPT ST NODELINK,NMADSTOR SAVE THE ADDRESS OF THE NODE-EQUAL 00012700 CR PREG,NODELINK IS IT THE FIRST NODE ?? 00012750 BE DELFIRST YES 00012800 CR POINTREG,NODELINK IS IT THE LAST NODE?? 00012850 BE DELELAST YES 00012900 B FINDBFOR NO SPECIAL POSITION SO JUST FIND 1B4 00012950 FINDBFOR L NODELINK,NAMELINK(NODELINK) TRY NEXT NODE 00013000 CLC NAMELINK(4,NODELINK),NMADSTOR SEE IF ONE B4 00013050 BE BEFOUND THIS IS THE ONE!! 00013100 B FINDBFOR TRY AGAIN 00013150 DELFIRST MVI DFFLAG,C'1' SET A FLAG 00013200 B SAMEBACK LEAVE 00013250 DELELAST MVI DFFLAG,C'2' SET FLAG AND FIND ONE BEFORE 00013300 B FINDBFOR 00013350 LASTNODE ST NODELINK,NMADSTOR SAVE ADDRESS 00013400 MVI DFFLAG,C'3' SET FLAG 00013450 B SAMEBACK LEAVE 00013500 BEFOUND ST NODELINK,TEMPNAME SAVE ADDRESS OF NODE BEFORE 00013550 B SAMEBACK LEAVE 00013600 AHA MVC MICFIN(19),NAME(AVAILREG) 00013650 XPRNT NOFILE,133 PRINT MESSAGE OF NOT IN LIST 00013700 MVI DFFLAG,C'4' SET FLAG 00013750 SAMEBACK EQU * 00013800 XBACK 00013850 *********************************************************************** 00013900 ******************** DELETES THE NAME FIELD ************* 00013950 *********************************************************************** 00014000 DNL XGO 00014050 L NODELINK,TEMPNAME SET TO NAME B4 00014100 L R4,NMADSTOR SET TO THE NODE 00014150 MVC NAMELINK(4,NODELINK),NAMELINK(R4) DELETE THE NAME 00014200 XBACK 00014250 *********************************************************************** 00014300 ******************** DELETES THE SEX FIELD ************** 00014350 *********************************************************************** 00014400 DSL XGO 00014450 L NODELINK,NMADSTOR SET TO THE NODE 00014500 CLI SEX(NODELINK),C'M' SEE IF A MALE 00014550 BE DM YES, SO WORK ON MALE LIST 00014600 L R4,HDFSEX NO SO IT IS A FEMALE 00014650 CFSEX CR R4,NODELINK IS SHE THE LAST FEMALE?? 00014700 BE CHECKITF SEE IF LAST NODE IN SUBLIST 00014750 C NODELINK,FSEXLINK(R4) SEE IF THE END FEMALE 00014800 BE LINKARF YES, DELINK HER 00014850 L R4,FSEXLINK(R4) NO, SO TRY NEXT LINKED NODE 00014900 B CFSEX TRY AGAIN 00014950 DM L R4,HDMSEX SET TO ADDRESS IN LIST HEAD 00015000 CR NODELINK,R4 SEE IF LAST MALE 00015050 BE CHECKITM IS IT THE LAST 1 IN SUBLIST ??? 00015100 CMSEX C NODELINK,MSEXLINK(R4) SEE IF END MALE 00015150 BE LINKARM YES!! 00015200 L R4,MSEXLINK(R4) NO---SET R4 TO NEXT LINKED MALE 00015250 B CMSEX TRY AGAIN 00015300 LINKARM MVC MSEXLINK(4,R4),MSEXLINK(NODELINK) LINK AROUND 00015350 B DSLBACK 00015400 THATSITF MVC HDFSEX,LAMDA 00015450 B DSLBACK 00015500 THATSITM MVC HDMSEX,LAMDA SET LIST HEAD TO LAMDA 00015550 B DSLBACK 00015600 CHECKITF CLC FSEXLINK(4,NODELINK),LAMDA LAST ONE ??? 00015650 BE THATSITF YES SO SET HDFSEX TO LAMDA 00015700 MVC HDFSEX(4),FSEXLINK(NODELINK) NO SO SET THIS IN HDFS 00015750 B LINKARF NOW DELETE 00015800 CHECKITM CLC MSEXLINK(4,NODELINK),LAMDA SEE IF LAST ONE 00015850 BE THATSITM 00015900 MVC HDMSEX(4),MSEXLINK(NODELINK) SO SET THE MALE LIST H 00015950 B LINKARM NOW DELETE 00016000 LINKARF MVC FSEXLINK(4,R4),FSEXLINK(NODELINK) LINK AROUND 00016050 DSLBACK XBACK 00016100 *********************************************************************** 00016150 ******************** DELETES THE MAGIC NUMBER FIELD ************** 00016200 *********************************************************************** 00016250 DM#L XGO 00016300 L R4,NMADSTOR SET TO NODE 00016350 L NODELINK,NMADSTOR ALSO SET TO THE NODE 00016400 L NODELINK,MAGNOR(NODELINK) SET TO THE RIGHT LINK 00016450 L R4,MAGNOL(R4) SET TO THE LEFT LINK 00016500 CLC HDMAGNO(4),NMADSTOR SEE IF FIRST ONE 00016550 BE SETHDMAG YES, SO SET HDMAGNO 00016600 SETML ST NODELINK,MAGNOR(R4) LINK AROUND 00016650 ST R4,MAGNOL(NODELINK) LINK AROUND 00016700 B DM#LBACK 00016750 SETHDMAG ST NODELINK,HDMAGNO SET THE MAGIC # LIST HEAD 00016800 B SETML NOW DELETE 00016850 DM#LBACK EQU * 00016900 XBACK 00016950 *********************************************************************** 00017000 ******************** DELETES THE CLASS FIELD ************** 00017050 *********************************************************************** 00017100 DCLASS XGO 00017150 L NODELINK,NMADSTOR SET TO THE NODE 00017200 LA R4,HDCLASS+2 SET R4 TO INFO FEILD OF CLASS HEAD 00017250 DCLASLOP LR R3,R4 SAVE FOR LATER 00017300 CLC CLASS(2,NODELINK),0(R4) SEE IF OF SAME CLASS 00017350 BE NOWTLINK IF OF SAME CLASS , THEN FIND NODE 00017400 LA R4,8(R4) SET TO NEXT CLASS FIELD 00017450 B DCLASLOP 00017500 NOWTLINK L R4,2(R4) SET TO THE ADDRESS OF FIRST CLNODE 00017550 CR R4,NODELINK SEE IF LAST ONE 00017600 BE CHECKITC SEE IF LAST ONE LEFT 00017650 DLINLOOP C NODELINK,CLASSLIK(R4) IS THIS THE NODE BEFORE??? 00017700 BE LINKARC IF YES, THEN LINK AROUND 00017750 L R4,CLASSLIK(R4) NO, SO TRY NEXT LINKED NODE 00017800 B DLINLOOP TRY AGAIN 00017850 THATSALL MVC 0(6,R3),ZEROS RESET CLASS LIST HEAD 00017900 B DC#LBACK NOW LEAVE 00017950 CHECKITC CLC CLASSLIK(4,NODELINK),LAMDA IS IT THE LAST ONE 00018000 BE THATSALL YES IT IS THE LAST ONE OF THIS CLASS 00018050 MVC 2(4,R3),CLASSLIK(NODELINK) UPDATE THE CLASS INDEX 00018100 LINKARC MVC CLASSLIK(4,R4),CLASSLIK(NODELINK) LINK AROUND 00018150 DC#LBACK EQU * 00018200 XBACK 00018250 *********************************************************************** 00018300 ******************** DELETES THE CODE2 FIELD ************** 00018350 *********************************************************************** 00018400 DC#2L XGO 00018450 LA R4,HDCODE2+1 SET TO INFO FIELD OF CODE2 INDEX 00018500 L NODELINK,NMADSTOR SET TO THE NODE 00018550 FINDCD#2 CLC CODE2(3,NODELINK),0(R4) SEE IF OF SAME CODE2 00018600 BE CD#FOUND YES,? THEN FIND LINK 00018650 LA R4,8(R4) SEE IF IT IS THE NEXT ONE 00018700 LR R3,R4 SAVE FOR LATER 00018750 B FINDCD#2 00018800 CD#FOUND L R4,3(R4) LOAD THE FIRST SIMILAR ADDRESS IN R4 00018850 CR R4,NODELINK SEE IF LAST ONE 00018900 BE CHECKC#2 SEE IF THE LAST ONE IN SUBLIST 00018950 LR R4,NODELINK SET R4 00019000 L NODELINK,CODE2LR(NODELINK) LINK AROUND 00019050 L R4,CODE2LL(R4) 00019100 ST NODELINK,CODE2LR(R4) SET LINKS AROUND 00019150 ST R4,CODE2LL(NODELINK) SET LINKS AROUND 00019200 B C#2LBACK LEAVE 00019250 CHECKC#2 CLC 3(4,R3),CODE2LR(NODELINK) IS IT THE LAST ONE 00019300 BE THATACD2 YES? GO SET LIST HEAD 00019350 MVC 3(4,R3),CODE2LR(NODELINK) UPDATE THE LIST HEAD 00019400 B C#2LBACK 00019450 THATACD2 MVC 0(7,R3),MINUS RESET THE LIST HEAD TO THE NULL LINK 00019500 C#2LBACK EQU * 00019550 XBACK 00019600 *********************************************************************** 00019650 CONSTANT CSECT 00019700 OPTAB TRTAB 16,TABLE=(A,4,D,8,M,12) 00019750 OPOP TRTAB 28,TABLE=(1,4,2,8,3,12,4,16,5,20,6,24) 00019800 FEMFLAG DC C'0' 00019850 DFFLAG DC C'0' 00019900 STATFLAG DS C 00019950 FLAG DS C 00020000 BLANKS DC CL72' ' 00020050 LAMDA DC CL10'-1-1-1-1-1' 00020100 STARS DC CL19'*******************' 00020150 MINUS DC CL8'--------' 00020200 PLUSES DC CL8'++++++++' 00020250 CD2HEAD DC C'1',49C'*',CL33'THE LIST OF SIMILIAR CODE2 FIELDS',49C'100020300 *' 00020350 MAGHEAD DC C'1',38C'*',CL53'THE LIST ACCORDING TO MAGIC NUMBER IN A100020400 SCENDING ORDER',38C'*' 00020450 FEMHEAD DC C'1',47C'*',CL35'THE LIST OF ALL FEMALES IN THE FILE',49100020500 C'*' 00020550 NFEM DC C'2',44C'/',CL43'THE LIST OF FEMALES ON FILE IS NONEXIST100020600 ANT',44C'/' 00020650 MALEHEAD DC C'1',47C'*',CL33'THE LIST OF ALL MALES IN THE FILE',47C'100020700 *' 00020750 NMALE DC C'2',45C'/',CL40'THE LIST OF MALES ON FILE IN NONEXISTAN100020800 TANT',45C'/' 00020850 CLASHEAD DC C'1',40C'*',CL46'THE LIST OF PEOPLE WITH IDENTICAL CLASS100020900 FIELDS',40C'*' 00020950 NAMEHEAD DC C'1',40C'*',CL43'THE LIST IN ALPHABETICAL ORDER BY LAST 100021000 NAME',40C'*' 00021050 NAMEDUMP DC C'0' 00021100 DS CL39 00021150 SPECNAME DC C'0',17C' ',CL4'NAME',21C' ',CL3'SEX',13C' ' 00021200 DC CL12'MAGIC NUMBER',13C' ',CL5'CLASS',13C' ',CL5'CODE1',1100021250 3C' ',CL5'CODE2',15C' ' 00021300 FILES DC 133C' ' 00021350 DOUBENTR DC C'+',5C'/',CL11'THE FILE OF',3C' ' 00021400 AGAINAME DS CL19 00021450 DC 3C' ',CL56'IS ALREADY IN THE ORIGINAL FILE SO IT HAS NOT100021500 BEEN ADDED',8C'*',CL15'CHECK YOUR DATA',7C'*' 00021550 NCLASPCE DC C'0',10C'*',CL81'THE SPACE FOR CLASS INDEXING IS EXHAUST100021600 ED, THE FILE BEING READ IN AT OVERFLOW WAS',3C' ' 00021650 CLASFILE DS CL19 00021700 DC C' ',40C'*',CL50'PROBABLE CAUSE---CLASS IN DATA OTHER TH100021750 AN 01--->13',40C'*' 00021800 CD2SPACE DC C'1',10C'*',CL93'THE SPACE FOR CODE2 INDEXING IS EXHAUST100021850 ED, THE FILE BEING READ IN AT THE TIME OF OVERFLOW WAS' 00021900 CD2FILE DS CL19 00021950 DC 8C'*' 00022000 NOROOM DC C' ',20C'*',CL5'ERROR',15C'*',CL50'THOU LAVS RUNNETH OVE100022050 R AVAILABLE ALLOCATED STORAGE',35C'*' 00022100 NOSEX DC C'2',15C'/',CL24'THE PERSON WHOSE NAME IS',3C' ' 00022150 WHATSEX DS CL19 00022200 DC 3C' ',CL70'IS OF THE NEUTER SEX, THEREFORE HAS NOT BEEN 100022250 ADDED TO THE ORIGINAL LIST',15C'/' 00022300 NOFILE DC C'2',24C'?',CL11'THE FILE OF',3C' ' 00022350 MICFIN DS CL19 00022400 DC 3C' ',CL48'CAN NOT BE DELETED BECAUSE IT IS NOT IN THE L100022450 IST',24C'?' 00022500 GOODBYE DC 48C' ',CL36'THE LIST HAS BEEN EMPTIED COMPLETELY',47C' ' 00022550 ERFIELD DC C' ',CL5'ERROR',7C'-',CL79'THE FOLLOWING FILE TO BE MODI100022600 FIED CONTAINS AN INVALID FIELD MODIFICATION NUMBER',5C'*200022650 ',CL27'THIS CARD HAS BEEN BYPASSED',6C'-' 00022700 ERBLANK DC C' ',25C'*',CL5'ERROR',3C'-',CL70'THE FOLLOWING FILE HAS100022750 BEEN BYPASSED DUE TO A BLANK MODIFICATION FIELD',25C'*' 00022800 FDMOD DC C'-',25C'*',CL24'THE FILE NOW MODIFIED IS',81C'*' 00022850 WROP DC C'2',17C'/',CL5'ERROR',3C'-',CL88'AN UNDEFINED OPERATION100022900 WAS SPECIFIED IN COL. 42, THE CARD THAT FOLLOWS HAS BEE200022950 N BYPASSED',17C'/' 00023000 UPDFILE DC C'0',35C' ',CL60'THE UPDATING AND MODIFICATION OF THE LI100023050 ST HAS BEEN COMPLETED',35C' ' 00023100 FCLASOUT DC C'1',35C'*',CL66'THE FOLLOWING LIST CONTAINS PERSONS WHO100023150 SE CLASS IS GREATER THAN 07',30C'*' 00023200 NOCHIC DC C'0',56C'!',CL18'THIS LIST IS EMPTY',56C'!' 00023250 FFEMPRIT DC C'1',25C'*',CL69'THE FOLLOWING LIST CONTAINS ALL GIRLS W100023300 ITH MAGIC NUMBERS GREATER THAN',3C' ',9C'5',25C'*' 00023350 STAR DC C' ',132C'*' 00023400 ZEROS DC CL10'0000000000' 00023450 FAKENODE DC CL72' ' 00023500 SEVEN DC CL2'07' 00023550 FIVES DC CL9'555555555' 00023600 DS 0F 00023650 NODLKST DC CL4'0000' 00023700 STOREIN DC CL4'0000' 00023750 HDMAGNO DC CL4'-1-1' 00023800 HDFSEX DC CL4'-1-1' 00023850 HDMSEX DC CL4'-1-1' 00023900 HDCLASS DC 25CL8'00000000' 00023950 DC CL8'++++++++' 00024000 HDCODE2 DC 25CL8'00000000' 00024050 HDCODEND DC CL8'++++++++' 00024100 CARD DS CL80 00024150 P DS CL4 00024200 PTR DC CL4'0000' 00024250 AVAIL DC CL4'0000' 00024300 TEMPCOD2 DS F 00024350 AVADST DC CL4'0000' 00024400 NMADSTOR DC CL4'0000' 00024450 TEMPNAME DC CL4'0000' 00024500 LAVS DC 200CL72' ' 00024550 DC CL10'-1-1-1-1-1' 00024600 END 00024650 $ENTRY 00024700 6HADDEN JOHN DANIEL M226621106GRCMPSCS25CMPSCS25404 01 3357000024750 6HELSEL BARBARA JEANF16242231309CMPSCS25CMPSCS25404 01 3357000024800 6QUAMMEN GERALD A M19940708508CMPSCS25CMPSCS25404 01 3357000024850 6RUSSONIELLO VINCENTM17842659008CMPSCS25CMPSCS25404 01 3357000024900 6HICKS ROBERT W M19036492309CMPSCS25CMPSCS25404 01 3357000024950 6HOLZER PAUL LOUIS M17038543507CMPSCS25CMPSCS25404 01 3357000025000 6HOSTETLER CLETUS L M280267240GRCMPSCS25CMPSCS25404 01 3357000000050 6SCHOKA ANDREW M M157302377GRN DEGY30CMPSCS25404 01 3357000000100 6SEIFRIT GEORGE EARLM20038844410CMPSCS25CMPSCS25404 01 3357000000150 6TURNBULL MICHAEL G M17638198509CMPSCS25CMPSCS25404 01 3357000000200 6WARRICK THOMAS R M178407063GRCMPSCS25CMPSCS25404 01 3357000000250 6WEISSER PAUL T M20442083508CMPSCS25CMPSCS25404 01 3357000000300 6WEISBERG ARVIN MILEM16440250809CMPSCS25CMPSCS25404 01 3357000000350 6RIGHI EARL THOMAS JM20840146308CMPSCS25CMPSCS25404 01 3357000000400 6JOHN RHYS DAVID M19038036109CMPSCS25CMPSCS25404 01 3357000000450 6COPE CLARENCE GILL M18140918308CMPSCS25CMPSCS25404 01 3357000000500 6DIGGINS CHARLES F M19242162708CMPSCS25CMPSCS25404 01 3357000000550 6ELLIOTT WILLIAM IIIM080320606GRCMPSCS25CMPSCS25404 01 3357000000600 6HUNDY MICHAEL J M172328223AEADJ Y05CMPSCS25404 01 3357000000650 6RIVELL RICHARD M14036301710CMPSCS25CMPSCS25404 01 3357000000700 6LANGE BETTYLOU F053403527GRCMPSCS25CMPSCS25404 01 3357000000750 6CLARK RICHARD A M329383268GRCMPSCS25CMPSCS25404 01 3357000000800 6MOON BYRON JOHN II M18640627609CMPSCS25CMPSCS25404 01 3357000000850 6BANGE CLAIR JOHN JRM174365058GRCMPSCS25CMPSCS25404 01 3357000000900 6NELSON KEVIN ERIK M18138124008CMPSCS25CMPSCS25404 01 3357000000950 6KALIN RICHARD STUARM479408587GRCMPSCS25CMPSCS25404 01 3357000001000 6MULLAN KATHLEEN K F17242864808CMPSCS25CMPSCS25404 01 3357000001050 6AUKER CHARLES W M189360098UESC S90CMPSCS25404 01 3357000001100 6TILEY JANE LOUISE F04838578908CMPSCS25CMPSCS25404 01 3357000001150 6NICKESON KENNETH E M18442360908CMPSCS25CMPSCS25404 01 3357000001200 6COCHRAN JOHN L M17442164008CMPSCS25CMPSCS25404 01 3357000001250 6STEWART BARBARA JEAF17042446211MATH S30CMPSCS25404 01 3357000001300 6RAPHAEL BARRY S M046346440ADADJ Y05CMPSCS25404 01 3357000001350 6CARELLI DENNIS JOHNM16042669808CMPSCS25CMPSCS25404 01 3357000001400 6NAPOLEON FRANK L M19240483308CMPSCS25CMPSCS25404 01 3357000001450 6MILFORD MARK TERENCM20338549008CMPSCS25CMPSCS25404 01 3357000001500 6CATON ROBERT GEORGEM16242355511CMPSCS25CMPSCS25404 01 3357000001550 6SKERCHOCK JOHN A M16442239911CMPSCS25CMPSCS25404 01 3357000001600 6STALTER IRA A JR M184366253GRCMPSCS25CMPSCS25404 01 3357000001650 6STOCKMAN GEORGE C M191348516GRCMPSCS25CMPSCS25404 01 3357000001700 6EDGAR LUCINDA ANN F208367961AEADJ Y05CMPSCS25404 01 3357000001750 6BECKER THOMAS JOSEPM18340977508CMPSCS25CMPSCS25404 01 3357000001800 6LEARMONT ELIZABETH F392463876GRCMPSCS25CMPSCS25404 01 3357000001850 6EICHHOLTZ ROBERT JRM18838547008CMPSCS25CMPSCS25404 01 3357000001900 6LINZ PAUL RICHARD M19336714513SOC L92CMPSCS25404 01 3357000001950 6KENEPP PAUL L M185303508GECMPSCS25CMPSCS25404 01 3357000002000 6WILSON DEBORAH F20738510909CMPSCS25CMPSCS25404 01 3357000002050 6BLACK SANDRA F18638210910ADVT L01CMPSCS25404 01 3357000002100 6MACEYUNAS PAUL J M041389959GRCMPSCS25CMPSCS25404 01 3357000002150 6BLAKE WILLIAM C M48158304106E E G25CMPSCS25404 01 3357000002200 6MAGILL DONALD RAY M20530675810CMPSCS25CMPSCS25404 01 3357000002250 6MAURER THOMAS A M210369617GRCMPSCS25CMPSCS25404 01 3357000002300 6MC CALL KEITH R M18142569105CMPSCS25CMPSCS25404 01 3357000002350 6STUMP WILLIAM HUNTEM17742909608CMPSCS25CMPSCS25404 01 3357000002400 6BRONG DOUGLAS G M20340141012COUN T01CMPSCS25404 01 3357000002450 6THOMAS GREGORY DALEM17040925808CMPSCS25CMPSCS25404 01 3357000002500 6BENNETT IAN G M264864999AEADJ Y05CMPSCS25404 01 3357000002550 6LIPP H ANNE F18638242907CMPSCS25CMPSCS25404 01 3357000002600 6BLACK KARL DEAN M523502468GRCD FRJ01CMPSCS25404 01 3357000002650 6BLUNT CHARLES R M579466035GECMPSCS25CMPSCS25404 01 3357000002700 6OLIVIERI LAURA A F05138716208CMPSCS25CMPSCS25404 01 3357000002750 6LYLE THOMAS JOSEPH M16242982508CMPSCS25CMPSCS25404 01 3357000002800 6PAULHAMUS RICHARD EM183407013GRCMPSCS25CMPSCS25404 01 3357000002850 6PEARSON MARY WINDERF223721061GRCMPSCS25CMPSCS25404 01 3357000002900 6ELSTON JAY COLLIN M19436461908CMPSCS25CMPSCS25404 01 3357000002950 6FRY STANLEY B M161422090AEADJ Y05CMPSCS25404 01 3357000003000 6GIBBONS JOHN J M20634189111ZOOL S96CMPSCS25404 01 3357000003050 6GINGERICH JEFFREY ZM17338784114ARCH B10CMPSCS25404 01 3357000003100 6GORE GEORGE ROLAND M18340649710CMPSCS25CMPSCS25404 01 3357000003150 ****** 00003200 6LEARMONT ELIZABETH F392463876GRCMPSCS25CMP3CS254567890123 3357000003250 6IAMADUMMYENTRY!!! M18138124008CMPSCS25CAPSCS25404 01 3357000003300 6STUMP WILLIAM HUNTEM17742909608CMPSCS25CMP2CS254F4 01 3357000003350 6FRY STANLEY B M161422090AEADJ Y05CDPSCS25404 01 3357000003400 6LYLE THOMAS JOSEPH M16242982508CMPSCS25CMP1CS254SLYLER THOMAS JOSEPH57000003450 6TILEY JANE LOUISE F04838578908CMPSCS25CMP4CS254NONE 3357000003500 6BLUNT CHARLES R M579466035GECMPSCS25CMP4CS254Y0501 3357000003550 ******* 00003600 $JOB ASSIST MACRO=F 00003650 MACRO 00003700 &LABEL QSAVE ®S,&BASE,&SA 00003750 .* 00003800 .* QSAVE GIVES STANDARD LINKAGE CONVENTIONS FOR A CSECT. 00003850 .* 00003900 .* BASE=NUMBER -THIS IS THE BASE REGISTER. DEFAULT IS REGISTER 12 00003950 .* REGISTER 13,14,15 ARE ILLEGAL 00004000 .* REGS=(CNT1,CNT2) -THESE ARE REGISTERS TO BE SAVED. 00004050 .* THE DEFAULT VALUE IS 14,12. 00004100 .* SA=VALUE -TAKES CARE OF SAVE AREA NAME AND ITS PROPER LINKAGE 00004150 .* IF VALUE=NO - THEN THERE IS NO SAVEAREA CREATED. 00004200 .* IF VALUE=NAME SAVE AREA LINKAGE WILL BE DONE AND 00004250 .* ITS ADDRESS PLACED IN REGISTER 13. 00004300 .* IF VALUE=* -SAVE AREA NAME IS FIRST 3 LETTERS OF 00004350 .* CSECT NAME FOLLOWED BY A UNIQUE NUMBER AND AN 00004400 .* 'S'. THIS IS DEFINED AS GBLC TO BE USED BY 00004450 .* QRETURN LATER. 00004500 .* 00004550 .* &SANAME - SAVE AREA NAME GENERATED IF VALUE=*. USED BY QRETURN 00004600 .* &DISPLT -DISPLACEMENT FOR ST OR STM INSTRUCTIONS. 00004650 .* ®NUM -REGISTER NUMBER USED TO DETERMINE DISPLACEMENT. 00004700 .* &BASERG -BASE REGISTER IS DEFAULTED TO 12. 00004750 .* &NAME -CSECT OR LABEL IDENTIFICATION NAME 00004800 .* &NUMBER -LENGTH OF BRANCH AND CSECT IDENTIFICATION NAME. 00004850 .* 00004900 GBLC &SANAME 00004950 LCLA &DISPLT,®NUM,&NUMBER,&BASERG 00005000 LCLC &NAME 00005050 &BASERG SETA 12 00005100 &DISPLT SETA 12 00005150 ®NUM SETA 14 00005200 .* 00005250 .* DEFINE LABEL IN DC AND BRANCH INSTRUCTIONS. 00005300 .* 00005350 &LABEL DS OH 00005400 USING *,15 TEMPORARY BASE REGISTER. 00005450 AIF (T'&LABEL EQ '0').NACSECT IF NO LABEL,USE CSECT NAME 00005500 &NAME SETC '&LABEL' IDENTIFICATION NAME =&LABEL 00005550 AGO .AROUND BRANCH TO MAKE ID. 00005600 .NACSECT AIF ('&SYSECT' EQ '').CHECK13 NO CSECT,USE NO ID. 00005650 &NAME SETC '&SYSECT' ID NAME = NAME OF CSECT. 00005700 .AROUND ANOP 00005750 &NUMBER SETA 6+((K'&NAME+1)/2)*2 LENGTH OF BRANCH 00005800 B &NUMBER.(,15) BRANCH AROUND THE ID. 00005850 &NUMBER SETA &NUMBER 00005900 DC AL1(&NUMBER),CL&NUMBER'&NAME' DEFINE THE ID NAME . 00005950 .* 00006000 .* SET UP THE DISPLACEMENT REQUIRED FOR THE PROPER STORAGE OF 00006050 .* REGISTERS AND THE ST OR STM INSTRUCTIONS. 00006100 .* 00006150 .CHECK13 AIF (®S(1) NE 13).AGAIN 00006200 MNOTE 0,'**ERROR-REGISTER 13 WAS FIRST REGISTER OF THE PAIR**' 00006250 ®NUM SETA 14 WE SHALL USE REGISTER 14 INSTEAD. 00006300 AGO .GOON GO ON TO .GOON 00006350 .AGAIN AIF (®S(1) EQ ®NUM).GOON GO ON IF REG(1) EQUALS 14 00006400 &DISPLT SETA &DISPLT+4 DISPLACEMENT IS NOW INCREASED. 00006450 ®NUM SETA ®NUM+1 INCREASE THE REGISTER NUMBER. 00006500 AIF (®NUM NE 16).AGAIN IF WE HAVE 16 START NOW AT 0 00006550 ®NUM SETA 0 00006600 AGO .AGAIN CONTINUE FOR 0 THROUGH 12 00006650 .GOON AIF ('®S(2)' NE '').PUTSTM REG(2) NOT NULL GO PUTSTM 00006700 ST ®NUM,&DISPLT.(13) SAVE THIS REGISTER 00006750 AGO .SAVEIT GO TO SAVEIT 00006800 .PUTSTM STM ®NUM,®S(2),&DISPLT.(13) DO STORE MULTIPLE 00006850 .* 00006900 .* GET THE NAME OF THE SAVE AREA PLUS THE POINTERS TO NEW AND 00006950 .* OLD SAVE AREAS. UNIQUE NAME GENERATED IF NO SA VALUE IS 00007000 .* PRESCRIBED. 00007050 .* 00007100 .SAVEIT AIF ('&SA' EQ 'NO').BASERT NO SA VALUE IS TO BE HAD. 00007150 AIF ('&SA' EQ '*').CSECTNA SA=*,GO TO GET A SAVE AREA NAME 00007200 &SANAME SETC '&SA' SAVE AREA NAME IS DEFINED 00007250 AGO .DOLINK GO TO SET SAVE AREA POINTERS. 00007300 .CSECTNA ANOP 00007350 AIF ('&SYSECT' EQ '').NULCECT NULL CSECT 00007400 &SANAME SETC '&SYSECT'(1,3).'&SYSNDX'.'S' GENERATE SAVE AREA NAME 00007450 AGO .DOLINK 00007500 .NULCECT ANOP 00007550 &SANAME SETC 'SAV&SYSNDX' 00007600 .DOLINK AIF (&BASE GT 12).CONTIN SET THE SAVE AREA POINTERS. 00007650 &BASERG SETA &BASE WORK REGISTERS FOR SAVE AREA. 00007700 .CONTIN LA &BASERG,&SANAME GET SAVE AREA ADDRESS 00007750 ST &BASERG,8(13) POINTER TO THE NEW SAVE AREA. 00007800 ST 13,4(&BASERG) POINTER TO OLD SAVE AREA. 00007850 LR 13,&BASERG GET THE NEW SAVE AREA. 00007900 .* 00007950 .* WE NOW TAKE CARE F 00008000 .* WE NOW TAKE CARE OF THE BASE REGISTER. REGISTERS 13,14,AND 15 00008050 .* ARE INVALID BASE REGISTERS. REGISTER 12 IS DEFAULT VALUE. 00008100 .* 00008150 .BASERT AIF (&BASE GT 12).ERROR2 INVALID BASE REGISTER SPECIFIED. 00008200 AIF ('&BASE' EQ '').NEWBASE NO BASE SPECIFIED,USE 12. 00008250 &BASERG SETA &BASE 00008300 .NEWBASE BALR &BASERG,0 SET UP NEW BASE REGISTER. 00008350 USING *,&BASERG NEW USING 00008400 DROP 15 DROP THE TEMPORARY BASE REGISTER. 00008450 AGO .STOP BRANCH TO THE END. 00008500 .ERROR2 MNOTE 0,'**ERROR INVALID BASE REGISTER 12 IS USED**' 00008550 &BASERG SETA 12 SET BASE REGISTER TO 12 00008600 AGO .NEWBASE GO TO NEWBASE. 00008650 .STOP MEND END 00008700 MACRO 00008750 &LABEL QRETURN ®S,&SA 00008800 .* 00008850 .* QRETURN GENERATES STANDARD LINKAGE FOR AN EXIT FROM A CSECT. 00008900 .* 00008950 .* REGS=(CNT1,CNT2) THIS CONTAINS THE REGISTERS TO BE RESTORED. 00009000 .* THE DEFAULT VALUE WILL BE (14,12) 00009050 .* SA=VALUE -THIS CONTROLS THE SAVE AREA LINKAGE AND ITS NAME. 00009100 .* VALUE=NO NO SAVE AREA IS CREATED 00009150 .* VALUE=NAME THE NAME IS GIVEN TO THE SAVE AREA AND NORMAL 00009200 .* LINKAGE OCCURS. 00009250 .* VALUE=* A NAME IS GIVEN TO SAVE AREA AND LINKAGE OCCURS 00009300 .* 00009350 .* &SANAME -SAVE AREA NAME IF GENERATED (PASSED FROM QSAVE). 00009400 .* &DISPLT -DISPLACEMENT FOR LOAX AND LOAD MULTIPLE INSTRUCTIONS. 00009450 .* ®NUM -REGISTER NUMBER USED TO DETERMINE DISPLACEMENT. 00009500 GBLC &SANAME 00009550 LCLA &DISPLT,®NUM 00009600 .* 00009650 &DISPLT SETA 12 00009700 ®NUM SETA 14 00009750 &LABEL DS OH DEFINE THE LABEL 00009800 L 13,4(13) RESTORE OUR OLD SAVE AREA POINTER. 00009850 .* 00009900 .* CHECK FOR THE SAVE AREA. IF NONE,RESTORE REGISTER 13 AND GO 00009950 .* TO STOP 00010000 .* 00010050 AIF ('&SA' NE 'NO').CHECK 00010100 AGO .STOP 00010150 .* 00010200 .* SET THE AMOUNT OF DISPLACEMENT FOR THE LOAD OR LOAD MULTIPLE 00010250 .* INSTRUCTIONS. 00010300 .* 00010350 .CHECK AIF (®S(1) NE 13).AGAIN GO TO AGAIN IF REGS (1) NOT 13. 00010400 MNOTE 0,'**WARNING REGISTER 13 IS PART OF REGISTER PAIR**' 00010450 ®NUM SETA 14 NOW WE USE REGISTER 14. 00010500 AGO .DONE IGNORE THIS IF REGISTER 13 WAS FIRST 00010550 .AGAIN AIF (®S(1) EQ ®NUM).DONE IF REGS(1) IS 14 GO TO DONE 00010600 &DISPLT SETA &DISPLT+4 INCREMENT THE DISPLACEMENT 00010650 ®NUM SETA ®NUM+1 INCREMENT THE NUMBER REGISTER. 00010700 AIF (®NUM NE 16).AGAIN IF REGNUM NOT 16 GO TO AGAIN. 00010750 ®NUM SETA 0 SET REGNUM TO ZERO 00010800 AGO .AGAIN GO TO AGAIN. 00010850 .DONE AIF ('®S(2)' NE '').DOLM IF REGS(2) NOT ZERO,GO TO DOLM 00010900 L ®NUM,&DISPLT.(13) RESTORE THE ONE REGISTER. 00010950 AGO .SAAREA 00011000 .DOLM LM ®NUM,®S(2),&DISPLT.(13) RESTORE ALL THE REGISTERS. 00011050 .* 00011100 .* SAVE AREA WITH NAME FROM QSAVE(&SANAME).RETURN TO CALL PROGRAM 00011150 .* 00011200 .SAAREA BR 14 RETURN TO CALL 00011250 &SANAME DC 18F'0' SAVE AREA IS DEFINED. 00011300 MEXIT 00011350 .STOP BR 14 RETURN TO CALL 00011400 MEND END 00011450 MACRO 00011500 &LABEL QCALL &NAME,&LIST 00011550 .* 00011600 .* NAME=NAME OF THE ENTRY 00011650 .* LIST= NAME OF THE ADDRESS LIST. 00011700 .* 00011750 .* &NUMBER =THIS IS THE COUNTER TO COUNT NUMBER PARAMETERS IN LIS 00011800 .* &LASTNUM =THIS IS NUMBER OF LAST NUMBER IN LIST. 00011850 .* &IDENTY =THIS IS THE UNIQUE NAME 00011900 .* 00011950 LCLA &NUMBER,&LASTNUM 00012000 LCLC &IDENTY 00012050 &NUMBER SETA 1 SET NUMBER TO 1. 00012100 &LASTNUM SETA ('&LIST 00012150 &LABEL DS OH DEFINE THE LABEL. 00012200 .* 00012250 .* THIS TAKES CARE OF PART2 OR JUST AN ENTRY NAME. 00012300 .* 00012350 AIF ('&LIST' EQ '').AR1 THIS CHECKS FOR THE NULL LIST. 00012400 .* 00012450 .* THIS TAKES CARE OF PART3 OR AN ENTRY NAME AND ADDRESS LIST 00012500 .* NAME. 00012550 .* 00012600 AIF ('&LIST'(1,1) NE '(').AR2 THIS IS FOR NO PARAMETERS. 00012650 .* 00012700 .* THIS TAKES CARE OF PART 1 AND 4. THIS IS AN ENTRY NAME AND AN 00012750 .* ARGUMENT LIST. 00012800 .* 00012850 CNOP 0,4 SET ON A FULL WORD BOUNDARY9 00012900 B *+&LASTNUM*4+4 DO A BRANCH AROUND THE LIST 00012950 &IDENTY SETC 'PARM&SYSNDX' THIS GIVES US THE UNIQUE NAME. 00013000 .AGAIN AIF (&LASTNUM EQ &NUMBER).LASTP 00013050 AIF (&NUMBER EQ 1).FIRSTP CHECK FOR FIRST PARAMETER 00013100 .FIRSTP ANOP 00013150 &IDENTY DC A(&LIST(&NUMBER)) NOT THE LAST PARAMETER. 00013200 &IDENTY SETC '' SET THE IDENTY TO ONE. 00013250 &NUMBER SETA &NUMBER+1 INCREASE NUMBER BY 1. 00013300 AGO .AGAIN GO TO AGAIN 00013350 .LASTP ANOP 00013400 &IDENTY DC X'80',AL3 (&LIST(&NUMBER)) THIS DOES THE LAST PARAMER. 00013450 .* 00013500 .* THIS DOES PART IS ARGUMENT LIST 00013550 .* 00013600 AIF ('&NAME' EQ '').STOP 00013650 .* 00013700 .* THIS DOES PART 4 ENTRY NAME AND ARGUMENT LIST. 00013750 .* 00013800 LA 1,&IDENTY THIS GETS YOU THE PARAMETER LIST ADD 00013850 AGO .AR2 GO GET THE ENTRY NAME. 00013900 .AR1 LA 1,&LIST GET THE PARAMETER LIST ADDRESS. 00013950 .AR2 AIF ('&NAME' EQ '').ERROR1 THIS CHECKS FOR THE NAME. 00014000 L 15,=V(&NAME) GET ENTRY POINT ADDRESS WITH V ADCON 00014050 BALR 14,15 BRANCH TO THE SUBPROGRAM. 00014100 AGO .STOP BRANCH TO STOP 00014150 .ERROR1 MNOTE 0,'**THERE IS NO ENTRY POINT ADDRESS**' 00014200 .STOP MEND THIS IS THE END. 00014250 MAINPRG CSECT 00014300 QSAVE 00014350 QCALL SUBX,ADDRX 00014400 QCALL SUBY 00014450 GOBACK QRETURN SA=* 00014500 ADDRX QCALL ,(MAINPRG,BOBACK) 00014550 LTORG 00014600 SUBXCS CSECT 00014650 ENTRY SUBX,SUBY 00014700 SUBX QSAVE SA=SUBXSA,BASE=11,REGS=(14,11) 00014750 CNOP 2,4 00014800 QCALL SUB1,(SUBX) 00014850 QCALL SUB2 00014900 SUBRET QRETURN SA=SUBXSA,REGS=(14,11) 00014950 SUBY QSAVE SA=NO 00015000 XPRNT =CL50'0************ AT SUBY ************',50 00015050 QRETURN SA=NO 00015100 LTORG 00015150 SUB1 CSECT 00015200 QSAVE BASE=13 00015250 QRETURN SA=* 00015300 SUB2 CSECT 00015350 QSAVE BASE=15,REGS=(2,12) 00015400 QRETURN SA=*,REGS=(2,12) 00015450 END 00015500 $JOB ASSIST MACRO=F 00015550 MACRO 00015600 SETGBL &TRACE=,&LSNAP=,&STSNAP= 00015650 GBLB &NOTRC,&NOLSNAP,&NOSNAP GLOBALS FOR DEBUG, LISTSNAP, 00015700 .* AND STSNAP 00015750 &NOTRC SETB (T'&TRACE EQ 'O' AND &NOTRC OR '&TRACE' EQ 'OFF') 00015800 &NOLSNAP SETB (T'&LSNAP EQ 'O' AND &NOLSNAP OR 'LSNAP' EQ 'OFF') 00015850 &NOSNAP SETB (T'&STSNAP EQ 'O' AND &NOSNAP OR '&STSNAP' EQ 'OFF') 00015900 MEND 00015950 EJECT 00016000 MACRO 00016050 &LABEL POP &HDR,®,&END,&LENGTH=48,&MSG= 00016100 &LABEL L ®,&HDR . GET ADDRESS TOP ELEMENT 00016150 AIF (T'&END EQ 'O').NOTEST SEE IF SHOULD DO EMPTY TEST 00016200 LTR ®,® . TEST FOR NULL LINK 00016250 BZ &END . IF EMPTY LIST, BRANCH OUT 00016300 .NOTEST ANOP 00016350 STM 0,1,POP&SYSNDX.S . SAVE REGS THAT ARE CHANGED 00016400 L 0,0(®) . GET SECOND TO TOP NODE 00016450 ST 0,&HDR . POINT HEAD TO 2ND NODE 00016500 LA 1,&HDR . GET ADDRESS OF HEADER 00016550 L 0,4(1) . GET CURRENT LIST LENGTH 00016600 BCTR 0,0 . DECREMENT LENGTH BY 1 00016650 ST 0,4(1) . STORE UPDATED LENGTH 00016700 LM 0,1,POP&SYSNDX.S . RESTORE REGISTERS 00016750 B POP&SYSNDX.S+8 . BRANCH AROUND SAVE AREA 00016800 POP&SYSNDX.S DC 2F'0' . SAVE AREA FOR REGS 0 AND 1 00016850 DEBUG POP,&HDR,&MSG,4(®),&LENGTH 00016900 MEND 00016950 SPACE 3 00017000 MACRO 00017050 &LABEL PUTFREE &FRHDR,® 00017100 &LABEL MVC 0(4,®),&FRHDR . RETURNED NODE ==> FREE LIST 00017150 ST ®,&FRHDR . FREE LIST HEAD ==> RETURNED NODE 00017200 SPACE 1 00017250 MEND 00017300 EJECT 00017350 MACRO 00017400 &LABEL DELETE &HDR,®,&END,&LENGTH=48,&MSG= 00017450 &LABEL STM 14,1,DEL&SYSNDX.S . SAVE REGS THAT ATE CHANGED 00017500 LR 0,® . LOAD @ OF NODE TO BE DELETED 00017550 LA 1,&HDR . LOAD ADDRESS OF LIST HEAD 00017600 L 15,=V(DELETE) . LOAD ADDR NODE DELETION ROUTINE 00017650 CNOP 2,4 . FOR ALIGNMENT OF SAVE AREA 00017700 BALR 14,15 . LINK TO DELETION ROUTINE 00017750 LM 14,1,8(14) . RELOAD REGISTERS 00017800 B &END . NODE NOT IN LIST, BRANCH OUT 00017850 DEL&SYSNDX.S DC 4F'0' . SAVE AREA FOR REGS 14-1 00017900 LM 14,1,8(14) . RELOAD REGISTERS FOR NORMAL RETURN 00017950 DEBUG DELETION,&HDR,&MSG,4(®),&LENGTH 00018000 SPACE 1 00018050 MEND 00018100 SPACE 2 00018150 MACRO 00018200 SYSGEN &CPU=1,&MEM=64,&IONO=1,&DISKQ=10,&CATNO=1,&JQLOOK=NO 00018250 GBLA &CPN,&MMS,&ION # CPU'S, MEM SIZE, # CHANNELS 00018300 GBLA &DQN,&CAT SIZE OF DISK QUEUE, # CATEGORY Q'S 00018350 GBLB &LOOK TRUE IF INITIATOR MAY LOOK AHEAD 00018400 &CPN SETA &CPU 00018450 &MMS SETA &MEM 00018500 &ION SETA &IONO 00018550 &DQN SETA &DISKQ 00018600 &CAT SETA &CATNO 00018650 &LOOK SETB ('&JQLOOK' EQ 'YES') 00018700 MEND 00018750 SPACE 2 00018800 MACRO 00018850 &LABEL PUTNODE &HDR,®,&KEY=4,&KEYLEN=2,&LENGTH=48,&MSG=,&WORK=15 00018900 AIF (&KEYLEN EQ 0).SHORT TEST IF SIMPLE INSERT OR ORDERED 00018950 &LABEL STM 14,1,PUT&SYSNDX.S . STORE REGS THAT ARE CHANGED 00019000 LR 0,® . LOAD ADDR OF NODE TO BE ADDED 00019050 LA 1,&HDR . LOAD ADDRESS OF LIST HEAD 00019100 L 15,=V(PUTNODE) . LOAD @ NODE INSERTION ROUTINE 00019150 CNOP 2,4 . FOR FULLWORD ALIGNMENT OF SAVE AREA 00019200 BALR 14,15 . LINK TO NODE INSERTION ROUTINE 00019250 PUT&SYSNDX.S DC 4F'0' . SAVE AREA FOR REGS 14-1 00019300 CLC &KEY.(&KEYLEN,2),&KEY.(1) . CLC FOR PUTNODE 00019350 LM 14,1,0(14) . RESTORE REGISTERS 00019400 AGO .END BRANCH AROUND SIMPLE INSERT 00019450 .SHORT ANOP 00019500 &LABEL ST ZERO,0(®) . ZERO LINK TO OTHER JOBS 00019550 ST ZERO,0(®) . ZERO LINK TO OTHER JOBS 00019600 LA &WORK,&HDR . GET ADDRESS OF HEADER 00019650 MVI 7(&WORK),X'01' . INDICATE PROCESSOR BEING USED 00019700 .END DEBUG ADDITION,&HDR,&MSG,4(®),&LENGTH 00019750 MEND 00019800 EJECT 00019850 MACRO 00019900 &LABEL GETFREE &FRHDR,®,&END 00019950 &LABEL L ®,&FRHDR . GET TOP ELEMENT OFF FREE LIST 00020000 LTR ®,® . TEST FOR EMPTY LIST 00020050 BZ &END . NO FREE NODES; TAKE ALTERNATE EXIT 00020100 MVC &FRHDR.(4),0(®) . MOVE STACK POINTER DOWN 00020150 SPACE 1 00020200 MEND 00020250 EJECT 00020300 MACRO 00020350 DEBUG &PREFIX,&HDR,&MSG,&LOC,&LEN 00020400 GBLB &NOTRC FALSE IF TRACE IS ON 00020450 LCLA &LN 00020500 LCLC &NAME EITHER &MSG OR &HDR 00020550 AIF (&NOTRC).END TEST FOR TRACE OFF 00020600 AIF ('&MSG' EQ '').HDRMSG USE &HDR IF &MSG OMITTED 00020650 &NAME SETC '&MSG'(2,K'&MSG-2) STRIP QUOTES OFF &MSG 00020700 &LN SETA K'&MSG-2 00020750 AGO .GENTR 00020800 .HDRMSG ANOP 00020850 &NAME SETC '&HDR' PUT &HDR INTO &NAME 00020900 &LN SETA K'&HDR 00020950 .GENTR XPRNT =C'0NODE &PREFIX AT &NAME',18+&LN 00021000 XDUMP &LOC,&LEN 00021050 .END MEND 00021100 SPACE 2 00021150 MACRO 00021200 CRLISTS &PREFIX,&NUM 00021250 LCLA &COUNT 00021300 LCLA &SUM # EVENT QUEUE ELEMENTS 00021350 .MORE ANOP 00021400 &COUNT SETA &COUNT+1 00021450 &PREFIX&COUNT DC 4F'0'. LIST HEADER 00021500 AIF (&COUNT LT &NUM).MORE 00021550 MEND 00021600 EJECT 00021650 MACRO 00021700 LISTS 00021750 GBLA &MMS,&DQN,&CAT,&ION,&CPN DECLARE GLOBALS 00021800 .* GENERATE LIST HEADERS 00021850 EVQ DC 4F'0' EVENT QUEUE HEADER 00021900 RJQ DC 4F'0' READY JOB QUEUE HEADER 00021950 CRLISTS DQ,&CAT LIST HEADERS FOR CATEGORY QUEUES 00022000 CRLISTS IOQ,&ION LIST HEADERS FOR CHANNEL WAIT QUEUES 00022050 CRLISTS CHAN,&ION LIST HEADERS FOR CHANNEL USE QUEUES 00022100 CRLISTS CPU,&CPN LIST HEADERS FOR CPU USING QUEUES 00022150 EVQFR DC A(FR1) 00022200 JQEFR DC A(FR2) 00022250 MMS DC F'&MMS' . MEMORY SIZE 00022300 HEADERS DC AL4(2+&CPN+&ION+&ION+&CAT) . NUMBER OF HEADERS 00022350 CAT DC F'&CAT' . NUMBER OF CATEGORIES 00022400 ION DC F'&ION' . NUMBER OF I/O CHANNELS 00022450 MEMTABLE DC &MMS.CL12' U' MEMORY TABLE 00022500 HOLES DC &MMS.F'0' . TABLE OF HOLES IN MEMORY 00022550 &SUM SETA &CPN+&ION+4 GET SIZE OF EVENT QUEUE 00022600 FR1 FREEAREA &SUM,2 AREA FOR EVENT QUEUE 00022650 FR2 FREEAREA &DQN,12 AREA FOR JQE'S 00022700 MEND 00022750 SPACE 3 00022800 MACRO 00022850 &LABEL FREEAREA &NUM,&DATA 00022900 LCLA &I LOCAL COUNTER 00022950 &LABEL DS 0F . DEFINE FREE LIST 00023000 &I SETA &NUM GET NUMBER OF NODES TO GENERATE 00023050 .NEXT AIF (&I LE 1).LAST SEE IF AT END YET 00023100 DC A(*+4*(&DATA+1)),&DATA.F'0' 00023150 &I SETA &I-1 DECREMENT COUNTER 00023200 AGO .NEXT GO DO NEXT NODE 00023250 .LAST DC A(0),&DATA.F'0' 00023300 SPACE 1 00023350 MEND 00023400 EJECT 00023450 MACRO 00023500 &LABEL QRETURN ®S=(14,9),&SA=* 00023550 GBLC &SANAME SAVE AREA GENERATED BY QSAVE 00023600 &LABEL DS 0H . DEFINE LABEL 00023650 AIF ('&SA' EQ 'NO').LM NO SAVE AREA NO R13 RESTORE 00023700 L 13,4(13) . GET POINTER TO BACK SAVE AREA 00023750 .LM AIF (®S(1) GE 14).R1415 DIFF. CODE IF RESTORE 14-15 00023800 LM ®S(1),®S(2),(®S(1)+5)*4(13) . RESTORE REGS 00023850 AGO .BR14 GENERATE BRANCH BACK 00023900 .R1415 LM ®S(1),®S(2),(®S(1)-11)*4(13) RESTORE REGS 00023950 .BR14 BR 14 . RETURN TO CALLING ROUTINE 00024000 AIF ('&SA' EQ '').END NO SAVE AREA, THEN DONE 00024050 AIF ('&SA' EQ 'NO').END 00024100 AIF ('&SA' NE '*').SA SA=* ==> USE GENERATED NAME 00024150 &SANAME DC 18F'0' . SAVE AREA, USING GENERATED NAME 00024200 AGO .END 00024250 .SA ANOP 00024300 &SA DC 18F'0' . GENERATE SAVE AREA 00024350 .END SPACE 1 00024400 MEND 00024450 EJECT 00024500 MACRO 00024550 &LABEL IDENT &NAME 00024600 LCLA &LIDENT LENGTH OF LABEL OR NAME 00024650 AIF ('&LABEL' EQ '').SYSECT IF LABEL OMITTED, USE CSECT NAME 00024700 &LIDENT SETA K'&LABEL/2*2+1 MAKE LENGTH OF LABEL ODD 00024750 &LABEL B *+5+&LIDENT . BRANCH AROUND IDENTIFIER 00024800 DC X'&LIDENT',CL&LIDENT'&LABEL' . ENTRY NAME 00024850 MEXIT 00024900 .SYSECT ANOP 00024950 &LIDENT SETA K'&NAME/2*2+1 MAKE CSECT NAME LENGTH ODD 00025000 B *+5+&LIDENT . BRANCH AROUND IDENTIFIER 00000050 DC X'&LIDENT',CL&LIDENT'&NAME' . ENTRY NAME 00000100 MEND 00000150 EJECT 00000200 MACRO 00000250 &LABEL QSAVE ®S=(14,9),&BASE=9,&SA=* 00000300 GBLC &SANAME NAME OF GENERATED SAVE AREA 00000350 LCLA &BR BASE REGISTER TO BE USED 00000400 AIF (&BASE GE 13).BERROR BASE REG CANNOT BE > 12 00000450 &BR SETA &BASE USE &BASE AS BASE REGISTER 00000500 AGO .U15 BRANCH AROUND BASE REG ERROR RESET 00000550 MNOTE *,'NOT UNLESS AN ERROR IN ASSIST' 00000600 .BERROR MNOTE *,'&BASE IS ILLEGAL BASE REGISTER. VALUE CHANGED TO 12.' 00000650 &BR SETA 12 USE 12 AS BASE REGISTER 00000700 .U15 USING *,15 . FOR TEMPORARY ADDRESSIBILITY 00000750 &LABEL IDENT &SYSECT GENERATE IDENTIFIER 00000800 AIF (®S(1) GE 14).R1415 IF SAVE REGS 14-15, DIFF. CODE 00000850 STM ®S(1),®S(2),(®S(1)+5)*4(13) . SAVE REGS 00000900 AGO .SAVEA 00000950 .R1415 STM ®S(1),®S(2),(®S(1)-11)*4(13) SAVE REGS 00001000 .SAVEA AIF ('&SA' EQ 'NO').BASEREG NO SAVE AREA, DO BASE REG 00001050 AIF ('&SA' EQ '*').GENSA GENERATE NAME IF SA=* 00001100 &SANAME SETC '&SA' USE NAME PROVIDED 00001150 AGO .R13FIX 00001200 .GENSA ANOP 00001250 &SANAME SETC '&SYSECT'(1,3).'&SYSNDX.S' GENERATE SAVE AREA NAME 00001300 .R13FIX LR &BR,13 . SAVE OLD POINTER 00001350 LA 13,&SANAME . GET ADDRESS NEW AREA 00001400 ST 13,8(&BR) . PUT NEW POINTER IN OLD AREA 00001450 ST &BR,4(13) . STORE POINTER TO OLD SAVE AREA 00001500 .BASEREG BALR &BR,0 . LOAD BASE REGISTER 00001550 USING *,&BR . DECLARE BASE REGISTER 00001600 DROP 15 . END TEMPORARY ADDRESSIBILITY 00001650 SPACE 1 00001700 MEND 00001750 EJECT 00001800 MACRO 00001850 &LABEL QCALL &ENTRY,&ARG 00001900 LCLA &CTR COUNTER FOR ARG LIST GENERATION 00001950 LCLA &ARGLEN # OF ITEMS IN ARGUMENT LIST 00002000 AIF ('&ENTRY' EQ '').LABELF NO ENTRY PT. PUT LABEL ON DS F 00002050 &LABEL DS 0H . DEFINE LABEL 00002100 AIF ('&ARG' EQ '').L15 NO ARG LIST, GENERATE L AND BALR 00002150 AIF ('&ARG'(1,1) NE '(').LA1 GET ARG LIST @ IN REG 1 00002200 CNOP 0,4 . ALIGN ARGUMENT LIST ON FULLWORD 00002250 &ARGLEN SETA N'&ARG GET NUMBER OF ARGUMENTS 00002300 BAL 1,*+4+4*&ARGLEN . LOAD ARG LIST @ AND BRANCH OVER 00002350 AGO .ARGLIST GO GENERATE ARGUMENT LIST 00002400 .LABELF ANOP 00002450 &LABEL DS 0F . ALIGN ARGUMENT LIST TO FULLWORD 00002500 .ARGLIST ANOP 00002550 &CTR SETA 1 INITIALIZE COUNTER 00002600 .TEST AIF (&CTR GE N'&ARG).LAST TEST FOR LAST ARGUMENT 00002650 DC A(&ARG(&CTR)) . ARGUMENT FOR CALLED PROGRAM 00002700 &CTR SETA &CTR+1 INCREMENT COUNTER 00002750 AGO .TEST TEST FOR LAST ARGUMENT 00002800 .LAST DC X'80',AL3(&ARG(&CTR)) .LAST ARG; VL FLAG SET TO 1 00002850 AIF ('&ENTRY' EQ '').END DONE IF NO ENTRY POINT 00002900 AGO .L15 GENERATE CODE TO L AND BALR 00002950 .LA1 LA 1,&ARG . LOAD ADDRESS OF REMOTE ARGUMENT LIST 00003000 .L15 L 15,=V(&ENTRY) . GET ADDRESS OF ENTRY POINT 00003050 BALR 14,15 . LINK TO CALLED ROUTINE 00003100 .END SPACE 1 00003150 MEND 00003200 PRINT ON 00003250 EJECT 00003300 SYSGEN CATNO=2 00003350 PROCJCL CSECT 00003400 ENTRY PUTNODE,DELETE,EVQINIT,ARRIVE 00003450 DS 55CL80 00003500 ORG PROCJCL+X'7C0' 00003550 PUTNODE DS 0H 00003600 ORG PROCJCL+X'802' 00003650 DELETE DS 0H 00003700 ORG PROCJCL+X'870' 00003750 EVQINIT DS 0H 00003800 ORG PROCJCL+X'A88' 00003850 ARRIVE DS 0H 00003900 ORG 00003950 LOADER CSECT 00004000 QSAVE REGS=(14,2),BASE=2 00004050 LA 0,55 00004100 L 1,=A(PROCJCL) 00004150 LOADREAD XREAD 0(1),72 00004200 LA 1,72(1) 00004250 BCT 0,LOADREAD 00004300 QCALL MAIN 00004350 QRETURN 00004400 LTORG 00004450 TITLE 'GLOBAL CSECT' 00004500 GCSECT CSECT 00004550 USING GCSECT,12 FOR ADDRESSIBILITY OF GBL TABLE 00004600 ZERO EQU 10 WILL CONTAIN ZERO AT EXECUTION TIME 00004650 SYSTIME EQU 11 SYSTEM CLOCK 00004700 COMLINE DC C'- COMMENT: ' 00004750 COMCARD DS CL80 SPACE FOR COMMENT CARD 00004800 CARDLINE DC CL12' ' LINE TO PRINT CARD IMAGE 00004850 CARD DC 80C' ',C' #' SPACE FOR CARD AND BYTES TO STOP TRT 00004900 ERRLINE DC CL12' ',82C'-',3C' ' ONE - IS CHANGED TO $ TO POINT 00004950 * TO ERROR IN CARD IMAGE 00005000 ERRMSG DS CL33 SPACE FOR ERROR MESSAGE 00005050 BATCHTBL DS 0F KEYWORD DESCRIPTOR TBL FOR $B CARDS 00005100 DC CL3'CPP',B'00000001',X'03',AL3(CPP),X'02',AL3(CPPST) 00005150 DC CL3'CPS',B'00000101',X'03',AL3(CPS),X'03',AL3(CPSST) 00005200 DC CL3'INP',B'00000101',X'02',AL3(INP),X'01',AL3(INPST) 00005250 DC CL3'INS',B'00000001',X'01',AL3(INS),X'02',AL3(INSST) 00005300 DC CL3'IOS',B'00000101',X'03',AL3(IOS),X'03',AL3(IOSST) 00005350 DC CL3'JAR',B'00001000',X'00',AL3(JAR),X'00',AL3(0) 00005400 DC CL3'MMA',B'00000001',X'03',AL3(MMA),X'03',AL3(MMAST) 00005450 DC CL3'MMJ',B'00000100',X'00',AL3(MMJ),X'00',AL3(0) 00005500 DC CL3'RPS',B'00000100',X'00',AL3(RPS),X'00',AL3(0) 00005550 DC CL3'XXX',B'00000010',X'00',AL3(XXX),X'00',AL3(0) 00005600 BATCHOP DS 0F SPACE FOR OPERANDS FROM $B CARDS 00005650 CPP DC 2F'0' 00005700 CPS DC 2F'0' 00005750 INP DC 2F'0' 00005800 INS DC 2F'0' 00005850 IOS DC 2F'0' 00005900 JAR DC F'0' 00005950 MMA DC 2F'0' 00006000 MMJ DC F'0' 00006050 RPS DC F'0' 00006100 XXX DC F'0' 00006150 BTCHDFLT DC F'0,2,1,0,1,0,0,1,1' $BATCH CARD DEFAULTS 00006200 DC F'0,0,0,1,15,999999999,0' 00006250 CPPST DC C'YES',X'00' STRING TABLES FOR $B CARDS 00006300 DC C'NO ',X'00' 00006350 CPSST DC C'IBC',X'01' 00006400 DC C'CBC',X'01' 00006450 DC C'C ',X'00' 00006500 INPST DC C'MS',X'00' 00006550 INSST DC C'C',X'00' 00006600 DC C'R',X'00' 00006650 IOSST EQU CPSST 00006700 MMAST DC C'CNF',X'00' 00006750 DC C'CNB',X'00' 00006800 DC C'S ',X'00' 00006850 SPACE 2 00006900 JOBTBL DS 0F KEYWORD DESCRIPTOR TBL FOR $J CARDS 00006950 DC CL3'CHI',B'00000100',A(JCHI),A(0) 00007000 DC CL3'CHL',B'00001000',A(JCHL),A(0) 00007050 DC CL3'CHN',B'00000100',A(JCHAN),A(0) 00007100 DC CL3'CTN',B'00000100',A(JCAT),A(0) 00007150 DC CL3'MEM',B'00000100',A(JMEM),A(0) 00007200 DC CL3'PRI',B'00000100',A(JPRI),A(0) 00007250 DC CL3'TIM',B'00000100',A(JTIME),A(0) 00007300 JOBOP DS 0F SPACE FOR OPERANDS FROM $J CARDS 00007350 JTIME DC F'1' 00007400 JMEM DC F'1' 00007450 JPRI DC F'999999999' 00007500 JCAT DC F'1' 00007550 JCHAN DC F'1' 00007600 JCHI DC F'999999999' 00007650 JCHL DC F'0' 00007700 JOBDFLT DC F'1,1,999999999,2,4,999999999,0' $JOB CARD DEFAULTS 00007750 COLUMN DS F COLUMN TO BEGIN PROCESSING CARD 00007800 DBLWRK DS D DOUBLE WORD FOR CVD'S 00007850 FORTIME DS F SYSTIME TIME FOR FORTRAN REPORTS 00007900 FORTURN DS F TURNAROUND TIME FOR FORTRAN REPORTS 00007950 FMEMRES DS F MEMORY RESIDENCE TIME FOR REPORTS 00008000 FORTJOB DS H JOB NUMBER FOR FORTRAN REPORTS 00008050 OVERLAP DS F TOTAL AMOUNT OF TIME A CPU AND CHAN 00008100 * WERE BUSY AT THE SAME TIME 00008150 AVJOBMEM DS F (AVERAGE # OF JOBS IN MEM)*(CURRENT 00008200 * SYSTEM TIME) 00008250 JOBFLOW DS F SUM OF TURNAROUND TIMES FOR ALL JOBS 00008300 * TERMINATED TO DATE 00008350 BADJOB DS F NUMBER OF BAD JOBS IN THIS BATCH 00008400 JQEUSED DS F'0' NUMBER OF JQE'S BEING USED 00008450 JOBIM DC F'0' # OF JOBS CURRENTLY IN MEMORY 00008500 JOB# DC H'0' NUMBER OF THE LAST JOB READ 00008550 BATCH# DC PL2'0' BATCH # 00008600 STAT# DS PL2 STATUS REPORT NUMBER 00008650 EDWRK DS CL11 WORK AREA FOR EDITS 00008700 EQOUTHEX DC C'0123456789ABCDEF' HEX OUTPUT TR TABLE 00008750 HEXTBL EQU EQOUTHEX-240 TO ADDRESS HEX TABLE 00008800 EOF DC X'00' SET TO 01 WHEN END OF FILE IS FOUND 00008850 INHIBIT DC C'F' SET TO T IF ALL JQE'S ARE BEING USED 00008900 JOBLAST DC C'F' SET TO T WHEN LAST JOB IN BATCH FOUND 00008950 CATL DC X'01' CATEGORY LAST INITIATED FROM 00009000 JOBARG QCALL ,(JOBTBL,L7) ARGUMENT LIST TO CALL PROCJCL FOR $J 00009050 L7 DC F'7' LENGTH OF JOB TABLE 00009100 BATCHARG QCALL ,(BATCHTBL,L10) ARGS TO CALL PROCJCL FOR $BATCH 00009150 L10 DC F'10' LENGTH OF $B ARG TABLE 00009200 LISTS 00009250 TITLE 'DSECTS' 00009300 LISTHEAD DSECT FORMAT OF 4 WORD LIST HEADER 00009350 TOP DS A POINTER TO TOP NODE 00009400 LLEN DS F CURRENT NUMBER OF NODES IN LIST 00009450 MAXLEN DS F MAX LENGTH LIST HAS EVER HAD 00009500 AVGLEN DS F AVERAGE Q LENGTH * TOTAL TIME 00009550 SPACE 2 00009600 EVQEL DSECT FORMAT EVENT QUEUE NODE 00009650 DS F LINK TO NEXT EVENT 00009700 EVTIME DS F TIME OF EVENT 00009750 EV# DS H EVENT NUMBER 00009800 EVFLAG DS H EVENT FLAGS 00009850 SPACE 2 00009900 JQEL DSECT FORMAT JOB QUEUE ELEMENT 00009950 DS F LINK TO NEXT JQE 00010000 JOBID DS H JOB IDENTIFICATION NUMBER 00010050 CHAN DS H CHANNEL JOB WILL USE 00010100 TIME DS F CPU TIME REQUESTED, IN MILLISECONDS 00010150 TIMREM DS F CPU TIME REMAINING UNTIL TERMINATION 00010200 CPUPRI DS H PRIORITY FOR USING THE CPU 00010250 IOPRI DS H PRIORITY FOR USING A CHANNEL 00010300 CHI DS F INTERVAL BETWEEN CHANNEL INTERRUPTS 00010350 COMPCHI DS F TIME UNTIL NEXT CHANNEL INTERRUPT 00010400 CHL DS F LENGTH OF EACH CHANNEL USAGE 00010450 INDQ DS F TIME ENTERED SYSTEM 00010500 CPS#IO DS H # I/O REQUESTS IN LAST CPS INTERVAL 00010550 IOS#IO DS H # I/O REQUESTS IN LAST IOS INTERVAL 00010600 MEMPTR DS 0F POINTER TO THE FIRST MEMORY BLOCK 00010650 MEM DS H # OF MEMORY BLOCKS REQUESTED 00010700 INITPRI DS H INITIATION PRIORITY 00010750 EVPTR DS F POINTER TO NEXT EVENT FOR THIS JOB 00010800 INITIME DS F TIME INITIATED 00010850 TITLE 'MAIN ROUTINE' 00010900 MAIN CSECT 00010950 QSAVE REGS=(14,12) 00011000 SR ZERO,ZERO PUT 0 IN ZERO 00011050 L 12,=V(GCSECT) GET ADDR OF GLOBAL TABLE 00011100 USING GCSECT,12 00011150 XPRNT =CL30'1 OS/411 JAMES WYLLIE',30 00011200 XPRNT =C'1',1 SKIP TO A NEW PAGE 00011250 MREAD XREAD CARD,80 READ NEXT CARD 00011300 BM MAINRET DONE IF ENDFILE 00011350 B MBATCH BRANCH AROUND END FILE TEST 00011400 MAINM2 CLI EOF,X'01' TEST FOR END OF FILE 00011450 BE MAINRET IF END OF FILE; THEN DONE 00011500 MBATCH CLC CARD(2),=C'$B' TEST FOR $BATCH CARD 00011550 BE MEVALB GO CALL PROCJCL IF $B CARD 00011600 CLC CARD(2),=C'$C' TEST FOR COMMENT CARD 00011650 BNE MERROR ERROR IF NOT $C OR $B 00011700 SPACE 1 00011750 MVC COMCARD,CARD MOVE COMMENT TO COMMENT PRINT AREA 00011800 XPRNT COMLINE,92 PRINT FIRST COMMENT 00011850 MVI CARDLINE,C' ' MOVE BLANK TO CARRIAGE CONTROL 00011900 MCOMREAD XREAD CARD,80 READ NEXT CARD 00011950 BM MAINRET DONE IF END FILE 00012000 CLI CARD,C'$' TEST FOR CONTROL CARD 00012050 BE MBATCH TEST IF CONTROL CARD IS $B 00012100 XPRNT CARDLINE,92 PRINT COMMENT CONTINUATION 00012150 B MCOMREAD GO READ NEXT CARD 00012200 SPACE 1 00012250 MERROR XPRNT =C'-EXPECTING $B OR $C CARD. THE FOLLOWING CARD WAS FOUX00012300 ND:',56 PRINT ERROR MESSAGE 00012350 XPRNT CARD-1,81 PRINT BAD CARD 00012400 B MREAD GO READ NEXT CARD 00012450 SPACE 1 00012500 MEVALB MVC COLUMN,=F'7' SET START COLUMN FOR PROCJCL 00012550 MVC BATCHOP(64),BTCHDFLT SET $B DEFAULTS 00012600 QCALL PROCJCL,BATCHARG CALL PROCJCL FOR $B CARDS 00012650 B *+8 IF GOOD, BRANCH AROuND BAD CARD BR 00012700 B MAINM2 BAD $BATCH CARD, GO CHECK EOF 00012750 QCALL BEGINB PRINT BEGINNING OF BATCH REPORT 00012800 SPACE 1 00012850 MJTYPE CLC CARD(2),=C'$J' TEST FOR JOB CARD IN BUFFER 00012900 BE MEVALJ IF $J, GO CALL PROCJCL FOR $J 00012950 CLC CARD(2),=C'$C' TEST IF COMMENT CARD IN BUFFER 00013000 BE MJCOMM DUMP COMMENTS IF FOUND 00013050 CLC CARD(2),=C'$B' TEST FOR $B IN BUFFER 00013100 BE EMPTYB EMPTY BATCH IF NO $J CARDS 00013150 XPRNT =C'-EXPECTING $J, $B, OR $C CARD. THE FOLLOWING CARD WAX00013200 S FOUND:',61 00013250 XPRNT CARD-1,81 PRINT BAD CARD 00013300 XREAD CARD,80 READ NEXT CARD 00013350 BNM MJTYPE NOT EOF; FIND TYPE OF CARD 00013400 MEOF MVI EOF,X'01' TURN ON ENDFILE FLAG 00013450 B EMPTYB PRINT EMPTY BATCH MESSAGE 00013500 SPACE 1 00013550 MJCOMM MVC COMCARD,CARD MOVE COMMENTS TO COMMENT PRINT AREA 00013600 XPRNT COMLINE,92 PRINT FIRST COMMENT 00013650 MVI CARDLINE,C' ' MOVE BLANK CARRIAGE CONTROL IN 00013700 MJCOMRD XREAD CARD,80 READ NEXT CARD 00013750 BM MEOF GO SET EOF FLAG AND PRINT EMPTY BATCH 00013800 CLI CARD,C'$' TEST FOR CONTROL CARD 00013850 BE MJTYPE FIND TYPE OF CONTROL CARD 00013900 XPRNT CARDLINE,92 PRINT COMMENT CONTINUATION 00013950 B MJCOMRD GO READ NEXT CARD 00014000 SPACE 1 00014050 MEVALJ MVC COLUMN,=F'5' SET START COLUMN FOR PROCJCL 00014100 MVC JOBOP(28),JOBDFLT SET $J DEFAULTS 00014150 QCALL PROCJCL,JOBARG CALL PROCJCL TO EVALUATE $J CARD 00014200 B MMTEST GOOD $J; CHECK MEM NOT > &MMS 00014250 MBADJOB L 3,BADJOB ADD ONE TO COUNT OF BAD JOBS IN BATCH 00014300 LA 3,1(3) 00014350 ST 3,BADJOB 00014400 CLI EOF,X'01' CHECK FOR ENDFILE 00014450 BNE MJTYPE IF NOT EOF, THEN TEST FOR A JOB CARD 00014500 SPACE 1 00014550 EMPTYB XPRNT =C'-THERE WERE NO VALID $JOB CARDS IN THE PRECEDING BATCX00014600 H. NO SIMULATIONS WERE DONE.',82 PRINT EMPTY BATCH MSG 00014650 B MAINM2 GO TEST FOR END OF FILE 00014700 SPACE 2 00014750 MMTEST CLC JMEM,MMS TEST FOR MEMORY REQUEST TOO HIGH 00014800 BNH MAINM1 IF WITHIN RANGE, GO DO SIMULATION 00014850 XPRNT =C'-A JOB REQUESTED TOO MUCH MEMORY. IGNORED.',43 00014900 B MBADJOB GO INC COUNT OF BAD JOBS 00014950 MAINM1 SR SYSTIME,SYSTIME SET SYSTEM TIME TO ZERO 00015000 MVI INHIBIT,C'F' NOT ALL JQE'S IN USE 00015050 MVI JOBLAST,C'F' NOT LAST JOB IN BATCH 00015100 STH ZERO,JOB# SET JOB NUMBER TO 0 00015150 * ZERO MAXIMUM LENGTH AND AVERAGE LENGTH FIELDS OF QUEUE HEADERS 00015200 L 5,HEADERS GET NUMBER OF HEADERS TO BLANK 00015250 LA 4,EVQ GET START ADDRESS OF HEADERS 00015300 MHEADBL STM ZERO,SYSTIME,8(4) ZERO MAX AND AVG LENGTH FIELDS 00015350 LA 4,16(4) INCREMENT POINTER 00015400 BCT 5,MHEADBL DECREMENT AND TEST COUNTER 00015450 SPACE 1 00015500 * MUST REINITIALIZE MEMORY TABLE 00015550 LA 4,MEMTABLE GET BEGIN ADDRESS OF TABLE 00015600 L 5,MMS GET NUMBER OF CELLS TO CLEAR 00015650 MEMBLANK ST ZERO,8(4) BLANK OUT CELL IN MEMORY TABLE 00015700 LA 4,12(4) INCREMENT POINTER 00015750 BCT 5,MEMBLANK DECREMENT COUNTER AND LOOP 00015800 SPACE 1 00015850 AP BATCH#,=PL1'1' INCREMENT BATCH NUMBER 00015900 ZAP STAT#,=P'0' ZERO STATUS REPORT NUMBER 00015950 MVC CATL,CAT+3 SET LAST CAT INITIATED FROM TO &CAT 00016000 ST ZERO,OVERLAP ZERO CHANNEL-CPU CONCURRENCY TIME 00016050 STM ZERO,SYSTIME,AVJOBMEM ZERO AVG # JOBS IN MEM AND TOTAL 00016100 * TURNAROUND TIME 00016150 SPACE 2 00016200 QCALL EVQINIT INITIALIZE EVENT QUEUE 00016250 QCALL EVENT PERFORM SIMULATION 00016300 QCALL ENDBATCH WRITE END OF BATCH REPORT 00016350 B MAINM2 GO TEST FOR END FILE 00016400 SPACE 2 00016450 MAINRET QRETURN REGS=(14,12) 00016500 LTORG 00016550 TITLE 'I/O REQUEST' 00016600 IOREQ CSECT 00016650 * AT ENTRY, REG 2 CONTAINS THE ADDRESS OF THE EVENT QUEUE 00016700 * ELEMENT ASSOCIATED WITHE THE I/O REQUEST 00016750 QSAVE 00016800 USING EVQEL,2 TO ADDRESS EVENT QUEUE ELEMENT 00016850 LH 1,EVFLAG GET (CPU#-1)*16 00016900 POP CPU1(1),3,MSG='IOREQ' FREE CORRECT CPU 00016950 USING JQEL,3 TO ADDRESS THE JQE 00017000 L 1,CHAN GET CHANNEL # JOB WILL USE 00017050 SLA 1,4 MULT BY 16 TO GET INDEX INTO CHAN HDR 00017100 L 0,CHAN1-12(1) GET LENGTH OF CHANNEL QUEUE 00017150 LTR 0,0 LENGTH = 0 IF CHANNEL IDLE; 00017200 BNZ IORWAIT = 1 IF BUSY 00017250 PUTNODE CHAN1-16(1),3,KEYLEN=0,MSG='IOR CHAN' ASSIGN CHANNEL 00017300 GETFREE EVQFR,2,ERROR GET A FREE EVENT QUEUE NODE 00017350 LR 0,SYSTIME COMPUTE TIME FINISHED USING CHANNEL 00017400 A 0,CHL 00017450 ST 0,EVTIME SET TIME OF CHANNEL TERMINATION 00017500 LA 0,3 GET # FOR I/O TERMINATION 00017550 STH 0,EV# PUT EVENT TYPE INTO NODE 00017600 STH 1,EVFLAG PUT (CHAN#)*16 INTO EVENT FLAG 00017650 PUTNODE EVQ,2,KEYLEN=6,LENGTH=8,MSG='REQ TERM' SCHED CHAN TERM 00017700 MSTATUS 3,I SET MEMORY USAGE FLAGS TO I 00017750 B IOREQEND 00017800 SPACE 2 00017850 * CHANNEL IS BUSY, MUST ENQUEUE JOB ON I/O WAIT QUEUE 00017900 IORWAIT PUTNODE IOQ1-16(1),3,KEY=18,MSG='I/O WAIT' PUT JOB INTO I/O Q 00017950 MSTATUS 3,W SET MEMORY BLOCK USAGE FLAGS TO WAIT 00018000 IOREQEND QRETURN 00018050 LTORG 00018100 DROP 2,3 00018150 TITLE 'I/O TERMINATOR' 00018200 IOTERM CSECT 00018250 * AT ENTRY, REG 2 CONTAINS THE ADDRESS OF THE EVENT QUEUE 00018300 * ELEMENT ASSOCIATED WITH THIS I/O TERMINATION 00018350 USING EVQEL,2 TO ADDRESS EVENT QUEUE ELEMENT 00018400 LH 3,EVFLAG GET CHANNEL# * 16 00018450 POP CHAN1-16(3),1,MSG='I/O TERM' FREE CHANNEL 00018500 USING JQEL,1 TO ADDRESS JOB QUEUE ELEMENT 00018550 LH 4,CPS#IO UPDATE # I/O REQUESTS FOR CPS 00018600 LA 4,1(4) 00018650 STH 4,CPS#IO 00018700 LH 4,IOS#IO UPDATE # I/O REQUESTS FOR IOS 00018750 LA 4,1(4) 00018800 STH 4,IOS#IO 00018850 ST ZERO,COMPCHI SET COMPUTED CHI TO 0 AWAITING CPU 00018900 PUTNODE RJQ,1,KEY=16,MSG='I/O TO R' PUT JOB BACK INTO RJQ 00018950 MSTATUS 1,R FIX UP MEMORY STATUS FLAGS FOR READY 00019000 POP IOQ1-16(3),1,IOTEND,MSG='I/O NEXT' GET NEXT JOB FOR CHAN 00019050 PUTNODE CHAN1-16(3),1,KEYLEN=0,MSG='IOT CHAN'CHAN TO NEXT 00019100 MSTATUS 1,I SET MEM STATUS FLAGS TO I/O WAIT 00019150 GETFREE EVQFR,2,ERROR GET A FREE EVENT QUEUE NODE 00019200 L 0,CHL COMPUTE TIME JOB DONE WITH CHANNEL 00019250 AR 0,SYSTIME 00019300 ST 0,EVTIME SET TIME OF CHANNEL TERMINATION 00019350 LA 0,3 GET # FOR I/O TERMINATION 00019400 STH 0,EV# SET EVENT TYPE TO I/O TERMINATION 00019450 STH 3,EVFLAG PUT CHANNEL #16 INTO EVQ ELEMENT 00019500 STH 3,EVFLAG PUT CHANNEL# * 16 INTO EVQ ELEMENT 00019550 IOTEND QRETURN 00019600 LTORG 00019650 DROP 1,2 END ADDRESSIBILITY OF QUEUE ELEMENTS 00019700 END LOADER 00019750 /* 00019800 $ENTRY 00019850 â00 PROCJCLŒŽ} &}3M]¦}3}&­ µ¦{¼jA3âµk-{*\{**k {*K¸¨~K00019900 ¸ÈkB¸ ¦{˜!BYk¸ˆô©¸â µw\{&â µ×n${âøµ±jA3âµ\{**¦{â0µ00019950 kC¦nB¸ âø¶¸jA3âµÎKA¹:k$*\{bk-*â0·o\¹‡â0·ož¹â×ý£¨Œ¸¨È¸N00020000 Œâøµ}âý£¦r ŸÈµæâ0ý£¦n=â×ýYkK¸ ¨ÈŒjŒâýk¸ˆô¸â2µ6â0ý2â000020050 ¶ðâ0ýðjŒâø·¨øŒë€ Œä€\Œ¦0ˆ¦øn -âø¶-N×-â׶+¦Ö¦Þâø00020100 ¶-â0¶¦ÿ§â·¦døâ0¶¦&0ÈPÈÈk¸ˆô¸â2¶:â0¶Žâ0ýâ0ýðâ0ýðj00020150 â×·k¸ˆô©¸â ¶õ\{&⵶ØkC¦¨ôqŽ} §n${âø¶¸jA3â¶M\{**¦{00020200 â0¶—ž¹â×·¦â0µjâ×·¦â0µj Œâø·-ýkâ×ýjŒâ·â0ýjâø·á00020250 -ýkâ×ýjâø·& Ȧ â0¶o¦© nA â ý%n9 âý%nF â}ýšn0 â ý%¦ë00020300 â0ýëâøýËž ¹ âýMÛ&ë&·§ë&¸ë ¸¨ ¸â0ý©¦¥n0&â ýyn9&â}ým©ž&¹ëâ00020350 ý{&ë&¸| ·yë6KA¹¾â0·«KA¹éâ0·«KAæâ0·«KAæâ0·«KAæ&â0·«KAæˆ00020400 â0·«KAækâ0·«KAæ·â0·«KAæMâ0·«KAæ5â0·«KA»â0·«KA»â0·«KA»¨â000020450 ·«KA»`k$;jA3â\·!\{**\{bk-;k·#\{&â ·kn${âø·oâ·hk0·#\¹«00020500 \{**â0·kC¦¨}·¸qŽ} â§55555555555555ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ00020550 ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ³÷ðú§ÿK·yõ·y·2 ¸·y2×·y5500020600 5555555555555550123456789 00020650  00020700 00020750     555555500020800 $JOB ASSIST MACRO=F 00020850 TITLE 'QDEFL MACRO - DEFINE A LIST OF NODES' 00020900 MACRO 00020950 &LABEL QDEFL &NUMBER,&LENGTH,&MESSAGE 00021000 LCLA &MSGK,&NNODES 00021050 LCLC &XLABEL 00021100 ACTR 100 00021150 .* 00021200 .* 00021250 .*THIS MACRO GENERATES &NUMBER NODES, EACH OF TOTAL LENGTH &LENGTH 00021300 .* BYTES (INCLUDING 4-BYTE LINK), LINKED TOGETHER, WITH KEY/DATA AREAS 00021350 .* INITIALIZED TO BLANKS, AND PRECEDED BY AN OPTIONAL MESSAGE. 00021400 .*&NUMBER IS A SELF-DEFINING TERM OF VALUE >0, GIVING THE NUMBER OF 00021450 .* NODES TO BE GENERATED. 00021500 .*&LENGTH IS ANY ABSOLUTE EXPRESSION GIVING A LENGTH FOR EACH NODE. 00021550 .* CODE GENERATED ALLOWS FOR ROUNDING THIS TO A 4-MULTIPLE. 00021600 .*&MESSAGE IS A STRING ENCLOSED IN QUOTES. IF OMITTED, THE LIST ONLY 00021650 .* IS CREATED, BUT IF PRESENT, THE MESSAGE STRING IS GENERATED AS 00021700 .* A C-TYPE CONSTANT, ROUNDED UP TO A 4-MULTIPLE, AND PLACED ON 00021750 .* A FULLWORD BOUNDARY PRECEDING THE LIST. IT IS USED FOR DEBUGGING 00021800 .* (I.E., TO LOCATE A LIST IN MEMORY IN A DUMP). 00021850 .*&LABEL IS GENERATED ON OR BEFORE THE FIRST NODE GENERATED. 00021900 .* 00021950 .* 00022000 &XLABEL SETC '&LABEL' 00022050 AIF (T'&MESSAGE EQ 'O').NOMSG . IS THERE A MESSAGE? 00022100 &MSGK SETA ((K'&MESSAGE+3)/4)*4 . MESSAGE LENGTH TO A 4-MULTIPLE. 00022150 DC 0F'0',CL&MSGK&MESSAGE . DEBUGGING MESSAGE FOR THIS LIST 00022200 .NOMSG ANOP 00022250 &NNODES SETA &NUMBER-1 . NUMBER OF NODES TO CREATE LESS ONE. 00022300 .ONELEFT AIF ('&NNODES' LT '1').LASTNOD . IS THIS THE LAST NODE? 00022350 &XLABEL DC A(*+((&LENGTH+3)/4)*4),CL(&LENGTH-4)' ' . SET UP A NODE. 00022400 .* LESS LINK POINTER OF 4 BYTES. 00022450 &XLABEL SETC '' . NULL THE LABEL. 00022500 &NNODES SETA &NNODES-1 . DECREMENT NODES TO DO. 00022550 AGO .ONELEFT . GO CHECK IF THERE IS ONLY ONE MORE. 00022600 .LASTNOD ANOP 00022650 &XLABEL DC A(0),CL(&LENGTH-4)' ' . POINTER OF LAST NODE IS ZERO. 00022700 MEND 00022750 TITLE 'QHED MACRO - DEFINE A LIST HEADER' 00022800 MACRO 00022850 &LABEL QHED &LISTNAM 00022900 ACTR 50 00022950 .* 00023000 .* 00023050 .*IF &LISTNAM IS CODED, THIS MACRO DEFINES A HEADER CONTAINING THE 00023100 .* ADDRESS OF THIS LIST, OTHERWISE IT IS A HEADER CELL HAVING A VALUE 00023150 .* OF 0, I.E., DEFINING AN EMPTY LIST. 00023200 .*FOR DEBUG PURPOSES, THIS MACRO GENERATES A MESSAGE '&LABEL LIST 00023250 .* HEADER' IMMEDIATELY PRECEDING THE HEADER WORD. 00023300 .* 00023350 .* 00023400 DC 0F'0',CL16'&LABEL HEADER' . DEBUGGING HEADER. 00023450 AIF (T'&LISTNAM EQ 'O').NULLNAM . IS THERE A HEADER NAME? 00023500 &LABEL DC A(&LISTNAM) . SET UP HEADER WITH ADDRESS OF LIST. 00023550 MEXIT 00023600 .NULLNAM ANOP 00023650 &LABEL DC A(0) . SET UP HEADER WITH NULL LIST. 00023700 MEND 00023750 TITLE 'QNEXT MACRO - GET ADDRESS OF NEXT NODE IN LIST' 00023800 MACRO 00023850 &LABEL QNEXT &RND,&ADDR,&RLK=,&END= 00023900 .* 00023950 .* 00024000 .*THIS MACRO SETS REGISTER &RND TO THE ADDRESS OF THE NEXT NODE IN 00024050 .* A LIST, GIVEN THAT &ADDR INDICATES THE ADDRESS OF A NODE WHOSE LINK 00024100 .* FIELD POINTS TO THE NEXT NODE. IF DESIRED, THE VALUE IN &RND MAY 00024150 .* BE SAVED INTO REGISTER &RLK BEFORE &RND IS CHANGED (USEFUL FOR LIST 00024200 .* SEARCH AND INSERT OPERATIONS). IF &END IS SPECIFIED, A TEST IS 00024250 .* MADE AND BRANCH TAKEN IF THERE ARE NO MORE NODES IN THE LIST. 00024300 .*&RND IS A REGISTER EQU SYMBOL OR NUMBER, INTO WHICH WILL BE LOADED 00024350 .* THE ADDRESS OF THE NEXT NODE. 00024400 .*&ADDR IF SPECIFIED AT ALL, IS AN RX-TYPE ADDRESS OF THE LINK FIELD 00024450 .* WHICH ADDRESSES THE NEXT NODE. THE WORD AT THIS ADDRESS IS TO BE 00024500 .* LOADED INTO &RND. IF OMITTED ENTIRELY, IT IS TO BE ASSUMED THAT 00024550 .* &RND CONTAINS THE ADDRESS OF THE LINK ALREADY. 00024600 .*&RLK IF SPECIFIED, GIVES THE NAME OR NUMBER OF A REGISTER INTO WHICH 00024650 .* &RND SHOULD BE SAVED BEFORE IT IS CHANGED. 00024700 .*&END IF SPECIFIED, GIVES A STATEMENT LABEL, IN WHICH CASE THE VALUE 00024750 .* NEWLY LOADED INTO &RND IS TO BE TESTED, AND IF FOUND = 0, A BRANCH 00024800 .* TAKEN TO THE GIVEN STATEMENT LABEL. 00024850 .*NOTE THAT 'LINK' IS ASSUMED TO BE THE LINK DISPLACEMENT. 00024900 .* 00024950 .* 00025000 LCLC &XLABEL 00000050 ACTR 50 00000100 &XLABEL SETC '&LABEL' 00000150 AIF (T'&RLK EQ 'O').NOWORKR . IS THERE A WORK REGISTER? 00000200 &XLABEL LR &RLK,&RND . SAVE NEXT NODE REGISTER. 00000250 &XLABEL SETC '' . NULL THE LABEL. 00000300 .NOWORKR AIF (T'&ADDR EQ 'O').NOADDR . IS THERE AN ADDR OF THE LINK? 00000350 &XLABEL L &RND,&ADDR+LINK . ADDR OF THE LINK FIELD. 00000400 &XLABEL SETC '' . NULL THE LABEL. 00000450 AGO .ENDTEST . GO TEST FOR END ENTRY. 00000500 .NOADDR ANOP 00000550 &XLABEL L &RND,LINK(,&RND) . SET TO POINT TO NEXT NODE. 00000600 .ENDTEST AIF (T'&END EQ 'O').NOEND . IS THE END OPTION REQUESTED? 00000650 LTR &RND,&RND . SET THE CONDITION CODE TO TEST 00000700 BZ &END . FOR LAST NODE, BRANCH IF YES. 00000750 MEXIT 00000800 .NOEND MEND 00000850 TITLE 'QPOP MACRO - POP THE FIRST ELEMENT OF A LIST' 00000900 MACRO 00000950 &LABEL QPOP &RND,&HDR,&END= 00001000 .* 00001050 .* 00001100 .*QPOP SETS REGISTER &RND TO THE ADDRESS OF THE FIRST NODE IN THE LIST 00001150 .* BEGUN BY HEADER AT ADDRESS &HDR, TAKING BRANCH TO &END= IF THE LIST 00001200 .* IS EMPTY. 00001250 .*&RND SPECIFIES REGISTER TO BE SET TO ADDRESS OF NODE. 00001300 .*&HDR USUALLY SPECIFIES THE NAME OR OTHER RX-ADDRESS OF THE HEADER 00001350 .* CELL OF A LIST. 00001400 .*&END IF SPECIFIED, REQUESTS CODE TO TEST THE LINK JUST LOADED INTO 00001450 .* &RND, AND BRANCH TO THE LABEL SPECIFIED IF IT IS ZERO. 00001500 .*NOTICE 'LINK' IS ASSUMED TO BE THE LINK DISPLACEMENT. 00001550 .*MACROS USED : QNEXT. 00001600 .* 00001650 .* 00001700 ACTR 50 00001750 &LABEL QNEXT &RND,&HDR,END=&END 00001800 MVC LINK+&HDR.(4),LINK(&RND) . POINT HEADER TO NEW TOP NODE. 00001850 MEND 00001900 TITLE 'QPUSH MACRO - PUSH A NODE ONTO THE BEGINNING OF A LIST' 00001950 MACRO 00002000 &LABEL QPUSH &RND,&HDR 00002050 .* 00002100 .* 00002150 .*&RND CONTAINS THE ADDRESS OF A NODE, WHICH IS PUSHED ONTO THE LIST 00002200 .* BEGUN AT &HDR. 00002250 .*&RND SPECIFIES A REGISTER NAME OR NUMBER. 00002300 .*&HDR IS A NAME OF A HEADER CELL. 00002350 .*NOTICE 'LINK' IS ASSUMED TO BE THE LINK DISPLACEMENT. 00002400 .* 00002450 .* 00002500 ACTR 50 00002550 &LABEL MVC LINK(4,&RND),&HDR . MOVE HEADER POINTER TO NEW NODE. 00002600 ST &RND,&HDR . SET HEADER POINTER TO POINT TO 00002650 * NEW NODE. 00002700 MEND 00002750 TITLE 'QSRCH MACRO - LIST SEARCH AND INSERT NODE IN SEQUENCE' 00002800 MACRO 00002850 &LABEL QSRCH &RND,&HDR,&RGW=(RWK1,RWK2),&KO=4,&KL=KEYL 00002900 .* 00002950 .* 00003000 .*THIS MACRO SEARCHES THE LIST BEGUN BY HEADER &HDR, WHICH IS LINKED 00003050 .* IN ASCENDING ORDER BY KEY FIELDS, FOR THE CORRECT PLACE TO INSERT 00003100 .* THE NODE ADDRESSED BY REGISTER &RND. THE KEY FIELDS ARE AT OFFSET 00003150 .* &KO, AND ARE &KL BYTES LONG. &RGW GIVES TWO REGISTERS WHICH MAY BE 00003200 .* USED IF NEEDED FOR TEMPORARY WORK REGISTERS WITHOUT DISTURBING 00003250 .* ANYTHING. 00003300 .*&RND GIVES ADDRESS OF THE NODE TO BE INSERTED. 00003350 .*&HDR IS THE NAME OF THE LIST HEADER CELL. 00003400 .*&RGW GIVES THE NAMES/NUMBERS OF 2 REGISTERS WHICH CAN SAFELY BE USED 00003450 .* AS TEMPORARY WORK REGISTERS, AND DESTROYED BY THE MACRO. 00003500 .*&KO GIVES A NUMBER (OR EQU SYMBOL) OF THE OFFSET IN BYTES FROM THE 00003550 .* BEGINNING OF THE NODE TO THE KEY FIELD IN THE NODE. 00003600 .*&LK IS THE LENGTH (NUMBER OR EQU VALUE) OF THE KEY FIELD. 00003650 .*NOTE THAT THE NODE TO BE INSERTED IS INSERTED AFTER ANY NODES WHICH 00003700 .* HAVE THE SAVE KEY VALUE. 00003750 .*NOTICE RWK1, RWK2, AND LINK AND KEYL ARE ASSUMED TO BE SET IN THE 00003800 .* MAIN PROGRAM BY EQU'S. 00003850 .* 00003900 .* 00003950 LCLC &LOOP,&SETLINK 00004000 ACTR 50 00004050 &LOOP SETC '&SYSECT'(1,2).'&SYSNDX'.'LP' . MAKE UP A LOOPING NAME. 00004100 &SETLINK SETC '&LOOP'(1,6).'SL' . MAKE UP A BRANCHING NAME. 00004150 &LABEL LA &RGW(1),&HDR . ADDR OF HEADER TO WORK REGISTER 1. 00004200 &LOOP LR &RGW(2),&RGW(1) . SAVE IT FOR LINKING. 00004250 L &RGW(1),LINK(,&RGW(1)) . POINTER TO NEXT NODE. 00004300 LTR &RGW(1),&RGW(1) . SET CONDITION CODE TO SEE IF THIS IS 00004350 BZ &SETLINK . THE LAST NODE. IF SO, BRANCH. 00004400 CLC &KO.(&KL,&RGW(1)),&KO.(&RND) . IS THIS THE PLACE TO PUT 00004450 BNH &LOOP . NODE IN? IF NOT GO PROCESS NEXT NODE 00004500 &SETLINK ST &RGW(1),LINK(,&RND) . SET NEW NODE POINTER TO NEXT NODE 00004550 .* IN ORIGINAL SEQUENCE. 00004600 ST &RND,LINK(,&RGW(2)) . SET NODE POINTER IN NODE BEFORE 00004650 .* INSERTED NEW NODE TO POINT TO 00004700 .* NEW NODE. 00004750 MEND 00004800 TITLE 'QSNAP MACRO - PRINT THE CONTENTS OF A LIST' 00004850 MACRO 00004900 &LABEL QSNAP &HDR,&MSG,&RGW=(RWK1,RWK2),&COUNT=4095,&LEN=20 00004950 .* 00005000 .* 00005050 .*THIS MACRO DUMPS THE LIST BEGINNING AT THE HEADER &HDR, USING XSNAP 00005100 .* WITH A MESSAGE &MSG PRINTED. THE WORK REGISTERS NEEDED ARE GIVEN 00005150 .* BY &RGW, AND UP TO &COUNT NODES ARE PRINTED. 00005200 .*&HDR IS NAME OF LIST HEADER. 00005250 .*&MSG IS QUOTED STRING USED AS TITLE FOR LIST OUTPUT. 00005300 .*&RGW SPECIFIES NAMES/NUMBERS OF 2 REGISTERS WHICH MAY BE ERASED. 00005350 .*&COUNT SPECIFIES THE MAXIMUM NUMBER OF NODES TO BE PRINTED. 00005400 .*&LEN IS AN ABSOLUTE EXPRESSION GIVING NODE LENGTH IN BYTES. 00005450 .*NOTICE RWK1 AND RWK2 ARE ASSUMED TO BE SET IN MAIN PROGRAM BY EQU'S 00005500 .*MACROS REQUIRED: QNEXT,XSNAP. 00005550 .* 00005600 .* 00005650 LCLC &LOOP,&ENDADDR 00005700 ACTR 50 00005750 &ENDADDR SETC '&SYSECT'(1,2).'&SYSNDX'.'EN' . UNIQUE BRANCH NAME. 00005800 &LOOP SETC '&ENDADDR'(1,6).'LP' . UNIQUE LOOPING NAME. 00005850 &LABEL LA &RGW(1),&COUNT . SET MAXIMUM NODES TO BE PRINTED. 00005900 LA &RGW(2),&HDR . GET ADDRESS OF LIST HEADER. 00005950 &LOOP QNEXT &RGW(2),END=&ENDADDR . GO TO NEXT NODE. 00006000 XSNAP LABEL=&MSG,T=NO,STORAGE=(*0(&RGW(2)),*&LEN.(&RGW(2))) 00006050 BCT &RGW(1),&LOOP . LOOP BACK TO GO TO NEXT NODE. 00006100 &ENDADDR EQU * 00006150 MEND 00006200 SPACE 2 00006250 * DUMMY MACROS TO SPEED PROCESSSING. 00006300 MACRO 00006350 GETMAIN 00006400 * SAVE FROM XSAVE. 00006450 MEND 00006500 MACRO 00006550 FREEMAIN 00006600 * SAVE FROM XRETURN. 00006650 MEND 00006700 MACRO 00006750 XSNAP 00006800 XSNAP &LABEL=,&STORAGE=,&T=,&IF= 00006850 XDUMP 00006900 MEND 00006950 *SYSLIB XSAVE,XRETURN,EQUREGS 00007000 TITLE 'TEST LIST MACROS MAIN PROGRAM' 00007050 SPACE 3 00007100 TENODES DSECT 00007150 TELINK DS A LINK TO NEXT NODE. 00007200 TEKEY DS CL8 KEY ORDERING FIELD. 00007250 TEDATA DS CL12 NODE'S DATA. 00007300 NODELEN EQU ((*-TELINK+3)/4)*4 NODE LENGTH, TO A 4-MULTIPLE. 00007350 SPACE 3 00007400 SPACE 2 00007450 *THIS TEST PROGRAM DOES THE FOLLOWING: 00007500 * 1)DEFINES A LIST OF 15 EMPTY NODES CALLED FREE LIST, EACH WITH 00007550 * 8-BYTE KEY AND 12-BYTE DATA AREAS. ALSO DEFINES TWO EMPTY LISTS, 00007600 * LISTA AND LISTB. (I.E. THESE ARE NAMES OF HEADERS). 00007650 * 2)READS IN 10 DATA CARDS, EACH OF WHICH CONTAINS KEY AND DATA FOR 00007700 * A SINGLE NODE IN COLUMNS 1-20. AFTER EACH CARD IS READ, AN EMPTY 00007750 * NODE IS OBTAINED FROM THE FREE LIST, FILLED WITH THE KEY AND DATA 00007800 * JUST READ (AND A DSECT IS USED TO REFER TO THESE FIELDS AT THIS 00007850 * POINT), THEN IT IS ENTERED IN LISTA. 00007900 * 3)DUMPS LISTS FREE, LISTA, AND LISTB. 00007950 * 4)READS IN 5 CARDS, EACH WITH A KEY VALUE ON COLUMNS 1-8. SEARCHES 00008000 * LISTA FOR THE SAME KEY VALUE. IF NOT FOUND, PRINTS A MESSAGE. 00008050 * IF FOUND, FIRST REMOVES THE NODE FROM LISTA, THEN PUSHES IT ONTO 00008100 * BEGINNING OF LISTB. 00008150 * 5)POPS EACH NODE OF LISTA, PRINTS EACH AS IT IS OBTAINED, THEN 00008200 * PLACES THE NODE BACK ONTO THE FREE LIST, UNTIL LISTA IS EMPTY. 00008250 * 6)PERFORMS SAME ACTION AS IN 5, BUT FOR LISTB. 00008300 *MACROS REQUIRED: XSNAP, XPRNT. 00008350 SPACE 2 00008400 PRINT NOGEN 00008450 EQUREGS 00008500 LINK EQU 0 OFFSET OF THE LINK FIELD IN A NODE. 00008550 KEYO EQU 4 COMMON OFFSET TO KEY FIELD. 00008600 KEYL EQU 8 MOST COMMON KEY LENGTH. 00008650 RWK1 EQU 5 TEMPORARY WORK REG. 00008700 RWK2 EQU 6 ANOTHER TEMPORARY WORK REG. 00008750 TESTLIST CSECT 00008800 XSAVE , ESTABLISH ENTRY LINKAGE, BASE=R12. 00008850 SPACE 2 00008900 *READ IN 10 CARDS AND INSERT THEM IN LISTA. 00008950 SPACE 2 00009000 LA R2,10 NUMBER OF CARDS TO BE READ. 00009050 PRINT NOGEN 00009100 XPRNT =CL80'-HERE ARE THE 10 CARDS TO GO ONTO LIST A:',80 00009150 TEREAD1 XREAD TECARD,20 GET A CARD. 00009200 XPRNT TECC,TECHOLEN ECHO PRINT THE CARDS. 00009250 PRINT GEN 00009300 QPOP R3,TEFREE,END=TEDUMMY GET A FREE NODE, TEST END FEATURE 00009350 USING TENODES,R3 DESECT SET UP TO MOVE DATA. 00009400 TEDUMMY MVC TEKEY,TECARDK KEY IN FREE NODE GETS KEY ON CARD. 00009450 MVC TEDATA,TECARDD DATA IN FREE NODE GETS DATA ON CARD. 00009500 QSRCH R3,TELISTA INSERT THIS NODE IN LIST A. 00009550 XSNAP STORAGE=(TEFREE,TECARDMS),IF=(R2,H,=F'6',C) 00009600 BCT R2,TEREAD1 HAVE 10 CARDS BEEN READ? 00009650 DROP R3 00009700 SPACE 2 00009750 *DUMP LISTS FREE, LISTA, AND LISTB. 00009800 SPACE 2 00009850 QSNAP TEFREE,'LIST OF FREE NODES',COUNT=16,LEN=NODELEN 00009900 QSNAP TELISTA,'LIST A',COUNT=16,LEN=NODELEN 00009950 QSNAP TELISTB,'LIST B',COUNT=16,LEN=NODELEN 00010000 SPACE 2 00010050 *READ IN 5 CARDS, SEARCH LISTA FOR THAT KEY, IF NOT FOUND, PRINT A 00010100 * MESSAGE SAYING SO; IF FOUND, MOVE THE NODE FROM LIST A TO LIST B. 00010150 SPACE 2 00010200 LA R2,5 NUMBER OF CARDS TO BE READ IN. 00010250 PRINT NOGEN 00010300 XPRNT =CL80'-HERE ARE THE 5 CARDS TO BE LIST A SEARCHED:',80 00010350 TEREAD2 XREAD TECARD,20 GET CARD. 00010400 XPRNT TECC,TECHOLEN ECHO PRINT THE CARD. 00010450 PRINT GEN 00010500 LA R3,TELISTA BEGINNING OF LIST TO BE SEARCHED. 00010550 TENEXT QNEXT R3,RLK=RWK1,END=TELAST1 00010600 CLC TECARDK,4(R3) IF THE NODE KEY AND THE INPUT CARD 00010650 BE TEFOUND KEY ARE SAME, THERE IS A MATCH. 00010700 B TENEXT GO BACK TO LOOK AT NEXT NODE. 00010750 TELAST1 CLC TECARDK,4(R3) IF THE NODE KEY AND THE INPUT CARD 00010800 BE TEFOUND KEY ARE SAME, THERE IS A MATCH. 00010850 PRINT NOGEN 00010900 XPRNT TECC,TEMSGLEN PRINT A NOT FOUND MESSAGE. 00010950 PRINT GEN 00011000 B TENEWCRD GO PROCESS NEXT CARD, IF ANY. 00011050 TEFOUND MVC LINK(4,RWK1),LINK(R3) REMOVE FOUND NODE FROM LIST. 00011100 QPUSH R3,TELISTB INSERT FOUND NODE IN LIST. 00011150 XSNAP STORAGE=(TEFREE,TECARDMS) 00011200 TENEWCRD BCT R2,TEREAD2 GO READ NEXT CARD TO BE SEARCHED. 00011250 SPACE 2 00011300 *POP EACH NODE OF LISTA AND PRINT AS OBTAINED, THEN PUT ON FREE LIST. 00011350 SPACE 2 00011400 PRINT NOGEN 00011450 XPRNT =CL40'0LIST A FOLLOWS:',40 00011500 PRINT GEN 00011550 TEPOPA QPOP R3,TELISTA,END=TESTOPOP 00011600 MVC TEPRNODE(NODELEN-4),4(R3) MOVE TO PRINT AREA LESS LINK. 00011650 PRINT NOGEN 00011700 XPRNT TECCPN,TECCPNL PRINT THE NODE. 00011750 PRINT GEN 00011800 B TEPOPA GO BACK TO POP NEXT NODE. 00011850 PRINT NOGEN 00011900 SPACE 2 00011950 *POP EACH NODE OF LISTB AND PRINT AS OBTAINED, THEN PUT ON FREE LIST. 00012000 SPACE 2 00012050 TESTOPOP XPRNT =CL40'0LIST B FOLLOWS:',40 00012100 PRINT GEN 00012150 TEPOPB QPOP R3,TELISTB,END=TESTOPB TAKE A NODE OFF LIST B. 00012200 MVC TEPRNODE(NODELEN-4),4(R3) MOVE TO PRINT AREA LESS LINK. 00012250 PRINT NOGEN 00012300 XPRNT TECCPN,TECCPNL PRINT THIS NODE. 00012350 PRINT GEN 00012400 B TEPOPB GO BACK TO POP NEXT NODE. 00012450 PRINT NOGEN 00012500 TESTOPB XRETURN SA=* 00012550 PRINT GEN 00012600 DROP 12 00012650 SPACE 3 00012700 LTORG 00012750 SPACE 3 00012800 TEFREE QHED TELIST1 HEADER FOR LIST OF FREE NODES. 00012850 TELIST1 QDEFL 15,NODELEN,'FREE NODES FOR TEST' 00012900 TELISTA QHED , HEADER FOR LIST A. 00012950 TELISTB QHED , HEADER FOR LIST B. 00013000 TECC DC CL1'0' CARRIAGE CONTROL FOR PRINTING CARDS. 00013050 TECARD EQU * CARD IMAGE AREA HAS 2 NAMES. 00013100 TECARDK DC CL8' ' CARD IMAGE KEY. 00013150 TECARDD DC CL12' ' CARD IMAGE DATA. 00013200 TECHOLEN EQU *-TECC LENGTH OF ECHO PRINT MESSAGE. 00013250 TECARDMS DC CL24' MATCHING NODE NOT FOUND' 00013300 TEMSGLEN EQU *-TECC LENGTH OF PRINT MESSAGE. 00013350 SPACE 2 00013400 TECCPN DC CL1' ' NODE PRINT CARRIAGE CONTROL CHAR. 00013450 TEPRNODE DC CL132' ' NODE PRINT AREA. 00013500 TECCPNL EQU *-TECCPN LENGTH OF THE NODE PRINT LINE. 00013550 END TESTLIST 00013600 $ENTRY 00013650 CCCCCCCCTEST CARD 1 00013700 AAAAAAAATEST CARD 2 00013750 DDDDDDDDTEST CARD 3 00013800 FFFFFFFFTEST CARD 4 00013850 BBBBBBBBTEST CARD 5 00013900 ZZZZZZZZTEST CARD 6 00013950 XXXXXXXXTEST CARD 7 00014000 GGGGGGGGTEST CARD 8 00014050 KKKKKKKKTEST CARD 9 00014100 EEEEEEEETEST CARD 10 00014150 NOTFOUNDTEST CARD 11 00014200 ZZZZZZZZTEST CARD 12 00014250 AAAAAAAATEST CARD 13 00014300 AAAAAAAATEST CARD 14 00014350 KKKKKKKKTEST CARD 15 00014400 $JOB ASSIST MACRO=F 00014450 TITLE '*** DCBDUMP - FORMATTED DUMP OF DATA CONTROL BLOCK ***' 00014500 MACRO 00014550 IHBERMAC 00014600 MEND 00014650 *SYSLIB DCBD 00014700 PRINT NOGEN 00014750 * 00014800 * SET UP SYMBOLIC NAMES FOR SYSTEM CONTROL BLOCKS 00014850 * USING I-B-M STANDARD MACROS TO AVOID PROBLEMS WITH 00014900 * FUTURE OPERATING SYSTEMS. 00014950 * 00015000 * 00015050 DCBD DSORG=PS 00015100 SPACE 4 00015150 IHACVT DSECT 00015200 CVTTCBP DS F 00015250 CVTPTR EQU 16 00015300 SPACE 4 00015350 IHATCBP DSECT 00015400 TCBPNTCB DS F 00015450 TCBPCTCB DS F 00015500 SPACE 4 00015550 IHATCB DSECT 00015600 DS 3F 00015650 TCBTIO DS F 00015700 SPACE 4 00015750 IHATIOT DSECT 00015800 DS F 00015850 SPACE 3 00015900 BS DSECT , BYTE SCANER PARM FIELD 00015950 BSBYTE DS A ADRS OF BYTE TO BE SCANNED 00016000 BSOUT DS A START ADRS OF OUTPUT FIELD 00016050 BSLIST DS A LIST HEADER OF OPTION DESCRIPTION 00016100 BSLEN DS F EFFECTIVE LENGTH OF OUTPUT FIELD 00016150 BSADD DS F SPACE BETWEEN OUTPUT FIELDS 00016200 SPACE 3 00016250 BITFLG DSECT , BIT PATTERN DESCRIPTION 00016300 BFLINK DS A LINK TO NEXT NODE 00016350 BFMASK DS C MASK ON SOURCE BYTE 00016400 BFMATCH DS C PATTERN BEING CHECKED FOR 00016450 BFOUT DS 0C MESSAGE FOR THIS BIT PATTERN 00016500 EJECT 00016550 DCBDUMP CSECT 00016600 USING *,15 00016650 STM 0,15,SAVEALL SAVE ALL REGS 00016700 CNOP 0,4 00016750 BAL 13,PGMSTART 00016800 DROP 15 00016850 USING *,13 00016900 DC 18F'0' 00016950 SAVEALL DS 16F 00017000 PGMSTART EQU * 00017050 ST 1,SAVEPARM 00017100 L Z,0(1) LOAD ADDRESS OF D-C-B 00017150 USING IHADCB,Z ADDRESSABILITY WITH DCBD 00017200 SPACE 10 00017250 * FIND DDNAME AND STATUS 00017300 * 00017350 MVC STATUS(3),=C'NOT' 00017400 LA A,DCBDDNAM 00017450 TM DCBOFLGS,X'10' 00017500 BZ CLOSED 00017550 L A,CVTPTR CVT POINTER 00017600 USING IHACVT,A 00017650 L A,CVTTCBP ADDRESS OF T-C-B 00017700 USING IHATCBP,A 00017750 L A,TCBPCTCB 00017800 USING IHATCB,A 00017850 L A,TCBTIO ADDRESS OF T-I/O-T 00017900 USING IHATIOT,A 00017950 LH B,DCBTIOT T-I/O-T OFFSET 00018000 LA A,4(A,B) 00018050 MVC STATUS(3),STATUS-1 00018100 CLOSED MVC DDNAME(8),0(A) 00018150 * 00018200 XPRNT LINE1,LEN1 00018250 EJECT 00018300 XPRNT HEADER2 00018350 LA A,96(Z) END OF D-C-B 00018400 ST A,ENDDCB 00018450 LM A,C,=A(DUMPLINE+20,9,DUMPLINE+47) 00018500 LR E,Z 00018550 OUTLOOP LR D,A 00018600 INLOOP UNPK 0(9,D),0(5,E) 00018650 MVI 8(D),X'FE' 00018700 LA E,4(E) 00018750 BXLE D,B,INLOOP 00018800 TR DUMPLINE+20(36),HEXTAB 00018850 XPRNT DUMPLINE 00018900 C E,ENDDCB 00018950 BL OUTLOOP 00019000 EJECT 00019050 * BLKSIZE, LRECL, RECFM 00019100 * 00019150 * BLOCK SIZE 00019200 LH A,DCBBLKSI 00019250 CVD A,DWORD 00019300 MVC BLKSIZE(6),EDIT 00019350 ED BLKSIZE(6),DWORD+5 00019400 * LOGICAL RECORD LENGTH 00019450 LH A,DCBLRECL 00019500 CVD A,DWORD 00019550 ED LRECL(6),DWORD+5 00019600 * RECORD FORMAT 00019650 SR A,A 00019700 IC A,DCBRECFM 00019750 SRL A,6 00019800 LA A,FORMATS(A) 00019850 MVC RECFM(1),0(A) 00019900 LA A,RECFM+1 00019950 TM DCBRECFM,B'00100000' 00020000 BZ *+12 00020050 MVI 0(A),C'T' 00020100 LA A,1(A) 00020150 TM DCBRECFM,B'00010000' 00020200 BZ *+12 00020250 MVI 0(A),C'B' 00020300 LA A,1(A) 00020350 IC B,DCBRECFM 00020400 SLL B,29 00020450 SRL B,31 00020500 LA B,PCCC(B) 00020550 MVC 0(1,A),0(B) 00020600 SPACE 3 00020650 * MACRO FORMAT,ACCESS METHOD 00020700 MVC MACRF,BLANKS 00020750 SPACE 1 00020800 TM DCBMACR,B'10000000' TEST FOR EXCP 00020850 BO EXCP 00020900 SPACE 1 00020950 TM DCBMACR,B'11000000' TEST FOR BSAM 00021000 BNZ NOTBSAM 00021050 TM DCBMACR+1,B'11000000' 00021100 BZ BSAM 00021150 NOTBSAM EQU * 00021200 SPACE 1 00021250 TM DCBMACR,B'10100000' CHECK FOR QSAM 00021300 BNZ NOTQSAM 00021350 TM DCBMACR+1,B'10100000' 00021400 BZ QSAM 00021450 NOTQSAM EQU * 00021500 SPACE 1 00021550 MVC ACCESS,=CL8' INVALID' 00021600 B MACRFXX 00021650 SPACE 1 00021700 EXCP MVC ACCESS,=CL8' EXCP' 00021750 B MACRFXX 00021800 SPACE 1 00021850 BSAM MVC ACCESS,=CL8' BSAM' 00021900 LM A,B,=A(MAC1BS1,MAC2BS1) 00021950 B MACRFDMP 00022000 SPACE 1 00022050 QSAM MVC ACCESS,=CL8' QSAM' 00022100 LM A,B,=A(MAC1QS1,MAC2QS1) 00022150 * B MACRFDMP 00022200 SPACE 1 00022250 MACRFDMP LR 1,A BYTE 1 MACRF CODES 00022300 LA D,DCBMACRF ADRS OF DCBMACRF 00022350 ST D,0(1) STORE FOR BYTESCAN 00022400 BAL 14,BYTESCAN 00022450 L C,NEXTADRS 00022500 MVC 0(C),C',' 00022550 LA C,1(C) 00022600 LR 1,B BYTE 2 MACRF CODES 00022650 USING BS,1 00022700 ST C,BSOUT 00022750 DROP 1 00022800 LA D,DCBMACRF+1 00022850 ST D,0(1) 00022900 BAL 14,BYTESCAN 00022950 L C,NEXTADRS 00023000 MVC 0(C),C')' 00023050 MACRFXX EQU * 00023100 * 00023150 XPRNT LINE2,LEN2 00023200 MVC RECFM(5),RECFM-1 00023250 EJECT 00023300 * BFALN, BFTEK, BUFCB, BUFL, BUFNO 00023350 * 00023400 * BUFFER ALIGNMENT 00023450 IC A,DCBBFALN 00023500 SLL A,30 00023550 SRL A,27 00023600 LA A,ALIGN(A) 00023650 MVC BFALN(5),0(A) 00023700 * BUFFERING TECHNIQUE 00023750 IC A,DCBBFTEK 00023800 SLL A,25 00023850 SRL A,29 00023900 LA A,TECH(A) 00023950 MVC BFTEK(1),0(A) 00024000 * BUFFER CONTROL BLOCK ADDRESS 00024050 L A,DCBBUFCB 00024100 LA A,0(A) 00024150 ST A,FULL 00024200 UNPK DWORD(7),FULL+1 00024250 TR DWORD(6),HEXTAB 00024300 MVC BUFCB(6),DWORD 00024350 * BUFFER LENGTH 00024400 LH A,DCBBUFL 00024450 CVD A,DWORD 00024500 MVC BUFL(6),EDIT 00024550 ED BUFL(6),DWORD+5 00024600 * NUMBER OF BUFFERS 00024650 SR A,A 00024700 IC A,DCBBUFNO 00024750 CVD A,DWORD 00024800 MVC BUFNO(4),EDIT 00024850 ED BUFNO(4),DWORD+6 00024900 * 00024950 XPRNT LINE3,LEN3 00025000 EJECT 00000050 * DSORG, EODAD, EROPT 00000100 * 00000150 * DATA SET ORGANIZATION 00000200 LA 1,DCBDSORG 00000250 MVC LRECL(6),EDIT 00000300 BAL 14,BASE2 00000350 SLL 1,1 00000400 LA A,ORGANS(1) 00000450 MVC DSORG(2),0(A) 00000500 * END OF DATA ADDRESS 00000550 L A,DCBEODAD 00000600 LA A,0(A) 00000650 ST A,FULL 00000700 UNPK DWORD(7),FULL+1(4) 00000750 TR DWORD(6),HEXTAB 00000800 MVC EODAD(6),DWORD 00000850 * ERROR OPTION 00000900 LA 1,DCBEROPT 00000950 BAL 14,BASE2 00001000 SLL 1,2 00001050 LA A,ERRORS(1) 00001100 MVC EROPT(3),0(A) 00001150 SPACE 3 00001200 * DCBOPTCD 00001250 MVC OPTCD,BLANKS 00001300 L 1,=A(DMPOPTCD) 00001350 LA A,DCBOPTCD 00001400 ST A,0(1) 00001450 BAL 14,BYTESCAN 00001500 * 00001550 XPRNT LINE4,LEN4 00001600 SPACE 3 00001650 * 00001700 * OUTPUT DCB CIND FLAGS 00001750 * 00001800 * CLEAR OUTPUT BUFFER 00001850 LM A,B,=A(CINDOUT,CINDSAVE) 00001900 MVC 0(133,A),0(B) 00001950 LM A,C,=A(CINDOUT+133,133,CINDOUT+7*133) 00002000 MVI 0(A),C' ' 00002050 CINDBLNK MVC 1(133,A),0(A) 00002100 BXLE A,B,CINDBLNK 00002150 SPACE 1 00002200 * CALL BYTESCAN SUBROUTINE TO FILL IN OUTPUT FIELDS 00002250 L 1,=A(DMPCND1) 00002300 LA A,DCBCIND1 ADRS OF CIND 1 BYTE 00002350 ST A,0(1) STORE IN PARM FOR BYTESCAN 00002400 BAL 14,BYTESCAN 00002450 L 1,=A(DMPCND2) 00002500 LA A,DCBCIND2 ADRS OF CIND BYTE 2 00002550 ST A,0(1) STORE IN PARM FOR BYTESCAN 00002600 BAL 14,BYTESCAN 00002650 SPACE 1 00002700 * PRINT OUTPUT BUFFER 00002750 LM A,C,=A(CINDOUT,133,CINDOUT+7*133) 00002800 CINDPRNT XPRNT 0(A),133 00002850 BXLE A,B,CINDPRNT 00002900 EJECT 00002950 * THAT'S ALL FOLKS 00003000 L 1,SAVEPARM PARM LIST ADRS 00003050 CLI 0(1),X'80' END OF LIST 00003100 BE PGMEXIT 00003150 LA 1,4(1) NEXT LIST ELEMENT 00003200 B PGMSTART 00003250 SPACE 1 00003300 PGMEXIT LM 0,15,SAVEALL 00003350 SPM 14 00003400 BR 14 00003450 SPACE 10 00003500 BYTESCAN DS 0H 00003550 STM 14,12,12(13) 00003600 USING BS,1 00003650 LM A,E,BS LOAD PARM REGS 00003700 USING BITFLG,C 00003750 BSLOOP MVC BSWORK,0(A) WORK ON SOURCE BYTE 00003800 NC BSWORK,BFMASK PATTERN MASK 00003850 CLC BSWORK,BFMATCH COMPARE WITH WANTED PATTERN 00003900 BNE BSNEXT NO MATCH 00003950 EX D,MVC1 MOVE MESSAGE TO OUTPUT FIELD 00004000 AR B,E NEXT ADRS IN OUTPUT BUFFER 00004050 BSNEXT L C,BFLINK NEXT NODE ADRS 00004100 LTR C,C END OF LIST ??? 00004150 BNZ BSLOOP NO 00004200 ST B,NEXTADRS 00004250 LM 14,12,12(13) 00004300 BR 14 00004350 MVC1 MVC 0(*-*,B),BFOUT MOVE MESSAGE TO OUTPUT FIELD 00004400 NEXTADRS DS A NEXT ADRS OF OUTPUT BUFFER 00004450 BSWORK DS CL1 00004500 SPACE 10 00004550 A EQU 3 00004600 B EQU 4 00004650 C EQU 5 00004700 D EQU 6 00004750 E EQU 7 00004800 F EQU 8 00004850 Z EQU 11 00004900 * 00004950 LINE DC 10C' ' 00005000 DS 8CL9 00005050 LEN EQU *-LINE 00005100 * 00005150 DWORD DS D 00005200 EDIT DC C' ',15X'20' 00005250 FULL DS F 00005300 HEXTAB EQU *-239 00005350 DC C' 0123456789ABCDEF' 00005400 LINE1 DC 0D'0',C'0' 00005450 DC C'DDNAME=' 00005500 DDNAME DC CL8' ',C' ' 00005550 STATUS DC CL3' ',C' OPEN' 00005600 LEN1 EQU *-LINE1 00005650 DC (133-LEN1)C' ' 00005700 SPACE 1 00005750 LINE2 DC 0D'0',C'0' 00005800 DC C' BLKSIZE=' 00005850 BLKSIZE DC CL6' ' 00005900 DC C' LRECL=' 00005950 LRECL DC CL6' ' 00006000 DC C' RECFM=' 00006050 RECFM DC CL5' ' 00006100 ACCESS DC CL8' ',C' ACCESS METHOD' 00006150 DC C' MACRF=(' 00006200 MACRF DC CL14' ' 00006250 LEN2 EQU *-LINE2 00006300 DC (133-LEN2)C' ' 00006350 SPACE 1 00006400 LINE3 DC 0D'0',C'0' 00006450 DC C' BFALN=' 00006500 BFALN DC CL5' ' 00006550 DC C' BFTEK=' 00006600 BFTEK DC CL1' ' 00006650 DC C' BUFCB=' 00006700 BUFCB DC CL6' ' 00006750 DC C' BUFL=' 00006800 BUFL DC CL6' ' 00006850 DC C' BUFNO=' 00006900 BUFNO DC CL4' ' 00006950 LEN3 EQU *-LINE3 00007000 DC (133-LEN3)C' ' 00007050 SPACE 1 00007100 LINE4 DC 0D'0',C'0' 00007150 DC C' DSORG=' 00007200 DSORG DC CL3' ' 00007250 DC C' EODAD=' 00007300 EODAD DC CL6' ' 00007350 DC C' EROPT=' 00007400 EROPT DC CL3' ' 00007450 DC C' OPTCD=' 00007500 OPTCD DS CL8 00007550 LEN4 EQU *-LINE4 00007600 DC (133-LEN4)C' ' 00007650 ALIGN DC CL8' ',CL8'F-DCB',CL8'D',CL8'F-DD' 00007700 TECH DC C' ERES A ' 00007750 FORMATS DC C' VFU' RECORD FORMATS 00007800 PCCC DC C' MA ' PRINTER CARRIAGE CONTROL CHAR 00007850 BLANKS DC 256C' ' 00007900 ORGANS DC C' ISPSDA******POU **' 00007950 ERRORS DC C' ACC SKP ABE ',6C'*** ' 00008000 EJECT 00008050 BASE2 LA A,8 00008100 BTEST LA B,POWERS(A) 00008150 CLC 0(1,B),0(1) 00008200 BE BOKAY 00008250 BCT A,BTEST 00008300 LA A,9 00008350 BOKAY LR 1,A 00008400 BR 14 00008450 POWERS DC AL1(0,128,64,32,16,8,4,2,1) 00008500 SAVEPARM DS A PARM LIST ADRS 00008550 ENDDCB DS A END OF D-C-B 00008600 HEADER2 DC CL133'0CORE IMAGE +0 +4 +8 +12(\00008650 C)' 00008700 DUMPLINE DC CL133' DD(XX)' 00008750 * 00008800 LTORG 00008850 DMPCND1 DC A(DCBCIND1-IHADCB,CINDOUT+10,CND1LST1,49,133) 00008900 DMPCND2 DC A(DCBCIND2-IHADCB,CINDOUT+76,CND2LST1,49,133) 00008950 CND1LST1 DC A(CND1LST2),X'80',X'80',CL50'TRACK OVERFLOW - NO DATA WR\00009000 ITTEN' 00009050 CND1LST2 DC A(CND1LST3),X'40',X'40',CL50'SEARCH DIRECT' 00009100 CND1LST3 DC A(CND1LST4),X'20',X'20',CL50'END OF VOLUMNE - EOB' 00009150 CND1LST4 DC A(CND1LST5),X'10',X'10',CL50'END OF VOLUMNE - CHANNEL EN\00009200 D APPENDAGE' 00009250 CND1LST5 DC A(CND1LST6),X'01',X'01',CL50'EXCHANGE BUFFERING SUPPORTE\00009300 D' 00009350 CND1LST6 EQU 0 00009400 CND2LST1 DC A(CND2LST2),X'80',X'80',CL50'STOW PREFORMED' 00009450 CND2LST2 DC A(CND2LST3),X'40',X'40',CL50'LAST I/O WAS WRITE RECORD 0\00009500 ' 00009550 CND2LST3 DC A(CND2LST4),X'20',X'20',CL50'CLOSE IN PROGRESS' 00009600 CND2LST4 DC A(CND2LST5),X'10',X'10',CL50'PERMANENT I/O ERROR' 00009650 CND2LST5 DC A(CND2LST6),X'08',X'08',CL50'OPEN ACQUIRED BUFFER POOL' 00009700 CND2LST6 DC A(CND2LST7),X'04',X'04',CL50'CHAINED SCHEDULING SUPPORTE\00009750 D' 00009800 CND2LST7 DC A(CND2LST8),X'02',X'02',CL50'F-E-O-V BIT' 00009850 CND2LST8 DC A(CND2LST9),X'01',X'01',CL50'THIS IS A QSAM DCB' 00009900 CND2LST9 EQU 0 00009950 CINDSAVE DC C'0',CL66'DCBCIND1',CL66'DCBCIND2' 00010000 CINDOUT DS 8CL133 00010050 SPACE 00010100 DMPOPTCD DC A(DCBOPTCD-IHADCB,OPTCD,OPTCD1,0,1) 00010150 OPTCD2 DC A(OPTCD3),X'40',X'40',C'U' 00010200 OPTCD3 DC A(OPTCD4),X'20',X'20',C'C' 00010250 OPTCD4 DC A(OPTCD5),X'10',X'10',C'H' 00010300 OPTCD5 DC A(OPTCD6),X'08',X'08',C'Q' 00010350 OPTCD6 DC A(OPTCD7),X'04',X'04',C'Z' 00010400 OPTCD7 DC A(OPTCD8),X'02',X'02',C'T' 00010450 OPTCD8 EQU 0 00010500 SPACE 1 00010550 MAC1BS1 DC A(MAC1BS2),X'2020',C'R' 00010600 MAC1BS2 DC A(MAC1BS3),X'0404',C'P' 00010650 MAC1BS3 DC A(MAC1BS4),X'0202',C'C' 00010700 MAC1BS4 EQU 0 00010750 SPACE 1 00010800 MAC2BS1 DC A(MAC2BS2),X'2020',C'W' 00010850 MAC2BS2 DC A(MAC2BS3),X'0808',C'L' 00010900 MAC2BS3 DC A(MAC2BS4),X'0404',C'P' 00010950 MAC2BS4 DC A(MAC2BS5),X'0202',C'C' 00011000 MAC2BS5 DC A(MAC2BS6),X'0101',C'X' 00011050 MAC2BS6 EQU 0 00011100 SPACE 1 00011150 MAC1QS1 DC A(MAC1QS2),X'4040',C'G' 00011200 MAC1QS2 DC A(MAC1QS3),X'1010',C'M' 00011250 MAC1QS3 DC A(MAC1QS4),X'0808',C'L' 00011300 MAC1QS4 DC A(MAC1QS5),X'0404',C'T' 00011350 MAC1QS5 DC A(MAC1QS6),X'0202',C'C' 00011400 MAC1QS6 DC A(MAC1QS7),X'0101',C'D' 00011450 MAC1QS7 EQU 0 00011500 SPACE 1 00011550 MAC2QS1 DC A(MAC2QS2),X'4040',C'P' 00011600 MAC2QS2 DC A(MAC2QS3),X'1010',C'M' 00011650 MAC2QS3 DC A(MAC2QS4),X'0808',C'L' 00011700 MAC2QS4 DC A(MAC2QS5),X'0404',C'T' 00011750 MAC2QS5 DC A(MAC2QS6),X'0202',C'C' 00011800 MAC2QS6 DC A(MAC2QS7),X'0101',C'D' 00011850 MAC2QS7 EQU 0 00011900 END 00011950