SRT TITLE 'DMSSRT (CMS) VM/370 - RELEASE 6' 00001000 SPACE 2 00002000 *. 00003000 * 00004000 * 00005000 * 00006000 * 00007000 * MODULE NAME: 00008000 * 00009000 * DMSSRT (SORT) 00010000 * 00011000 * FUNCTION: 00012000 * 00013000 * TO ARRANGE RECORDS WITHIN A FILE IN A DESCENDING 00014000 * SEQUENTIAL ORDER. 00015000 * 00016000 * ATTRIBUTES: 00017000 * 00018000 * DISK RESIDENT 00019000 * 00020000 * ENTRY POINTS: 00021000 * 00022000 * DMSSRT - 00023000 * 00024000 * ENTRY CONDITIONS: 00025000 * 00026000 * GPR1 = A(PLIST) 00027000 * 00028000 * PLIST DC CL8'SORT' 00029000 * DC CL16'FILEID1' FILENAME,FILETYPE,FILEMODE 00030000 * DC CL16'FILEID2' FILENAME,FILETYPE,FILEMODE 00031000 * DC XL8'FENCE' 00032000 * 00033000 * EXIT CONDITIONS: 00034000 * 00035000 * NORMAL - GPR15 = 0 00036000 * 00037000 * ERROR - GPR15 = NON-ZERO 00038000 * 20 INVALID '*' IN FILEID 00039000 * 24 INVALID PARAMETER 00040000 * 24 INCOMPLETE FILEID 00041000 * 28 INPUT FILE1 NOT FOUND 00042000 * 24 INCOMPLETE SORT FIELD PAIR DEFINITION 00043000 * 24 SORT COLUMN EXCEEDS RECORD LENGTH 00044000 * 32 INPUT FILE NOT FIXED FORMAT 00045000 * 24 FILEID 1 & 2 IDENTICAL 00046000 * 24 NO LIST ENTERED 00047000 * 24 INVALID DISK MODE 00048000 * 36 OUTPUT DISK IS READ/ONLY 00049000 * 36 TARGET DISK NOT ACCESSED @VA12416 00049250 * 40 MAX NUMBER OF RECORDS EXCEEDED 00049500 * 100 ERROR READING/WRITING FILE 00050000 * 00051000 * EXTERNAL REFERENCES: 00052000 * 00053000 * DMSCWR, DMSBWR, DMSBRD, DMSSTT 00054000 * DMSFRE, DMSFNS, DMSCRD, DMSERR 00055000 * 00056000 * REGISTER USAGE: 00057000 * 00058000 * BASE = GPR12 00059000 * WORK REGISTER = ALL OTHERS 00060000 * 00061000 * OPERATION: 00062000 * 00063000 * FROM THE REQUESTED FIELD DEFINITIONS, SORT SETS UP AN 00064000 * ORDERED SERIES OF MVC'S AT THE BEGINNING OF THE FREE 00065000 * AREA, IN WHICH THE 'FROM' FIELD IS INPUT RECORD FIELD 00066000 * LOCATION, THE LENGTH IS THE LENGTH OF THE FIELD, AND 00067000 * THE 'TO' LOCATION IS THE START OF THE DISTRIBUTION 00068000 * BUFFER PLUS THE LENGTH OF ANY FIELDS WHICH HAVE COME 00069000 * BEFORE. THUS, A PRIMARY FIELD OF LENGTH 5 WOULD BE 00070000 * MOVED INTO DISTRIBUTION BUFFER LOCATION 0, WHILE THE 00071000 * SECONDARY FIELD, IF ANY WOULD BE MOVED INTO 00072000 * DISTRIBUTION BUFFER LOCATION 0 PLUS 5. THUS A SINGLE 00073000 * CONTIGUOUS SORT ELEMENT IS CREATED WHOSE LENGTH IS 00074000 * THE TOTAL LENGTH OF ALL THE FIELDS. 00075000 * 00076000 * RECORDS ARE READ IN ONE AT A TIME INTO CONTIGUOUS 00077000 * AREAS OF STORAGE. A SORT ELEMENT IS CREATED WHICH IS 00078000 * THEN PLACED IN ASCENDING ORDER IN A SORT TREE, WHERE 00079000 * EACH ENTRY HAS THE FOLLOWING FORMAT: 00080000 * 00081000 * DC AL3(LOW) 00082000 * DC AL3(HIGH) 00083000 * DC AL3(BACK) 00084000 * DC XL1(FLAG) 00085000 * DC AL2(CNT) 00086000 * DC AL ELEMENT LENGTH PLUS 2 BYTES FOR ITEM NO. 00087000 * 00088000 * LOW IS ADDRESS OF NEXT LOWER ENTRY 00089000 * HIGH IS ADDRESS OF NEXT HIGHER ENTRY 00090000 * BACK IS BACK POINTER TO PREVIOUS ENTRY 00091000 * FLAG IS USED IN UNWINDING THE TREE TO MARK A DELETED ELEM 00092000 * CNT INDICATES NUMBER OF DUPLICATES 00093000 * 00094000 * WHEN THE TREE HAS BEEN COMPLETED, THE CHAIN IS 00095000 * SEARCHED FOR THE LOWEST ELEMENT, WHICH IS SIGNIFIED 00096000 * BY A LOW FIELD OF ALL ZEROS. THE FLAG IS SET TO 00097000 * 'USED'. RDBUF IS CALLED WITH THE ITEMNO WHICH WAS 00098000 * SAVED IN THE MODE. WRBUF WRITES THE RECORD OUT ON 00099000 * DISK. THE CHAIN IS THEN UNWOUND UPWARDS, WITH EACH 00100000 * DELETED ENTRY BEING FLAGGED AND THE CORRESPONDING 00101000 * RECORD WRITTEN OUT, UNTIL THE ENTIRE TREE IS 00102000 * EXHAUSTED AND THE SORTED FILE IS WRITTEN. THE INPUT 00103000 * AND OUTPUT FILES ARE CLOSED, STORAGE IS RELEASED, THE 00104000 * PAGES RELEASED, AND CONTROL IS PASSED BACK TO THE 00105000 * CALLER. 00106000 * 00107000 *. 00108000 EJECT 00109000 DMSSRT START X'0' 00110000 USING DMSSRT,R12 00111000 LR R12,R15 00112000 ST R14,CMSRET 00113000 DMSKEY NUCLEUS DISABLE NUCLEUS PROTECT 00114000 USING NUCON,R0 00115000 MVC DOSF(1),DOSFLAGS SAVE CURR. SET OF DOSFLAGS @V305001 00115100 NI DOSFLAGS,255-DOSSVC TURN DOSSVC FLAF OFF @V305001 00115200 CLI 8(1),X'FF' 00116000 BE ERR54E 00117000 CLI 8(R1),C'*' 00118000 BE ERR62I '*' IS NO-NO IN FILEID 00119000 CLI 16(1),X'FF' 00120000 BE ERR54E 00121000 CLI 16(R1),C'*' 00122000 BE ERR62I 00123000 CLI 24(1),X'FF' 00124000 BE ERR54E 00125000 CLI 32(1),X'FF' RAM 00126000 BE ERR54E 00127000 CLI 32(R1),C'*' 00128000 BE ERR62O NO '*' IN OUT FILEID EITHER 00129000 CLI 40(R1),X'FF' 00130000 BE ERR54E 00131000 CLI 40(R1),C'*' 00132000 BE ERR62O 00133000 CLI 48(R1),X'FF' 00134000 BE ERR54E 00135000 CLC 48(2,R1),RDMODE CHECK WRITE MODE FOR '*' 00136000 BNE GARCHK 00137000 MVC 48(2,R1),WRMODE IF SO, FORCE 'A1' MODE 00138000 GARCHK CLI 56(R1),X'FF' CHEK XTRA OPTIONS 00139000 BNE ERR70E ERROR IF ANY MORE 00140000 * 00141000 LR R2,R1 SAVE COMMAND PLIST PTR 00142000 MVC RDFN(18),8(R1) MOVE IN THE INPUT FILEID 00143000 MVC WRFN(18),32(R1) MOVE IN OUTPUT FILEID 00144000 LA 1,RDPLST CALL STATE FOR INPUT 00145000 SVC 202 00146000 DC AL4(*+4) 00147000 LTR R15,R15 00148000 BZ FSTAD FILE FOUND WITH NO PROBLEMS 00149000 CH R15,=H'28' 00150000 BE ERR2E FILE NOT FOUND 00151000 CH R15,=H'36' DISK NOT ACCESSED @VA12416 00151100 LA R2,RDMODE POINT TO DISK MODE @VA12416 00151200 BE ERRMSG36 YES, ISSUE MSG69E @VA12416 00151300 B ERET DISK OR SYNTAX ERROR 00152000 FSTAD L 2,DATABF GET FST ADDRESS 00153000 CLI 30(2),C'F' IS IT FIXED LENGTH? 00154000 BNE ERR34E 00155000 L 3,32(,2) GET RECORD SIZE 00156000 ST 3,INSIZE PUT IT INTO PLIST 00157000 STATEOUT LA 1,WRPLST NOW FIND OUT IF OUTPUT ALREADY EXISTS 00158000 SVC 202 00159000 DC AL4(*+4) 00160000 LTR R15,R15 00161000 BZ CHKSAME FILE FOUND, ERASE IT 00162000 CH R15,=H'28' 00163000 BE NOTTHERE FILE NOT FOUND 00164000 CH R15,=H'36' DISK NOT ACCESSED @VA12416 00164100 LA R2,WRMODE POINT TO DISK MODE @VA12416 00164200 BE ERRMSG36 YES, ISSUE MSG69E @VA12416 00164300 B ERET DISK OR SYNTAX ERROR 00165000 CHKSAME EQU * @VA09700 00166000 CLC WRFN(17),RDFN INPUT/OUTPUT FILES THE SAME.? @VA09700 00166500 BE ERR19E YES 00167000 MVC WROPTN(8),=CL8'ERASE' 00168000 L 2,WRBUF GET FST ADDRESS 00169000 LA 1,WRPLST GO ERASE THE OLD FILE 00170000 SVC 202 00171000 DC AL4(*+4) 00172000 B SAMESIZE 00173000 NOTTHERE LA R1,WRPLST 00174000 L R15,VCADTLKW GET ADDRESS OF ADTLKW. @VM03093 00175100 BALR R14,R15 00176000 BC 2,ERR37E 00177000 SAMESIZE MVC WRSIZE(4),INSIZE AND SAME RECORD SIZE 00178000 LR R1,R2 RESTORE PLIST POINTR 00179000 * 00180000 CLI WRMODE+1,C' ' BLANK MODE NUMBER? P3037 00181000 BNE SKIP P3037 00182000 MVI WRMODE+1,C'1' IF SO, DEFAULT '1' P3037 00183000 SKIP EQU * P3037 00184000 CLI WRMODE,C'*' CAN'T WRITE TO '*' 00185000 BNE R604 00186000 MVC WRMODE(2),=CL2'A1' FORCE WRITES TO A-DISK 00187000 R604 DS 0H HRC323DS 00187020 LH R15,NUMFINRD get number of lines in the stack HRC323DS 00187040 LTR R15,R15 HRC323DS 00187060 BNZ NOTYPE skip next msg if line in stack HRC323DS 00187080 DMSERR NUM=604,LET=R,TEXT='Enter sort fields: ',DOT=NO RC323DS 00188000 * WHILE TYPING, SETUP FREE CORE 00189000 NOTYPE DS 0H HRC323DS 00189020 L R15,ASTRINIT CALL 'STRINIT 00190000 BALR 14,15 00191000 GETMAIN VU,LA=LENGTHS,A=GENBUF GET ALL STORAGE WE CAN @VA04199 00196000 L R1,GENBUF GET STARTING FREE ADDRESS @VA04199 00197000 A 1,FREESIZE COMPUTE END OF CORE 00198000 BCTR 1,0 SUBTRACT 1 00199000 ST 1,AFREEND PLACE IT INTO THE 'TREE' PLIST 00200000 LA R1,CONRDLST READ FIELDS FROM TERMINAL 00201000 SVC 202 00202000 DC AL4(*+4) 00203000 B CONTINUE 00204000 CONRDLST DS 0D 00205000 DC CL8'WAITRD' 00206000 DC AL1(1) 00207000 DC AL3(CONBUF) 00208000 DC C'U' 00209000 NCH DC AL3(0) 00210000 CONTINUE DS 0H 00211000 LH 3,NCH+1 GET NUMBER OF CHARACTERS READ 00212000 LTR 3,3 00213000 BZ ERR63E IF ZERO, NULL LINE 00214000 ST 3,SCNCH NON-ZERO, SET LENGTH FOR SCAN 00215000 LA 1,SCNCH SET R1 FOR 'SCAN' 00216000 L 15,ASCANO CALL SCAN 00217000 BALR 14,15 00218000 EJECT 00219000 L 5,GENBUF 00220000 SR 6,6 SET STARTING 'TO' DISPLACEMENT 00221000 GENLP CLI 0(1),X'FF' DOES FIRST OF PAIR EXIST? 00222000 BE ENDLINE NO, GO CLEANUP AND START 00223000 CLI 8(1),X'FF' DOES SECOND OF PAIR EXIST? 00224000 BE ERR53E NO, ERROR 00225000 L 4,0(,1) GET 'SC' 00226000 BAL 14,BD2BN GO CONVERT IT 00227000 ST 4,SC SAVE IT 00228000 L 4,8(,1) GET 'EC' 00229000 BAL 14,BD2BN GO CONVERT IT 00230000 S 4,SC COMPUTE 'MVC' COUNT FIELD 00231000 BM ERR53E IF MINUS, ERROR 00232000 MVC 0(L'MVC,5),MVC MOVE INTO FREE CORE THE MVC 00233000 STC 4,1(,5) INSERT THE COUNT FIELD 00234000 STC 6,3(,5) SET 'TO' DISPLACEMENT 00235000 LA 6,1(4,6) UPDATE THE TO DISP. 00236000 L 7,SC GET 'SC' 00237000 BCTR 7,0 REDUCE BY 1 00238000 LH 8,4(,5) GET MVC FROM FIELD 00239000 OR 8,7 'OR' IN THE FROM DISP. 00240000 STH 8,4(,5) PUT IT BACK INTO THE 'MVC' 00241000 LA 5,L'MVC(,5) 00242000 LA 1,16(,1) UPDATE PARAM POINTER 00243000 B GENLP 00244000 * 00245000 MVC MVC *-*(*-*,3),*-*(2) DUMMY MVC FOR GENERATION 00246000 BR BR 9 DUMMY BR FOR GENERATION 00247000 SC DS F SUBFIELD STARTING CHARACTER 00248000 EJECT 00249000 ENDLINE MVC 0(L'BR,5),BR MOVE THE BRANCH CODE INTO CORE 00250000 LA 5,L'BR(,5) UPDATE R5 00251000 ST 5,AFREES SAVE NEW FREE ADDRESS 00252000 L 3,INSIZE SETUP BUFFER SPACE 00253000 L 4,AFREES 00254000 ST 4,DATABF 00255000 ST 4,WRBUF 00256000 AR 4,3 COMPUTE NEW FREE AREA ADDRESS 00257000 MVC RDOPTN,=CL8'RDBUF' SET PLIST FOR READ 00258000 MVC WROPTN,=CL8'WRBUF' AND WRITE 00259000 ST 4,DBUF SET DISTRIBUTION BUFFER ADDRESS 00260000 C R6,=F'253' SORT FIELD > 253 00261000 BH ERR53E YES, ERROR 00262000 ST 6,FLDLEN SAVE ACTUAL SORT FIELD LENGTH 00263000 STC 6,MVCITMNO+3 SET DISP. FOR ITMNO MVC 00264000 LA 6,2(,6) UPDATE BUFFER LENGTH FOR ITMNO 00265000 STC 6,DBUF SET IT INOT THE 'TREE' PLIST 00266000 AR 4,6 COMPUTE NEW FREE ADDRESS 00267000 ST 4,AFREES 00268000 LA 9,MVCITMNO SET R9 FOR GENERATED 'BR' 00269000 L 10,GENBUF SET R10 FOR BRANCH INTO GENERATED 'MVC'S 00270000 EJECT 00271000 L 3,DBUF GET DISTRIBUTION BUFFER ADDRESS 00272000 L 2,DATABF GET DATA BUFFER ADDRESS 00273000 RDLP LA 1,RDPLST CALL RDBUF FOR AN INPUT RECORD 00274000 SVC 202 .. 00275000 DC AL4(*+4) .. 00276000 LH 4,RCNT UPDATE INPUT ITEM NO. 00277000 LA 4,1(,4) .. 00278000 STH 4,RCNT .. 00279000 LTR 15,15 ANY READ ERRORS? 00280000 BCR 8,10 NO, GO MOVE SORT FIELDS TO 'DBUF' 00281000 CH 15,=H'12' YES, IS IT EOF? 00282000 BNE ERR104S NO, BAD NEWS 00283000 BCTR 4,0 REDUCE COUNT BY ONE 00284000 EOF L 2,FLDLEN YES, SET R2 TO TOTAL SORT FIELD LENGTH 00285000 WRTLP LA 1,ATREE GET 'TSRCH' PLST ADDRESS 00286000 BAL R14,TSRCH 00287000 LTR 15,15 WAS AN ELEMENT GOTTEN? 00288000 BNZ FINIS NO, WE ARE ALL FINISHED 00289000 LA 3,12(1,2) YES, SET R3 TO ADDRESS OF ITEMNO 00290000 MVC INITMNO(2),0(3) AND MOVE IT TO READ PLIST 00291000 LA 1,RDPLST NOW GO READ THAT ITEM INTO CORE 00292000 SVC 202 .. 00293000 DC AL4(ERR104S) ANY ERRORS NOW ARE BAD 00294000 LA 1,WRPLST NOW WRITE THE RECORD OUT SEQUENTALLY 00295000 SVC 202 .. 00296000 DC AL4(ERR105S) SO ARE WRITE ERRORS 00297000 B WRTLP GO BACK FOR NEXT RECORD 00298000 * 00299000 MVCITMNO MVC *-*(2,3),RCNT SORT FIELD MOVED, GET CURRENT ITMNO 00300000 LA 1,TPLST NOW CALL 'TREE' WITH ITS PLIST 00301000 BAL 14,TREE 00302000 LTR 15,15 WAS ELEMENT PROCESSED CORRECTLY? 00303000 BZ RDLP YES, GO GET RECORD FOR NEXT ELEMENT 00304000 B ERR212E @VA01057 00305000 FINIS MVC RDOPTN,=CL8'FINIS' CLOSE INPUT FILE 00306000 LA 1,RDPLST .. 00307000 SVC 202 00308000 DC AL4(*+4) .. 00309000 MVC WROPTN,=CL8'FINIS' CLOSE OUTPUT FILE 00310000 LA 1,WRPLST .. 00311000 SVC 202 .. 00312000 DC AL4(*+4) .. 00313000 FREEMAIN V,A=GENBUF RELEASE OUR FREE STORAGE @VA04199 00315000 RET SR 15,15 CLEAR ERROR FLAGS 00317000 ERET LR R4,R15 SAVE RETURN CODE 00318000 OI MISFLAGS,RELPAGES TURN PAGE REL. FLAG ON 00319000 MVC DOSFLAGS(1),DOSF RESET DOSFLAGS @V305001 00319100 DMSKEY RESET RESTORE NUCLEUS PROTECT 00320000 L R14,CMSRET 00321000 LR R15,R4 RESTORE RETURN CODE 00322000 BR 14 00323000 BD2BN EQU * DELETE TRAILING BLANKS AND CVB 00324000 LA R2,4 4-BYTE LIMIT (REGISTER CONTENTS) 00325000 ST R4,SAV5 SAVE IT FOR COMPARES 00326000 LA R3,SAV5 00327000 VALNUM CLI 0(R3),C' ' WE'RE LOOKING FOR INVALID CHARS 00328000 BE NEXTD BLANKS WILL BE STRIPPED LATER 00329000 CLI 0(R3),C'0' 00330000 BL ERR53E HAS TO BE A NUMERIC 00331000 CLI 0(R3),C'9' BETWEEN 0 AND 9 00332000 BH ERR53E OR IT'S AN ERROR 00333000 NEXTD LA R3,1(,R3) LOOK AT NEXT CHARACTER 00334000 BCT R2,VALNUM 00335000 * EVRYTHING IS O.K. AT THIS POINT 00336000 ST R5,SAV5 SAVE FREE STORAGE POINTR 00337000 CVTLP SR R5,R5 00338000 SRDL R4,8 00339000 CL R5,=X'40000000' DROP TRAILING BLANKS AFTER ENTRY 00340000 BE CVTLP TRY ANOTHER BLANK 00341000 SLDL R4,8 ALL BLANKS OUT, SHIFT BACK 00342000 O R4,=C'0000' ZONE THE ZEROES 00343000 ST R4,DEC SET UP ZONED DIGITS 00344000 PACK DECD(8),DEC(4) FOR PACKING AND 00345000 CVB R4,DECD CONVERSION TO BINARY 00346000 C R4,INSIZE SORT ENTRY > LRECL? 00347000 BH ERR9E YES, ERROR 00348000 LTR R4,R4 SORT ENTRY OF '0' ILLEGAL 00349000 BZ ERR53E 00350000 L 5,SAV5 RESTORE FREE STORAGE POINTR 00351000 BR 14 00352000 SAV5 DS F 00353000 EJECT 00354000 * 00355000 * SUBROUTINE NAME - 00356000 * 00357000 * TREE 00358000 * 00359000 * FUNCTION- 00360000 * 00361000 * TO SEARCH AN ORDERED DISTRIBUTION TREE FOR A PARTICULAR 00362000 * ELEMENT. 00363000 * 00364000 * ENTRY CONDITIONS - 00365000 * 00366000 * GPR15 - A($$$SRRA) 00367000 * GPR1 - A(PLIST) 00368000 * PLIST - AL1(LENGTH),AL3(ELEMENT) 00369000 * XL1'TFLAG' 00370000 * AL3(ATREE) 00371000 * A(STRTFREE) 00372000 * A(ENDFREE) 00373000 * 00374000 * WHERE: 00375000 * LENGTH - NO. OF CHARACTERS IN ELEMENT FIELD 00376000 * ELEMENT - ADDRESS OF ELEMENT TO SEARCH FOR 00377000 * TFLAG - A SWITCH FLAG TO INDICATE: 00378000 * 80 - THE TREE HAS AT LEAST ONE ENTRY 00379000 * 00 - THE TREE IS EMPTY 00380000 * ATREE - STARTING ADDRESS OF THE SEARCH TREE; 00381000 * WILL BE SET BY 'TREE' DURING FIRST 00382000 * ENTRY TO VALUE IN 'STRTFREE'. 00383000 * STRTFREE - ADDRESS OF LOWEST FREE CORE BYTE 00384000 * INTO WHICH 'ATREE' MAY EXPAND. 'TREE' 00385000 * WILL UPDATE THIS ADDRESS EACH TIME A 00386000 * NEW ELEMENT IS BUILT. 00387000 * ENDFREE - ADDRESS OF HIGHEST FREE CORE BYTE 00388000 * INTO WHICH 'ATREE' MAY EXPAND. 00389000 * 00390000 * EXIT CONDITIONS - 00391000 * 00392000 * NORMAL - 00393000 * GPR15 = 0 : ELEMENT PROCESSED CORRECTLY 00394000 * 00395000 * ERROR - 00396000 * GPR15 = 4 : ELEMENT NOT FOUND AND NO CORE AVAILABLE 00397000 * TO CREATE A NEW ELEMENT IN THE TABLE 00398000 * 00399000 * 00400000 * TABLES | WORKAREAS - 00401000 * 00402000 * TREE TABLE ENTRY FORMAT: 00403000 * 00404000 * AL3(LOW) ADDRESS OF LOWER ELEMENT OR ZERO 00405000 * AL3(HIGH) ADDRESS OF HIGHER ELEMENT OR ZERO 00406000 * AL3(BACK) ADDRESS OF PREVIOUS NODE 00407000 * XL1(FLAG) ATTACHED|DETACHED FLAG 00408000 * AL2(CNT) FREQUENCY COUNT FOR ELEMENT 00409000 * CL(LENGTH)'EE...EE' 00410000 * 00411000 * REGISTER USAGE - 00412000 * 00413000 * GPR2 - A(ELEMENT) 00414000 * GPR3 - LENGTH OF ELEMENT 00415000 * GPR4 - A(TREE) 00416000 * GPR5 - A(FREE) FOR TREE BUILD 00417000 * GPR14 - RETURN 00418000 * GPR15 - ERROR CODE RETURN 00419000 * 00420000 * OPERATION - 00421000 * 00422000 * IF THE ELEMENT IS FOUND DURING THE SEARCH, A FREQUENCY COUNT 00423000 * IS UPDATED; IF IT IS NOT FOUND, A NEW ELEMENT IS CREATED. 00424000 * 00425000 * 00426000 TREE DS 0H 00427000 STM R0,R14,SAVEAREA 00428000 USING TREED,4 00429000 SR 15,15 CLEAR ERROR FLAG 00430000 SR 3,3 AND R3 00431000 L 2,0(,1) R2 = A(ELEMENT) 00432000 IC 3,0(,1) R3 = LENGTH 00433000 BCTR 3,0 DECRIMENT FOR 'EX' MASK 00434000 CLI 4(1),0 NEW TREE? 00435000 BE BUILD YES, GO INSERT FIRST ENTRY 00436000 L 4,4(,1) R4 = A(TREE) 00437000 LOOP LA 6,3 SET R6 WITH HIGH FLAG 00438000 EX 3,COMPARE COMPARE SEARCH/TREE ELEMENTS 00439000 BE FOUND EQUAL? 00440000 BL GOLOW NO, LOW? 00441000 MVC NXTADR+1(3),HIGH NO, GET HIGH ELEM. ADDRESS 00442000 B JOIN 00443000 GOLOW MVC NXTADR+1(3),LOW IS LOW, GET LOW ELEM. ADDR. 00444000 SR 6,6 RESET R6 WITH LOW FLAG 00445000 JOIN L 5,NXTADR DOES NEXT TREE ELEMENT 00446000 LTR 5,5 EXIST? 00447000 BZ BUILD NO, GO BUILD ONE 00448000 LR 4,5 YES, SET R4 00449000 B LOOP AND LOOP 00450000 * 00451000 FOUND MVC ADDER,CNT ELEMENTS MATCHED 00452000 LH 6,ADDER UPDATE 00453000 LA 6,1(,6) TREE 00454000 STH 6,ADDER FREQUENCY 00455000 MVC CNT,ADDER COUNT 00456000 RET2 LM R2,R14,SAVEAREA+8 00457000 BR 14 00458000 EJECT 00459000 USING TREED,5 00460000 BUILD L 5,8(,1) ELEM. NOT IN TREE, R5=A(FREE) 00461000 LA 7,13(5,3) SET R7 TO NEW FREE ADDRESS 00462000 C 7,12(,1) CORE OVERFLOW? 00463000 BH FULL YES, GO SET ERROR FLA 00464000 ST 7,8(,1) NO, RESET A(FREE) 00465000 MVC TREED(12),INIT INITIALIZE FIXED ENTRY PORTION 00466000 EX 3,MOVE MOVE INTO ENTRY THE ELEMENT FIELD 00467000 CLI 4(1),X'80' FIRST ENTRY? 00468000 BE NORMAL NO, BRANCH 00469000 ST 5,4(,1) SET TREE ADDRESS FOR NEXT ENTRY 00470000 MVI 4(1),X'80' SET TREE CREATED SWITCH 00471000 B RET2 00472000 * 00473000 NORMAL EQU * 00474000 ST 4,BKADR 00475000 MVC BACK,BKADR+1 00476000 ST 5,NXTADR SET NEW TREE ENTRY ADDRESS 00477000 LA 4,0(6,4) IN CORRECT OLD 00478000 MVC 0(3,4),NXTADR+1 ENTRY FIELD 00479000 B RET2 00480000 FULL MVI 4(1),0 RESET TREE EXISTANCE SWITCH 00481000 LA 15,4 INDICATE FULL TABLE 00482000 B RET2 00483000 EJECT 00484000 * CONSTANTS AND FORMATS 00485000 * 00486000 NXTADR DC A(0) 00487000 BKADR EQU NXTADR 00488000 ADDER DS H 00489000 INIT DC XL12'1' 00490000 * 00491000 MOVE MVC ELEM,0(2) 00492000 DROP 5 00493000 USING TREED,4 00494000 COMPARE CLC 0(1,2),ELEM 00495000 EJECT 00496000 * 00497000 * SUBROUTINE NAME - 00498000 * 00499000 * TSRCH 00500000 * 00501000 * FUNCTION - 00502000 * 00503000 * TO FIND THE LOWEST VALUED ELEMENT IN AN ORDERED DISTRIBUTION 00504000 * TREE. 00505000 * 00506000 * ENTRY CONDITIONS - 00507000 * 00508000 * GPR15 - A($$$SRSA) 00509000 * GPR1 - A(PLIST) 00510000 * PLIST - XL1'TFLAG',A(ATREE) 00511000 * 00512000 * WHERE: 00513000 * TFLAG - A SWITCH FLAG TO INDICATE: 00514000 * 80 - THE TREE HAS AT LEAST ONE ENTRY 00515000 * 00 - THE TREE IS EMPTY 00516000 * ATREE - STARTING ADDRESS OF THE SEARCH TREE 00517000 * 00518000 * EXIT CONDITIONS - 00519000 * 00520000 * NORMAL - 00521000 * GPR15 = 0 : ELEMENT FOUND 00522000 * GPR1 = A(ELEMENT) 00523000 * 00524000 * ERROR - 00525000 * GPR15 = 4 : TREE IS EMPTY 00526000 * 00527000 * 00528000 * TABLES | WORKAREAS - 00529000 * 00530000 * TREE TABLE ENTRY FORMAT: 00531000 * 00532000 * AL3(LOW) ADDRESS OF LOWER ELEMENT OR ZERO 00533000 * 00534000 * AL3(HIGH) ADDRESS OF HIGHER ELEMENT OR ZERO 00535000 * AL3(BACK) ADDRESS OF PREVIOUS NODE 00536000 * XL1(FLAG) ATTACHED|DETACHED FLAG 00537000 * AL2(CNT) FREQUENCY COUNT FOR ELEMENT 00538000 * CL(LENGTH)'EE...EE' 00539000 * 00540000 * REGISTER USAGE - 00541000 * 00542000 * GPR2 - A(TREE) 00543000 * GPR14 - RETURN 00544000 * GPR15 - ERROR CODE RETURN 00545000 * 00546000 * OPERATION - 00547000 * 00548000 * WHEN THE ELEMENT IS FOUND DURING THE TREE SEARCH, IT IS 00549000 * DETACHED FROM THE TREE, AND THE TREE ELEMENT ADDRESS IS 00550000 * RETURNED IN GPR1. 00551000 * 00552000 TSRCH DS 0H 00553000 STM R0,R14,SAVEAREA 00554000 DROP 4 00555000 USING TREED,2 00556000 L 2,0(,1) SET R2 TO BEGINNING OF TREE 00557000 CKLOW TM FLAG,USED HAS CURRENT ENTRY BEEN DETACHED? 00558000 BO TAKEN YES, BRANCH 00559000 MVC A+1(3),LOW NO, DOES A 00560000 L 3,A LOWER ENTRY 00561000 LTR 3,3 EXIST? 00562000 BZ FOUND2 NO, ELEMENT FOUND, GO RETURN IT 00563000 CKLOW1 LR 2,3 YES, RESET ENTRY BASE 00564000 B CKLOW AND LOOP 00565000 * 00566000 TAKEN EQU * CURRENT ENTRY HAS BEEN DETACHED 00567000 MVC A+1(3),HIGH THERE CANNOT BE ANY LOWER ENTRIES 00568000 L 3,A DOES A HIGHER ENTRY EXIST? 00569000 LTR 3,3 00570000 BZ BKCHN NO, GO BACK-CHAIN 00571000 LR 2,3 YES, RESET ENTRY BASE 00572000 TM FLAG,USED HAS THIS NODE BEEN DETACHED? 00573000 BO TAKEN YES, BRANCH 00574000 MVC A+1(3),LOW NO, DOES IT 00575000 L 3,A HAVE A LOWER NODE? 00576000 LTR 3,3 00577000 BNZ CKLOW1 YES, GO CHECK IT 00578000 * 00579000 FOUND2 EQU * ELEMENT FOUND 00580000 LR 1,2 LOAD ITS ADDRESS IN R1 00581000 MVI FLAG,USED DETACH IT FROM THE TREE 00582000 SR 15,15 CLEAR ERROR FLAG 00583000 B RET3 00584000 BKCHN1 TM FLAG,USED IS ELEMENT USED? 00585000 BZ FOUND2 NO, RETURN THIS ELEMENT TO CALLER 00586000 BKCHN EQU * SEARCH BACKWARD 00587000 MVC A+1(3),BACK THROUGH THE TREE 00588000 L 3,A FOR A NON-DETACHED 00589000 LTR 2,3 NODE. 00590000 BNZ BKCHN1 00591000 * 00592000 EMPTY LA 15,4 00593000 RET3 LM R2,R14,SAVEAREA+8 00594000 BR 14 00595000 EJECT 00596000 * CONSTANTS AND FORMATS 00597000 * 00598000 USED EQU X'80' 00599000 A DC F'0' 00600000 * 00601000 EJECT 00602000 ERR2E DMSERR NUM=2,LET=E,SUB=(CHAR8A,RDFN), *00603000 TEXT='File ''....................'' not found' HRC323DS 00604000 LA R15,28 RETURN CODE = 28 00605000 B ERET 00606000 SPACE 2 00607000 ERR9E DMSERR NUM=9,LET=E,SUB=(DEC,(R4)),TEXT='Column ''...'' exceeds*00608000 record length' HRC323DS 00609000 LA R15,24 RETURN CODE = 24 00610000 B ERET 00611000 SPACE 2 00612000 ERR19E DMSERR NUM=19,LET=E,TEXT='Identical fileids' HRC323DS 00613000 LA R15,24 RETURN CODE = 24 00614000 B ERET 00615000 SPACE 2 00616000 ERR34E DMSERR NUM=34,LET=E,SUB=(CHAR8A,RDFN), *00617000 TEXT='File ''....................'' is not fixed length' 00618000 LA R15,32 RETURN CODE = 32 00619000 B ERET 00620000 SPACE 2 00621000 ERR37E DMSERR NUM=37,LET=E,SUB=(CHARA,WRMODE), *00622000 TEXT='Disk ''..'' is read/only' HRC323DS 00623000 LA R15,36 RETURN CODE = 36 00624000 B ERET 00625000 SPACE 2 00626000 SPACE 2 00627000 ERR53E DMSERR NUM=53,LET=E,TEXT='Invalid sort field pair defined' 00628000 LA R15,24 RETURN CODE = 24 00629000 B ERET 00630000 SPACE 2 00631000 ERR54E DMSERR NUM=54,LET=E,TEXT='Incomplete fileid specified' RC323DS 00632000 LA R15,24 RETURN CODE = 24 00633000 B ERET 00634000 SPACE 2 00635000 ERR62I LA R2,8(,R1) POINT TO INPUT FILEID 00636000 B ERR62E 00637000 ERR62O LA R2,32(,R1) POINT TO OUTPUT FILEID 00638000 * 00639000 ERR62E DMSERR NUM=62,LET=E,SUB=(CHAR8A,(R2)),TEXT='Invalid ''*'' in f*00640100 ileid ''....................''' HRC323DS 00641000 LA R15,20 RETURN CODE = 20 00642000 B ERET 00643000 ERRMSG36 EQU * @VA12416 00643100 DMSERR TEXT='DISK ''..'' NOT ACCESSED',NUM=69, X00643200 LET=E,SUB=(CHARA,((R2),1)) @VA12416 00643300 LA R15,36 RETURN CODE = 36 @VA12416 00643400 B ERET @VA12416 00643500 SPACE 2 00644000 ERR70E LA R2,56(,R1) POINT TO XTRA PARM 00645000 DMSERR NUM=70,LET=E,SUB=(CHARA,(R2)),TEXT='Invalid parameter '*00646000 '........''' 00647000 LA R15,24 RETURN CODE = 24 00648000 B ERET 00649000 SPACE 2 00650000 ERR63E DMSERR NUM=63,LET=E,TEXT='No list entered' HRC323DS 00651000 LA R15,40 RETURN CODE = 40 00652000 B ERET 00653000 SPACE 2 00654000 ERR104S LR R0,R15 SAVE ERROR CODE V0314 00655000 DMSERR NUM=104,LET=S,SUB=(DEC,(R0),CHAR8A,RDFN), *00655100 TEXT='Error ''..'' reading file ''....................''*00655200 from disk',RENT=NO HRC323DS 00655300 LA R15,100 RETURN CODE = 100 00658000 B ERET 00659000 SPACE 2 00660000 ERR105S LR R0,R15 00661000 DMSERR NUM=105,LET=S,SUB=(DEC,(R0),CHAR8A,WRFN), *00662000 TEXT='Error ''...'' writing file ''....................'*00663000 ' on disk',RENT=NO HRC323DS 00664000 LA R15,100 RETURN CODE = 100 00665000 B ERET 00666000 ERR212E DMSERR NUM=212,LET=E,TEXT='Maximum number of records exceeded' 00666100 LA R15,40 RETURN CODE = 40 @VA01057 00666300 B ERET @VA01057 00666500 SPACE 2 00667000 EJECT 00668000 RDPLST DS 0D 00669000 RDOPTN DC CL8'STATE' 00670000 RDFN DS CL8 00671000 RDFT DS CL8 00672000 RDMODE DC CL2'*' 00673000 INITMNO DC H'0' 00674000 DATABF DC A(0) 00675000 INSIZE DC F'0' 00676000 DC CL2'F' 00677000 DC H'1' 00678000 DC F'0' 00679000 * 00680000 WRPLST DS 0D 00681000 WROPTN DC CL8'STATEW' CKECK FOR EXISTING FILE ON R/W DISK 00682000 WRFN DS CL8 00683000 WRFT DS CL8 00684000 WRMODE DC CL2'A1' 00685000 DC H'0' 00686000 WRBUF DC A(0) 00687000 WRSIZE DC F'0' 00688000 DC CL2'F' 00689000 DC H'1' 00690000 DC F'0' 00691000 * 00692000 TPLST DS 0F 00693000 DBUF DC AL1(*-*),AL3(*-*) 00694000 ATREE DC A(0) 00695000 AFREES DC A(0) 00696000 AFREEND DC A(0) 00697000 * 00698000 DECD DS D 00699000 DEC DS F 00700000 GENBUF DS F 00701000 FREESIZE DS F 00702000 FLDLEN DS F 00703000 RCNT DC H'0' 00704000 SCNCH DS F 00705000 CONBUF DS 130C 00706000 * 00707000 SAVEAREA DC 14F'-1' 00708000 LENGTHS DC F'4096',F'8343600' MIN/MAX LENGTHS FOR GETMAIN @VA04199 00709000 CMSRET DS F 00710000 DOSF DS X SAVE AREA FOR DOSFLAGS @V305001 00710100 * 00711000 TREED DSECT 00712000 LOW DS AL3 00713000 HIGH DS AL3 00714000 BACK DS AL3 00715000 FLAG DS XL1 00716000 CNT DS AL2 00717000 ELEM DS C 00718000 * 00719000 EJECT 00720000 REGEQU 00721000 NUCON 00722000 EJECT 00723000 END 00724000