* * SITE INSTALLED PHONETIC ROUTINE * 02/02/87 * RALPH PARTLOW, DAVID GAHRING * LA TIMES * FIXED ON 5/9/89 BY BARRY LIPSKER * CHANGED ON 6/10/99 BY PHIL WASON ADAUX3 CSECT ADAUX3 AMODE 31 ADAUX3 RMODE 24 USING ADAUX3,12 STM 14,12,12(13) LR 12,15 L 6,0(1) GET A(LENGTH) * DE-COMMENT THIS LINE TO TEST IN NATURAL L 6,0(6) GET ACTUAL LENGTH L 7,4(1) GET ADDRESS OF WORD L 7,0(7) LOADCODE LA 8,CODE GET ADDRESS OF RESULT MVC WORK(20),=20C' ' MVC CODET(4),=20C' ' * DE-COMMENT THIS LINE TO TEST IN NATURAL * L 8,8(1) **** TEMP FOR NAT TEST ST 8,8(1) STORE IN EXPECTED LOCATION LA 9,20 MAXIMUM OF TWENTY BYTES CR 9,6 COMPARE BYTES SENT BH USELGTH IF 20 OR LESS USE LENGTH LR 6,9 OTHERWISE USE 20 USELGTH SR 5,5 CLEAR REG 5 LR 9,6 BCTR 9,0 ST 5,CODET CLEAR TEMP CODE AREA ST 5,CODE AND FINAL AREA EX 9,MOVEWORK * MVC WORK,0(7) MOVE WORD TO WORK OI WORK,X'40' SET FIRST BYTE TO UPPER CASE OI WORK+1,X'40' AND SECOND BYTE CLI WORK,X'40' IS FIRST BYTE BLANK? BE NOMOVE YES - GO DIRECTLY TO TRANSLATE * * IF STREET NAME IS NUMERIC USE UP TO SIX POSITIONS AS THE PHONETIC KEY * TM WORK,X'F0' IS FIRST POS NUMERIC BNO NONUMLP NO - DO SOUNDEX MVC CODET(1),WORK GRAB FIRST BYTE CH 6,=H'1' IS WORD MORE THAN ONE BYTE BNH NUMPK NO - DONT LOOK AT SECOND BYTE TM WORK+1,X'F0' IS SECOND BYTE NUMERIC BNO NUMPK NO GO PACK IT MVC CODET+1(1),WORK+1 GRAB SECOND BYTE NUMPK PACK CODE(2),CODET(3) ESTABLISH FIRST POS OF CODE MVI CODE+1,X'00' CLEAR TRAILING BYTE ST 5,CODET CLEAR TEMP FIELD CH 6,=H'2' SEE IF MORE THAN 2 BYTES BNH LOOPEND END OF NUMERIC LOOP LR 9,6 GET LENGTH FOR LOOP CONTROL SH 9,=H'2' BACK OFF TWO POSITIONS TM WORK+1,X'F0' WAS SECOND BYTE NUMERIC BNO LOOPEND NO - DONT LOOP LA 3,CODET+1 POINT TO 2ND BYTE OF TEMP FLD LA 4,CODET+3 AND LAST BYTE LA 5,WORK+2 POINT TO NEXT BYTE OF WORD NUMLOOP TM 0(5),X'F0' IS THIS POS NUMERIC BNO LOOPEND NO - GO NO FURTHER MVC 0(1,3),0(5) YES - GRAB IT LA 5,1(5) BUMP TO NEXT BYTE OF WORD CR 3,4 IS THIS THE END OF CODE BE LOOPEND YES - ALL DONE LA 3,1(3) BUMP TO NEXT POS OF TEMP CODE BCT 9,NUMLOOP GO THROUGH ENTIRE WORD B LOOPEND WHEN DONE - ALL DONE MOVEWORK MVC WORK(0),0(7) *** EXECUTED *** * * THE FOLLOWING TWO LOOPS ARE USED TO TRANSLATE THE FIRST ONE OR TWO * POSITIONS OF THE WORD TO A PHONETIC VALUE - PREVIOUS TO RUNNING THE * ENTIRE WORD THROUGH THE STANDARD 'SOUNDEX' ALOGRITHM. THE TWO * CHARACTER TABLE IS CHECKED FIRST AS IT MIGHT OVERRIDE AN EFFECT * OF THE ONE CHARACTER CHECK. * NONUMLP EQU * LA 3,TWOSTBL GET BEG OF TWO LTR TABLE L 4,TWOSLGTH AND NUMBER OF ENTRIES LA 9,WORK GET ADDRESS OF WORD CH 6,=H'1' IS LENGTH ONLY ONE BE DOONESLP YES - DONT CHECK TWOS TABLE TWOSLP CLC 0(2,9),0(3) CHECK TABLE ENTRY AGAINST WORD BNE TWOSAGN NOT SAME - DONT REPLACE MVC 0(2,9),2(3) MOVE IN REPLACEMENT LETTERS TWOSAGN EQU * LA 3,4(3) BUMP TO NEXT ENTRY BCT 4,TWOSLP GO THROUGH WHOLE TABLE DOONESLP LA 3,ONESTBL NOW DO ONE LETTER TABLE L 4,ONESLGTH NUMBER OF ENTRIES ONESLP CLC 0(1,9),0(3) CHECK ONE LETTER AGAINST TABLE BNE ONESAGN NO GOOD MVC 0(1,9),1(3) GOT A HIT - REPLACE IT ONESAGN EQU * LA 3,2(3) BUMP TO NEXT ENTRY BCT 4,ONESLP AND DO WHOLE TABLE * * NOW DO STANDARD SOUNDEX ON RESULT * MVC CODE(1),WORK MOVE FIRST BYTE TO CODE NOMOVE TR WORK,TRTABLE TRANSLATE LETTERS TO VALUES * NOW WORK WITH RESULTS LR 9,6 GET LENGTH OF WORD BCT 9,DOLOOP ONE LESS FOR LOOP B LOOPEND LENGTH WAS ONE - DONT LOOP DOLOOP LA 6,9 SET TO BLANK VAL LA 10,WORK+1 POINT TO SECOND BYTE IC 5,WORK GET VALUE OF 1ST LTR FOR LAST LA 4,CODET+1 POINT TO 2ND BYTE OF CODE LA 3,CODET+4 POINT TO LAST BYTE OF CODE LOOP1 EQU * SR 11,11 CLEAR REG 11 IC 11,0(10) GRAB NEXT BYTE OF WORD LTR 11,11 SEE IF IT WAS A ZERO VALUE LTR BZ LOOP23 IF ZERO WE DONT WANT IT CR 11,6 WAS CHAR A BLANK BE LOOPSM YES - IGNORE IT CR 5,11 SEE IF SAME AS LAST VAL BE LOOPSM YES - DONT WANT IT LR 5,11 NOT SAME - SAVE AS LAST STC 11,0(4) AND STORE IT IN CODE LA 4,1(4) BUMP CODE ADDRESS CR 3,4 ARE WE AT END OF CODE FIELD BNH LOOPEND YES - FAR ENOUGH B LOOPSM NO - DO NEXT ONE * LOOP23 EQU * SR 5,5 LAST WAS ZERO VAL - CLEAR LAST LOOPSM LA 10,1(10) BUMP TO NEXT LETTER BCT 9,LOOP1 LOOP THROUGH ENTIRE WORD * COMPRESS CODE DOWN TO 3 BYTES LOOPEND EQU * PACK CODE+1(2),CODET+1(3) PICK UP NUMERIC VALS * DE-COMMENT THIS LINE TO TEST IN NATURAL * MVC 0(4,8),CODE **** TEMP FOR NAT TEST * * RETURN * RTN EQU * LM 14,12,12(13) SR 15,15 BR 14 * LTORG * CNOP 0,4 CODE DS CL4 CODET DS CL4 ONESLGTH DC F'1' TWOSLGTH DC F'14' * WORK DS CL20 ONESTBL DC C'XZ' TWOSTBL DC C'PHFAPFFAGFFAKNNAGNNAPNNATZZATSZAWRRAPSSACAKA' DC C'MNNUCUKUCOKO' TRTABLE DS 0CL256 DC 64X'00' DC X'09' DC 64X'00' * - A.B.C.D.E.F.G.H.I. LOWERCASE DC X'000102030001020000' DC 7X'00' * - J.K.L.M.N.O.P.Q.R. LOWERCASE DC X'020204050500010206' DC 8X'00' * - S.T.U.V.W.X.Y.Z. LOWERCASE DC X'0203000100020002' DC 23X'00' * - A.B.C.D.E.F.G.H.I. UPPERCASE DC X'000102030001020000' DC 7X'00' * - J.K.L.M.N.O.P.Q.R. UPPERCASE DC X'020204050500010206' DC 8X'00' * - S.T.U.V.W.X.Y.Z. UPPERCASE DC X'0203000100020002' DC 22X'00' * PATCH DC 200X'00' END