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