./ ADD SSI=00013170,SOURCE=1,NAME=IHEABND ABN TITLE ' IHEABND STANDARD ABEND DEFAULT MODULE X02000019 OS/360 PL/1 LIBRARY' 04000019 SPACE 2 06000019 * VERSION 08000019 * RELEASE 19 VERSION 5 OF F-LEVEL PL/1 COMPILER 10000019 * 12000019 * FUNCTION 14000019 * THIS MODULE IS THE STANDARD DEFAULT IHEABND MODULE 16000019 * IT SETS A RETURN CODE OF ZERO IN REGISTER 15 18000019 * THIS MODULE MAY BE REPLACED BY A USER WRITTEN FORM 20000019 * WHICH SETS A NON-ZERO CODE IN REGISTER 15 IN WHICH CASE 22000019 * THE STANDARD SYSTEM ACTION IN THE ABSENCE OF AN ERROR 24000019 * ON-UNIT IS A STEP ABEND WITH A USER CODE OF 3001. 26000019 * 28000019 * ENTRY POINT 30000019 * IHEABND 32000019 * 34000019 * RETURNS 36000019 * ZERO RETURN CODE IN REGISTER FIFTEEN 38000019 * 40000019 * PRIVATE MACROS 42000019 * NONE 44000019 * 46000019 * ASSEMBLY REQUIREMENTS 48000019 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 50000019 * SUPPORT E.G. O/S 360 F-ASSEMBLER 52000019 * 54000019 SPACE 5 56000019 IHEABN CSECT 58000019 * 60000019 * STANDARD IHEABND DEFAULT MODULE 62000019 * 64000019 ENTRY IHEABND 66000019 USING *,15 68000019 IHEABND EQU * 70000019 L 15,ZERO SET RETURN CODE IN REG 15. 72000019 BR 14 RETURN ON REG 14. 74000019 ZERO DC F'0' ZERO RETURN CODE .. NO ABEND. 76000019 END 78000019 ./ ADD SSI=03010761,SOURCE=1,NAME=IHEABU0 ABU TITLE ' IHEABU BINARY FIXED COMPLEX ABS *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 184 BYTES 00140000 * 00160000 * FUNCTION ABS(Z) WHERE Z IS FIXED BINARY COMPLEX. 00180000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00200000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEABU0 00280000 * RA = A(PLIST) 00300000 * PLIST = A(Z) 00320000 * A(DED FOR Z) 00340000 * A(TARGET) 00360000 * A(DED FOR TARGET) 00380000 * 00400000 * INPUT N/A 00420000 * 00440000 * OUTPUT N/A 00460000 * 00480000 * EXTERNAL MODULES 00500000 * N/A 00520000 * 00540000 * EXITS NORMAL 00560000 * RETURN TO CALLER VIA LINK REGISTER. 00580000 * 00600000 * TABLES/WORK-AREA 00620000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00640000 * 00660000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00680000 * 00700000 * PRIVATE MACROS 00720000 * IHELIB,IHESDR 00740000 * 00760000 * ASSEMBLY REQUIREMENTS 00780000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00800000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00820000 * 00840000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00860000 * STANDARDS. 00880000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00900000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 00920000 * EXTERNAL CHARACTER SET. 00940000 EJECT 00960000 IHEABU CSECT 00980000 SPACE 2 01000000 IHELIB 01020000 * PRIVATE REGISTER ASSIGNMENTS 01040000 SPACE 01060000 RY1 EQU R0 EVEN-ODD 01080000 WR1 EQU RA PAIR. 01100000 RX1 EQU RB 01120000 REV EQU RD EVEN-ODD 01140000 ROD EQU RE PAIR. 01160000 WR2 EQU RF 01180000 EJECT 01200000 IHEABU CSECT 01220000 SPACE 01240000 * ENTRY POINTS 01260000 SPACE 01280000 ENTRY IHEABU0 01300000 SPACE 01320000 USING *,BR 01340000 IHEABU0 STM LR,WR,OFLR(DR) 01360000 IHESDR LW0,RB 01380000 L RG,12(RA) LOAD A(DED) 01390001 LM RA,RC,0(RA) LOAD ARGUMENT LIST. 01400000 TM 0(RB),HWRD TEST DED FOR HALF_WORD 01408001 BO ABU01 01416001 L RX1,0(RA) FULL WORD ABS(X) 01424001 L RY1,4(RA) ABS(Y) 01432001 B ABU02 01440001 ABU01 LH RX1,0(RA) HALF WORD ABS(X) 01448001 LH RY1,2(RA) ABS(Y) 01456001 ABU02 LPR RX1,RX1 01464001 LPR RY1,RY1 ABS(Y) . 01480000 CR RX1,RY1 01500000 BC 2,ABU10 01520000 BC 8,ABU40 01540000 LR WR1,RX1 IF ABS(X) LT ABS(Y) , 01560000 LR RX1,RY1 INTERCHANGE IN 01580000 LR RY1,WR1 REGISTERS. 01600000 SPACE 01620000 * ABS(Z) = X1 * SQRT(1+(Y1/X1)**2), WHERE X1 GT Y1 . 01640000 SPACE 01660000 ABU10 SR WR1,WR1 01680000 SRDA RY1,1 Y1 (63,31) 01700000 DR RY1,RX1 Y1/X1 (31,31) 01720000 MR RY1,WR1 (Y1/X1)**2 (63,62) 01740000 A RY1,X130 (Y1/X1)**2 + 1 = G (63,62) 01760000 LR WR2,RY1 01780000 AL WR2,X130 1+G (32,30) 01800000 SRL WR2,2 (31,28) 01820000 SRDA RY1,4 G (63,58) 01840000 LR REV,RY1 01860000 LR ROD,WR1 01880000 DR REV,WR2 G/(1+G) (31,30) 01900000 AR WR2,ROD G/(1+G) + (1+G)/4 (31,30) 01920000 SRA WR2,1 = AP1 (31,29) 01940000 SPACE 01960000 * FIRST NEWTON-RAPHSON ITERATION. 01980000 SPACE 02000000 LR REV,RY1 G (63,58) 02020000 LR ROD,WR1 02040000 DR REV,WR2 G/AP1 (31,29) 02060000 AR ROD,WR2 (G/AP1 + AP1)/2 =AP2 (31,30) 02080000 SPACE 02100000 * TEST WHETHER SECOND ITERATION NECESSARY. 02120000 SPACE 02140000 C RX1,F215 02160000 BC 4,ABU20 02180000 SPACE 02200000 * SECOND NEWTON-RAPHSON ITERATION 02220000 SPACE 02240000 SLDA RY1,2 G (63,60) 02260000 DR RY1,ROD G/AP2 (31,30) 02280000 ALR ROD,WR1 G/AP2 + AP2 (32,30) 02300000 AL ROD,FONE ROUND 02320000 SRL ROD,1 AP3 (31,30) 02340000 SPACE 02360000 * FINAL MULTIPLICATION. 02380000 SPACE 02400000 ABU20 MR REV,RX1 X1 * AP (63,30) 02420000 ABU25 SLDA REV,2 02440000 LTR ROD,ROD 02460000 BC 10,ABU30 02480000 A REV,FONE ROUND 02500000 ABU30 TM 0(RG),HWRD TEST DED FOR HALF WORD 02508001 BO ABU31 02516001 ST REV,0(RC) STORE FULL WORD RESULT 02524001 B ABU32 02532001 ABU31 STH REV,0(RC) STORE HALF WORD RESULT 02540001 ABU32 L DR,OFDR(DR) 02548001 LM RB,RF,OFRB(DR) 02560000 MVI OFLR(DR),X'FF' 02580000 BCR 15,LR RETURN 02600000 SPACE 2 02620000 ABU40 LR ROD,RY1 IF ABS(X) = ABS(Y), USE 02640000 M REV,XRT2 Y1 * SQRT(2) 02660000 BC 15,ABU25 02680000 SPACE 2 02700000 * CONSTANTS. PRECISION 02720000 SPACE 02740000 F215 DC F'32768' 2**15 02760000 FONE DC F'1' 1 02780000 X130 DC X'40000000' 1 (31,30) 02800000 XRT2 DC X'5A82799A' SQRT(2) (31,30) 02820000 HWRD EQU X'10' 02830001 SPACE 4 02840000 END 02860000 ./ ADD SSI=03011972,SOURCE=1,NAME=IHEABV0 ABV TITLE ' IHEABV DECIMAL FIXED COMPLEX ABS *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*ABV000-TSS 00106001 * ----------------------------------------------------ABV000-TSS 00112001 * 00120000 * SIZE 544 BYTES 00140000 * 00160000 * FUNCTION ABS(Z) WHERE Z IS FIXED DECIMAL COMPLEX. 00180000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00200000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEABV0 00280000 * RA = A(PLIST) 00300000 * PLIST = A(Z) 00320000 * A(DED FOR Z) 00340000 * A(TARGET) 00360000 * A(DED FOR TARGET) 00380000 * 00400000 * INPUT N/A 00420000 * 00440000 * OUTPUT N/A 00460000 * 00480000 * EXTERNAL MODULES 00500000 * N/A 00520000 * 00540000 * EXITS NORMAL 00560000 * RETURN TO CALLER VIA LINK REGISTER. 00580000 * 00600000 * TABLES/WORK-AREA 00620000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00640000 * 00660000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00680000 * 00700000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00720000 * PRIVATE MACROS 00740000 * IHELIB,IHESDR 00760000 * 00780000 * ASSEMBLY REQUIREMENTS 00800000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00820000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00840000 * 00860000 * STANDARDS. 00880000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00900000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 00920000 * EXTERNAL CHARACTER SET. 00940000 EJECT 00960000 IHEABV CSECT 00980000 SPACE 2 01000000 IHELIB 01020000 * PRIVATE REGISTER ASSIGNMENTS . 01040000 SPACE 01060000 RX1 EQU R0 01080000 WSP EQU RB 01100000 REV EQU RD EVEN-ODD 01120000 ROD EQU RE PAIR. 01140000 WR3 EQU RF 01160000 RY1 EQU RF EVEN-ODD 01180000 WR1 EQU RG PAIR. 01200000 EXP EQU RH 01220000 LTH EQU RI 01240000 RE2 EQU RJ EVEN-ODD 01260000 WR2 EQU RX PAIR. 01280000 SPACE 1 COPY 01300000 * PRIVATE OFFSETS . 01320000 SPACE 01340000 OPW1 EQU 72 01360000 OPW2 EQU OPW1+8 DOUBLE WORDS . 01380000 OPD1 EQU OPW2+8 01400000 OPD2 EQU OPD1+16 01420000 EJECT 01440000 IHEABV CSECT 01460000 SPACE 01480000 * ENTRY POINTS 01500000 SPACE 01520000 ENTRY IHEABV0 01540000 SPACE 01560000 USING *,BR 01580000 IHEABV0 STM LR,WR,OFLR(DR) 01600000 IHESDR LW0,WSP 01620000 MVI OPW1(DR),0 ZEROISE WORKSPACE. 01640000 MVC OPW1+1(15,DR),OPW1(DR) 01660000 LM RA,RC,0(RA) LOAD ARGUMENT LIST. 01680000 SR LTH,LTH LOAD LTH WITH FIELD WIDTH OF P 01700000 IC LTH,1(RB) DECIMAL DIGITS, THEN CONVERT TO 01720000 SRA LTH,1 CORRESPONDING LENGTH-1 IN BYTES. 01740000 LR WR2,RA ADDRESS OF REAL(Z) . 01760000 LA WR3,1(LTH,RA) ADDRESS OF IMAG(Z) . 01780000 SR EXP,EXP SET EXPONENT TO ZERO . 01800000 LA WR1,4 01820000 CR LTH,WR1 IF LTH LE 4 , CONVERSION TO 01840000 BC 12,ABV40 BINARY IS STRAIGHTFORWARD. 01860000 SR WR1,LTH OTHERWISE SET UP WR2 TO ADDRESS 01880000 LCR WR1,WR1 FIELD WITH MAXIMUM NUMBER OF 01900000 CLC 0(3,WR2),0(WR3) SIGNIFICANT DIGITS, WR3 OTHER 01920000 BC 10,ABV10 FIELD, AND PREPARE FOR LOOP. 01940000 LR WR2,WR3 01960000 LR WR3,RA 01980000 SPACE 02000000 ABV10 CLI 0(WR2),0 TEST FOR MORE THAN 9 SIGNIFICANT 02020000 BC 6,ABV20 DIGITS . 02040000 LA WR2,1(WR2) 02060000 LA WR3,1(WR3) 02080000 BCT WR1,ABV10 02100000 BC 15,ABV25 IF NOT MORE THAN 9, SKIP SCALING . 02120000 SPACE 02140000 ABV20 LA EXP,0(WR1,WR1) SET EXPONENT, 02160000 TM 0(WR2),X'F0' TESTING HIGH-ORDER HALF OF FIRST 02180000 BC 7,ABV25 SIGNIFICANT BYTE FOR ZEROS, WHEN 02200000 BCTR EXP,0 EXPONENT IS ODD AND MOVE WITH 02220000 MVO OPW1+3(5,DR),0(5,WR2) OFFSET IS REQUIRED. 02240000 MVO OPW2+3(5,DR),0(5,WR3) 02260000 BC 15,ABV27 02280000 ABV25 MVC OPW1+3(5,DR),0(WR2) IF EXPONENT IS EVEN, MOVE 9 02300000 MVC OPW2+3(5,DR),0(WR3) LEADING DIGITS TO WORKSPACE. 02320000 ABV27 OI OPW1+7(DR),X'0F' INSERT POSITIVE SIGNS. 02340000 OI OPW2+7(DR),X'0F' 02360000 BC 15,ABV45 02380000 ABV40 EX LTH,ZADD1 SET UP TWO PARTS OF ARGUMENT IN 02400000 EX LTH,ZADD2 WORKSPACE WHEN NO SCALING NEEDED. 02420000 SPACE 02440000 ABV45 CVB RX1,OPW1(DR) TAKE ABSOLUTE BINARY VALUES OF 02460000 LPR RX1,RX1 SCALED REAL AND IMAGINARY PARTS 02480000 CVB RY1,OPW2(DR) OF ARGUMENT, AND ARRANGE FOR PART 02500000 LPR RY1,RY1 IN RX1 TO BE GREATER THAN OR EQUAL 02520000 CR RX1,RY1 TO PART IN RY1. 02540000 BC 2,ABV50 02560000 LR WR1,RX1 02580000 LTR RX1,RY1 02600000 BC 8,ABV90 IF X1=Y1=0, RETURN RESULT 0 . 02620000 LR RY1,WR1 02640000 SPACE 02660000 * ABS(Z)= X1 * SQRT(1+(Y1/X1)**2) WHERE Y1 LE X1 . 02680000 SPACE 02700000 ABV50 SR WR1,WR1 02720000 SRDA RY1,2 Y1 (63,30) 02740000 DR RY1,RX1 Y1/X1 (31,30) 02760000 MR RY1,WR1 (Y1/X1)**2 (63,60) 02780000 A RY1,X128 (Y1/X1)**2 + 1 = G (63,60) 02800000 LR WR2,RY1 02820000 A WR2,X128 1+G (31,28) 02840000 L REV,XMNA -A (63,57) 02860000 SR ROD,ROD 02880000 DR REV,WR2 -A/(1+G) (31,29) 02900000 A ROD,XAAA -A/(1+G) + A (31,29) 02920000 M RE2,XBBB B*(1+G) (63,61) 02940000 AR RE2,ROD A + B*(1+G) - A/(1+G) = AP1 (31,29) 02960000 SPACE 02980000 * FIRST NEWTON-RAPHSON ITERATION. 03000000 SPACE 03020000 LR REV,RY1 03040000 LR ROD,WR1 03060000 SRDA REV,2 G (63,58) 03080000 DR REV,RE2 G/AP1 03100000 AR ROD,RE2 (G/AP1 + AP1) / 2 = AP2 (31,30) 03120000 SPACE 03140000 * MULTIPLICATION BY X1 . 03160000 SPACE 03180000 MR REV,RX1 X1 * AP2 (63,30) 03200000 SLDA REV,2 03220000 LTR ROD,ROD 03240000 BC 10,ABV60 03260000 A REV,FONE ROUND. 03280000 SPACE 03300000 ABV60 CVD REV,OPW1(DR) CONVERT TO DECIMAL. 03320000 C REV,F107 IF RESULT LESS THAN 10**(7-Q), 03340000 BC 4,ABV90 SKIP DECIMAL ITERATION. 03360000 LCR EXP,EXP IF EXP ZERO, 03380000 BC 8,ABV70 SKIP SCALING. 03400000 SPACE 03420000 * DECIMAL SCALING . 03440000 SPACE 03460000 MVC OPW2+5(2,DR),X128+1 ZEROISE LAST THREE BYTES OF WKSP 2 03480000 MVI OPW2+7(DR),X'0C' AND INSERT PLUS SIGN. 03500000 STC EXP,OPW1(DR) 03520000 SRA EXP,1 03540000 TM OPW1(DR),X'01' 03560000 BC 8,ABV65 03580000 LA WR1,OPW2+1(EXP,DR) IF EXPONENT ODD, 03600000 MVO 0(8,WR1),OPW1+2(6,DR) MOVE WITH OFFSET . 03620000 NI 7(WR1),X'0F' CLEAR OLD SIGN. 03640000 BC 15,ABV69 03660000 SPACE 03680000 ABV65 LA WR1,7(EXP) IF EXPONENT EVEN, 03700000 LA WR2,OPW2(WR1,DR) SET UP 03720000 SLA WR1,4 LENGTH CODE 03740000 EX WR1,ZADD4 AND ZERO AND ADD. 03760000 SPACE 03780000 NI 0(WR2),X'F0' CLEAR OLD SIGN. 03800000 ABV69 MVC OPW1(8,DR),OPW2(DR) PLACE APPROXIMATION IN WKSP 1 . 03820000 SPACE 03840000 * DECIMAL ITERATION WHERE NECESSARY . 03860000 SPACE 03880000 ABV70 LA WR1,1(LTH,LTH) 03900000 LR WR3,WR1 03920000 SLA WR1,4 03940000 OR WR3,WR1 03960000 OR WR1,LTH 03980000 EX WR1,ZADD5 X 04000000 SPACE 04020000 EX WR1,MULT1 X**2 04040000 SPACE 04060000 LA WR2,1(LTH,RA) 04080000 EX WR1,ZADD6 Y 04100000 SPACE 04120000 EX WR1,MULT2 Y**2 04140000 SPACE 04160000 EX WR3,ADDD1 X**2 + Y**2 = H , SAY. 04180000 SPACE 04200000 EX WR3,ZADD7 APP 04220000 SPACE 04240000 DP OPD2(16,DR),OPW1(8,DR) H/APP 04260000 SP OPD2(8,DR),OPW1(8,DR) H/APP - APP 04280000 MP OPD2+1(7,DR),X50C 04300000 MVN OPD2+6(1,DR),OPD2+7(DR) (H/APP - APP)/2 04320000 AP OPW1(8,DR),OPD2+2(5,DR) (H/APP - APP)/2 + APP 04340000 EJECT 04360000 * EXIT. 04380000 SPACE 04400000 ABV90 IC WR1,1(RB) CALCULATE LENGTH CODE 04420000 CLI 1(RB),15 FOR TARGET FIELD. 04440000 BC 8,ABV92 04460000 LA WR1,1(WR1) 04480000 ABV92 SRA WR1,1 04500000 SLL WR1,4 04520000 EX WR1,ZADD3 MOVE RESULT TO TARGET FIELD. 04540000 SPACE 04560000 ABV95 L DR,OFDR(DR) 04580000 LM RB,RX,OFRB(DR) 04600000 MVI OFLR(DR),X'FF' 04620000 BCR 15,LR RETURN. 04640000 SPACE 2 04660000 * EXECUTED INSTRUCTIONS. 04680000 SPACE 04700000 ZADD1 ZAP OPW1+3(5,DR),0(,WR2) 04720000 ZADD2 ZAP OPW2+3(5,DR),0(,WR3) 04740000 ZADD3 ZAP 0(,RC),OPW1(8,DR) 04760000 ZADD4 ZAP OPW2(,DR),OPW1+2(6,DR) 04780000 ZADD5 ZAP OPD1(,DR),0(,RA) 04800000 ZADD6 ZAP OPD2(,DR),0(,WR2) 04820000 ZADD7 ZAP OPD2(16,DR),OPD2(,DR) 04840000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*ABV001-TSS 04850001 MULT1 MP OPD1(,DR),0(,RA) 04860000 MULT2 MP OPD2(,DR),0(,WR2) 04880000 * ----------------------------------------------------ABV001-TSS 04890001 ADDD1 AP OPD2(,DR),OPD1(,DR) 04900000 SPACE 04920000 * CONSTANTS 04940000 SPACE 04960000 FONE DC F'1' 04980000 F107 DC F'10000000' 10**7 05000000 X128 DC X'10000000' 1 (31,28) 05020000 XAAA DC X'20F2FA59' 1.02966039 (31,29) 05040000 XBBB DC X'7C424B32' 0.24269328 (31,33) 05060000 XMNA DC X'FDF0D05A' -1.02966039 (31,25) 05080000 X50C DC X'050C' 05100000 SPACE 4 05120000 END 05140000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEABW0 ABW TITLE ' IHEABW SHORT FLOAT COMPLEX ABS *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 128 BYTES 00140000 * 00160000 * FUNCTION ABS(Z) WHERE Z IS SHORT FLOAT COMPLEX. 00180000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00200000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEABW0 00280000 * RA = A(PLIST) 00300000 * PLIST = A(Z) 00320000 * A(TARGET) 00340000 * 00360000 * INPUT N/A 00380000 * 00400000 * OUTPUT N/A 00420000 * 00440000 * EXTERNAL MODULES 00460000 * IHESQS - SQRT(X) WHERE X IS SHORT FLOAT REAL 00480000 * 00500000 * EXITS NORMAL 00520000 * RETURN TO CALLER VIA LINK REGISTER. 00540000 * 00560000 * TABLES/WORK-AREA 00580000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00600000 * 00620000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00640000 * 00660000 * PRIVATE MACROS 00680000 * IHELIB,IHESDR 00700000 * 00720000 * ASSEMBLY REQUIREMENTS 00740000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00760000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00780000 * 00800000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00820000 * STANDARDS. 00840000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00860000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 00880000 * EXTERNAL CHARACTER SET. 00900000 EJECT 00920000 IHEABW CSECT 00940000 SPACE 2 00960000 IHELIB 00980000 SPACE 2 COPY 01000000 * PRIVATE REGISTER ASSIGNMENTS 01020000 SPACE 01040000 ADZ EQU RB 01060000 AZ1 EQU RB 01080000 ADT EQU RC 01100000 SPACE 01120000 WSP EQU LR 01140000 SPACE 1 COPY 01160000 * PRIVATE OFFSETS 01180000 SPACE 01200000 OPZ1 EQU 72 01220000 OPZ3 EQU OPZ1+4 01240000 OPAL EQU OPZ3+4 01260000 EJECT 01280000 IHEABW CSECT 01300000 SPACE 01320000 * ENTRY POINTS 01340000 SPACE 01360000 ENTRY IHEABW0 01380000 SPACE 01400000 USING *,BR 01420000 IHEABW0 STM LR,WR,OFLR(DR) 01440000 IHESDR LW1,WSP 01460000 LM ADZ,ADT,0(RA) LOAD ADDRESSES OF Z AND TARGET 01480000 LE FA,0(ADZ) 01500000 LPER FA,FA ABS(X) 01520000 LE FB,4(ADZ) 01540000 LPER FB,FB ABS(Y) 01560000 CER FA,FB 01580000 BC 2,AB010 01600000 LER FC,FB IF ABS(X) LE ABS(Y), INTERCHANGE. 01620000 LER FB,FA Z2 = MIN( ABS(X),ABS(Y) ) 01640000 LER FA,FC Z1 = MAX( ABS(X),ABS(Y) ) 01660000 LTER FA,FA IF X=Y=0, RETURN 0 ANSWER. 01680000 BC 8,AB020 01700000 SPACE 01720000 AB010 BALR RA,0 SAVE PROGRAM MASK. 01740000 SR R0,R0 01760000 SPM R0 MASK OUT UNDERFLOW INTERRUPTION. 01780000 DER FB,FA Z2/Z1 01800000 MER FB,FB (Z2/Z1)**2 01820000 SPM RA RESTORE PROGRAM MASK. 01840000 AE FB,EONE (Z2/Z1)**2 + 1 = Z3 01860000 STE FB,OPZ3(DR) STORE Z3 FOR USE AS ARGUMENT. 01880000 LA AZ1,OPZ3(DR) 01900000 STM AZ1,ADT,OPAL(DR) STORE ARGUMENT LIST. 01920000 STE FA,OPZ1(DR) SAVE Z1. 01940000 LA RA,OPAL(DR) 01960000 L BR,VSQS 01980000 BALR LR,BR CALL REAL SHORT SQRT. 02000000 SPACE 02020000 USING *,LR 02040000 LE FA,OPZ1(DR) 02060000 ME FA,0(RC) Z1 * SQRT(Z3) 02080000 SPACE 02100000 AB020 STE FA,0(RC) STORE RESULT. 02120000 L DR,OFDR(DR) RESTORE DR. 02140000 LM LR,RC,OFLR(DR) 02160000 MVI OFLR(DR),X'FF' TRACE STOPPER. 02180000 BCR 15,LR 02200000 SPACE 02220000 * CONSTANTS 02240000 SPACE 02260000 EONE DC E'1' 02280000 VSQS DC V(IHESQS0) 02300000 SPACE 2 02320000 END 02340000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEABZ0 ABZ TITLE ' IHEABZ LONG FLOAT COMPLEX ABS *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 128 BYTES 00140000 * 00160000 * FUNCTION ABS(Z) WHERE Z IS LONG FLOAT COMPLEX. 00180000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00200000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEABZ0 00280000 * RA = A(PLIST) 00300000 * PLIST = A(Z) 00320000 * A(TARGET) 00340000 * 00360000 * INPUT N/A 00380000 * 00400000 * OUTPUT N/A 00420000 * 00440000 * EXTERNAL MODULES 00460000 * IHESQL - SQRT(X) WHERE X IS LONG FLOAT REAL 00480000 * 00500000 * EXITS NORMAL 00520000 * RETURN TO CALLER VIA LINK REGISTER. 00540000 * 00560000 * TABLES/WORK-AREA 00580000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00600000 * 00620000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00640000 * 00660000 * PRIVATE MACROS 00680000 * IHELIB,IHESDR 00700000 * 00720000 * ASSEMBLY REQUIREMENTS 00740000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00760000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00780000 * 00800000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00820000 * STANDARDS. 00840000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00860000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 00880000 * EXTERNAL CHARACTER SET. 00900000 EJECT 00920000 IHEABZ CSECT 00940000 SPACE 2 00960000 IHELIB 00980000 SPACE 2 COPY 01000000 * PRIVATE REGISTER ASSIGNMENTS 01020000 SPACE 01040000 ADZ EQU RB 01060000 AZ1 EQU RB 01080000 ADT EQU RC 01100000 SPACE 01120000 WSP EQU LR 01140000 SPACE 1 COPY 01160000 * PRIVATE OFFSETS 01180000 SPACE 01200000 OPZ1 EQU 72 01220000 OPZ3 EQU OPZ1+8 01240000 OPAL EQU OPZ3+8 01260000 EJECT 01280000 IHEABZ CSECT 01300000 SPACE 01320000 * ENTRY POINTS 01340000 SPACE 01360000 ENTRY IHEABZ0 01380000 SPACE 01400000 USING *,BR 01420000 IHEABZ0 STM LR,WR,OFLR(DR) 01440000 IHESDR LW1,WSP 01460000 LM ADZ,ADT,0(RA) LOAD ADDRESSES OF Z AND TARGET. 01480000 LD FA,0(ADZ) 01500000 LPER FA,FA ABS(X) 01520000 LD FB,8(ADZ) 01540000 LPER FB,FB ABS(Y) 01560000 CDR FA,FB 01580000 BC 2,AB010 01600000 LDR FC,FB IF ABS(X) LE ABS(Y), INTERCHANGE. 01620000 LDR FB,FA Z2 = MIN( ABS(X),ABS(Y) ) 01640000 LDR FA,FC Z1 = MAX( ABS(X),ABS(Y) ) 01660000 LTDR FA,FA IF X=Y=0, RETURN 0 ANSWER. 01680000 BC 8,AB020 01700000 SPACE 01720000 AB010 BALR RA,0 SAVE PROGRAM MASK. 01740000 SR R0,R0 01760000 SPM R0 MASK OUT UNDERFLOW INTERRUPTION. 01780000 DDR FB,FA Z2/Z1 01800000 MDR FB,FB (Z2/Z1)**2 01820000 SPM RA RESTORE PROGRAM MASK. 01840000 AD FB,DONE (Z2/Z1)**2 + 1 = Z3 01860000 STD FB,OPZ3(DR) STORE Z3 FOR USE AS ARGUMENT. 01880000 LA AZ1,OPZ3(DR) 01900000 STM AZ1,ADT,OPAL(DR) STORE ARGUMENT LIST. 01920000 STD FA,OPZ1(DR) SAVE Z1. 01940000 LA RA,OPAL(DR) 01960000 L BR,VSQL 01980000 BALR LR,BR CALL REAL LONG SQRT. 02000000 SPACE 02020000 USING *,LR 02040000 LD FA,OPZ1(DR) 02060000 MD FA,0(RC) Z1 * SQRT(Z3) 02080000 SPACE 02100000 AB020 STD FA,0(RC) STORE RESULT. 02120000 L DR,OFDR(DR) RESTORE DR. 02140000 LM LR,RC,OFLR(DR) 02160000 MVI OFLR(DR),X'FF' TRACE STOPPER. 02180000 BCR 15,LR 02200000 SPACE 02220000 * CONSTANTS. 02240000 SPACE 02260000 VSQL DC V(IHESQL0) 02280000 DONE DC D'1' 02300000 SPACE 2 02320000 END 02340000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEADD0 ADD TITLE ' IHEADD REAL DECIMAL FIXED ''ADD'' FUNCTION *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 216 BYTES 00140000 * 00160000 * FUNCTION ADD(X,Y,P,Q) WHERE X AND Y ARE FIXED DECIMAL REAL AND 00180000 * (P,Q) IS THE TARGET PRECISION. 00200000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00220000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00240000 * 00260000 * ENTRY POINTS 00280000 * IHEADD0 00300000 * RA = A(PLIST) 00320000 * PLIST = A(X) 00340000 * A(DED FOR X) 00360000 * A(Y) 00380000 * A(DED FOR Y) 00400000 * A(TARGET) 00420000 * A(DED FOR TARGET) 00440000 * 00460000 * INPUT N/A 00480000 * 00500000 * OUTPUT N/A 00520000 * 00540000 * EXTERNAL MODULES 00560000 * IHEAPD - DECIMAL SHIFT AND ASSIGN, SHIFT AND LOAD 00580000 * 00600000 * EXITS NORMAL 00620000 * RETURN TO CALLER VIA LINK REGISTER. 00640000 * 00660000 * TABLES/WORK-AREA 00680000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00700000 * 00720000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00740000 * 00760000 * PRIVATE MACROS 00780000 * IHELIB,IHESDR 00800000 * 00820000 * ASSEMBLY REQUIREMENTS 00840000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00860000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00880000 * 00900000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00920000 * STANDARDS. 00940000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00960000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 00980000 * EXTERNAL CHARACTER SET. 01000000 EJECT 01020000 IHEADD CSECT 01040000 SPACE 2 01060000 IHELIB 01080000 * PRIVATE REGISTER ASSIGNMENTS 01100000 SPACE 01120000 WSP EQU LR 01140000 CMP EQU LR 01160000 SCR EQU R0 01180000 SF1 EQU RA 01200000 LT1 EQU RH 01220000 LTH EQU RH 01240000 SF2 EQU RI 01260000 ADR EQU RI 01280000 LT2 EQU RJ 01300000 BAS EQU WR 01320000 SPACE 01340000 * PRIVATE OFFSETS 01360000 SPACE 01380000 OPW1 EQU 72 01400000 OPDD EQU OPW1+16 01420000 EJECT 01440000 IHEADD CSECT 01460000 SPACE 01480000 * ENTRY POINTS 01500000 SPACE 01520000 ENTRY IHEADD0 01540000 SPACE 01560000 IHEADD0 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01580000 BALR BAS,0 01600000 USING *,BAS 01620000 IHESDR LW1,WSP 01640000 LM RB,RG,0(RA) LOAD ARGUMENT LIST 01660000 SR SF1,SF1 01680000 IC SF1,2(RC) SCALE FACTOR OF FIRST ARGUMENT 01700000 SR SF2,SF2 01720000 IC SF2,2(RE) SCALE FACTOR OF SECOND ARGUMENT 01740000 SR LT1,LT1 01760000 IC LT1,1(RC) PRECISION OF FIRST ARGUMENT 01780000 SRL LT1,1 LENGTH CODE OF 1ST ARGUMENT TO LT1 01800000 SR LT2,LT2 01820000 IC LT2,1(RE) PRECISION OF SECOND ARGUMENT 01840000 SRL LT2,1 LENGTH CODE OF 2ND ARGUMENT TO LT2 01860000 MVI OPDD+1(DR),31 SET PRECISION BYTE IN DED TO 31 01880000 LR CMP,RB 01900000 EX LT1,CP010 TEST FOR ZERO FIRST ARGUMENT 01920000 LR CMP,RD 01940000 BNE FIRN0 IF NON-ZERO, BRANCH TO FURTHER TEST 01960000 EX LT2,ZAP10 IF ZERO ZAP 2ND ARGUMENT TO OPW1 AND 01980000 STC SF2,OPDD+2(DR) STORE ITS SCALE FACTOR IN DED THEN 02000000 B CNSTR BRANCH PAST ADDITION 02020000 FIRN0 EX LT2,CP010 TEST FOR ZERO 2ND ARGUMENT 02040000 BNE BOTN0 IF BOTH NON-ZERO, BRANCH 02060000 LR CMP,RB 02080000 EX LT1,ZAP10 IF ZERO ZAP 1ST ARGUMENT TO OPW1 AND 02100000 STC SF1,OPDD+2(DR) STORE ITS SCALE FACTOR IN DED THEN 02120000 B CNSTR BRANCH PAST ADDITION 02140000 BOTN0 CR SF1,SF2 COMPARE SCALE FACTORS 02160000 BL SECLA AND BRANCH IF SECOND GE FIRST 02180000 SPACE 02200000 * 1ST ARGUMENT IS TO BE CONVERTED TO SCALE FACTOR OF SECOND 02220000 SPACE 02240000 STC SF2,OPDD+2(DR) SET SCALE FACTOR IN DED TO THAT OF 02260000 * SECOND ARGUMENT 02280000 LR RA,RB 02300000 LR RB,RC 02320000 LR LTH,LT2 SET LTH = 2ND ARGUMENT LENGTH CODE 02340000 LR ADR,RD 02360000 B CNTNU 02380000 SPACE 02400000 * SECOND ARGUMENT IS TO BE CONVERTED TO SCALE FACTOR OF FIRST 02420000 SPACE 02440000 SECLA STC SF1,OPDD+2(DR) SET SCALE FACTOR IN DED TO THAT OF 02460000 * FIRST ARGUMENT 02480000 LR ADR,RB 02500000 LR RA,RD 02520000 LR RB,RE 02540000 CNTNU LA RC,OPW1(DR) COMPLETE ARGUMENT LIST FOR SHIFTING 02560000 LA RD,OPDD(DR) OTHER ARGUMENT INTO OPW1 02580000 L BR,VSHF CALL SHIFT ROUTINE TO SHIFT ARGUMENT 02600000 BALR LR,BR WITH LARGER S.F. INTO OPW1 02620000 EX LTH,AP010 ADD THE TWO NUMBERS 02640000 CNSTR LA RA,OPW1(DR) CONSTRUCT ARGUMENT LIST FOR ASSIGN 02660000 LA RB,OPDD(DR) ROUTINE TO ASSIGN SUM TO TARGET 02680000 LR RC,RF WITH DESIRED PRECISION AND SCALE 02700000 LR RD,RG FACTOR 02720000 L BR,VASS 02740000 BALR LR,BR 02760000 L DR,OFDR(DR) 02780000 RSTOR LM LR,RJ,OFLR(DR) RESTORE REGISTERS 02800000 MVI OFLR(DR),X'FF' TRACE STOPPER 02820000 BR LR RETURN TO CALLER 02840000 SPACE 02860000 * EXECUTED INSTRUCTIONS 02880000 SPACE 02900000 AP010 AP OPW1(16,DR),0(0,ADR) 02920000 CP010 CP ZERO(1),0(0,CMP) 02940000 ZAP10 ZAP OPW1(16,DR),0(0,CMP) 02960000 SPACE 02980000 * CONSTANTS 03000000 SPACE 03020000 ZERO EQU RSTOR+3 03040000 VSHF DC V(IHEAPDB) 03060000 VASS DC V(IHEAPDA) 03080000 SPACE 4 03100000 END 03120000 ./ ADD SSI=03011640,SOURCE=1,NAME=IHEADV0 ADV TITLE ' IHEADV COMPLEX DECIMAL FIXED ''ADD'' FUNCTION *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 96 BYTES 00140000 * 00160000 * FUNCTION ADD(W,Z,P,Q) WHERE W AND Z ARE FIXED DECIMAL COMPLEX 00180000 * AND (P,Q) IS THE TARGET PRECISION. 00200000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00220000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00240000 * 00260000 * ENTRY POINTS 00280000 * IHEADV0 00300000 * RA = A(PLIST) 00320000 * PLIST = A(W) 00340000 * A(DED FOR W) 00360000 * A(Z) 00380000 * A(DED FOR Z) 00400000 * A(TARGET) 00420000 * A(DED FOR TARGET) 00440000 * 00460000 * INPUT N/A 00480000 * 00500000 * OUTPUT N/A 00520000 * 00540000 * EXTERNAL MODULES 00560000 * IHEADD - ADD(X,Y,P,Q) WHERE X AND Y ARE FIXED DECIMAL 00580000 * REAL AND (P,Q) IS THE TARGET PRECISION 00600000 * 00620000 * EXITS NORMAL 00640000 * RETURN TO CALLER VIA LINK REGISTER. 00660000 * 00680000 * TABLES/WORK-AREA 00700000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00720000 * 00740000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00760000 * 00780000 * PRIVATE MACROS 00800000 * IHELIB,IHESDR 00820000 * 00840000 * ASSEMBLY REQUIREMENTS 00860000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00880000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00900000 * 00920000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00940000 * STANDARDS. 00960000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00980000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01000000 * EXTERNAL CHARACTER SET. 01020000 EJECT 01040000 IHEADV CSECT 01060000 SPACE 2 01080000 IHELIB 01100000 * PRIVATE REGISTER ASSIGNMENTS 01120000 LTH EQU RA 01140000 WSP EQU RB 01160000 SPACE 01180000 * PRIVATE OFFSET 01200000 SPACE 01220000 OPWK EQU 72 01240000 EJECT 01260000 IHEADV CSECT 01280000 SPACE 01300000 * ENTRY POINTS 01320000 SPACE 01340000 ENTRY IHEADV0 01360000 SPACE 01380000 USING *,BR 01400000 IHEADV0 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01420000 IHESDR LW2,WSP 01440000 LM RB,RG,0(RA) LOAD ARGUMENT LIST 01460000 L BR,VADD CALL REAL ADD TO OBTAIN REAL PART 01480000 BALR LR,BR OF ANSWER IN TARGET 01500000 USING *,LR 01520000 SR LTH,LTH 01540000 IC LTH,1(RC) COMPUTE LENGTH CODE OF EACH PART 01560000 SRL LTH,1 OF FIRST ARGUMENT 01580000 LA RB,1(RB,LTH) UPDATE RB TO IMAGINARY PART 01600000 IC LTH,1(RE) COMPUTE LENGTH CODE OF EACH PART 01620000 SRL LTH,1 OF SECOND ARGUMENT 01640000 LA RD,1(RD,LTH) UPDATE RD TO IMAGINARY PART 01660000 IC LTH,1(RG) COMPUTE LENGTH CODE OF EACH PART 01680000 SRL LTH,1 OF ANSWER 01700000 LA RF,1(RF,LTH) UPDATE RF TO TARGET FOR IMAG. PART 01720000 STM RB,RG,OPWK(DR) STORE NEW ARGUMENT LIST 01740000 LA RA,OPWK(DR) POINT RA AT LIST 01760000 L BR,VADD CALL REAL ADD TO OBTAIN IMAGINARY 01780000 BALR LR,BR PART OF ANSWER IN TARGET 01800000 L DR,OFDR(DR) 01820000 LM LR,RG,OFLR(DR) RESTORE REGISTERS 01840000 MVI OFLR(DR),X'FF' 01860000 BR LR RETURN TO CALLER 01880000 SPACE 01900000 VADD DC V(IHEADD0) 01920000 SPACE 4 01940000 END 01960000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEAPDA APD TITLE ' IHEAPD DECIMAL SHIFT AND ASSIGN, SHIFT AND LOAD *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 360 BYTES 00140000 * 00160000 * FUNCTION TO CONVERT A FIXED DECIMAL REAL NUMBER WITH PRECISION 00180000 * (P1,Q1) TO PRECISION (P2,Q2) OR PRECISION (31,Q2) 00200000 * WHERE P1 LE 31 AND P2 LE 15. 00220000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00240000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00260000 * 00280000 * ENTRY POINTS 00300000 * IHEAPDA - SHIFT AND ASSIGN 00320000 * RA = A(ARGUMENT) 00340000 * RB = A(DED FOR ARGUMENT) 00360000 * RC = A(TARGET) 00380000 * RD = A(DED FOR TARGET) 00400000 * IHEAPDB - SHIFT AND LOAD 00420000 * RA = A(ARGUMENT) 00440000 * RB = A(DED FOR ARGUMENT) 00460000 * RC = A(TARGET) 00480000 * RD = A(DED FOR TARGET) 00500000 * 00520000 * INPUT N/A 00540000 * 00560000 * OUTPUT N/A 00580000 * 00600000 * EXTERNAL MODULES 00620000 * N/A 00640000 * 00660000 * EXITS NORMAL 00680000 * RETURN TO CALLER VIA LINK REGISTER. 00700000 * ERROR 00720000 * BRANCH TO THE ENTRY POINT IHEERRB OF THE EXECUTION 00740000 * ERROR PACKAGE IF SIZE OR FIXEDOVERFLOW CONDITIONS HAVE 00760000 * BEEN DETECTED. 00780000 * 00800000 * TABLES/WORK-AREA 00820000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00840000 * 00860000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00880000 * 00900000 * PRIVATE MACROS 00920000 * IHELIB,IHEPRV,IHESDR 00940000 * 00960000 * ASSEMBLY REQUIREMENTS 00980000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 01000000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01020000 * 01040000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01060000 * STANDARDS. 01080000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01100000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01120000 * EXTERNAL CHARACTER SET. 01140000 EJECT 01160000 IHEAPD CSECT 01180000 SPACE 2 01200000 IHELIB 01220000 * PRIVATE REGISTER ASSIGNMENTS 01240000 SPACE 01260000 SCR EQU R0 01280000 SAV EQU RE 01300000 LCS EQU RE 01320000 SFS EQU RE 01340000 LT1 EQU RF 01360000 WKF EQU RG 01380000 SF1 EQU RH 01400000 LTH EQU RH 01420000 SFT EQU RI 01440000 WSP EQU DR 01460000 BAS EQU WR 01480000 SPACE 01500000 * PRIVATE OFFSETS 01520000 SPACE 01540000 OPWK EQU 72 01560000 OPW8 EQU OPWK+8 01580000 EJECT 01600000 IHEAPD CSECT 01620000 SPACE 01640000 * ENTRY POINTS 01660000 SPACE 01680000 ENTRY IHEAPDA,IHEAPDB 01700000 SPACE 01720000 * ******************** 01740000 * * SHIFT AND ASSIGN * 01760000 * ******************** 01780000 IHEAPDA NOPR 0 01800000 SPACE 01820000 * ******************** 01840000 * * SHIFT AND LOAD * 01860000 * ******************** 01880000 IHEAPDB STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01900000 BALR BAS,0 01920000 USING *,BAS 01940000 LR RJ,DR SAVE SAVE AREA POINTER 01960000 IHESDR LW0,RG 01980000 LA WKF,OPWK(0,WSP) ADDRESS OF WORKSPACE TO WKF 02000000 ZAP 0(16,WKF),ZERO SET WORKSPACE FIELD TO ZERO 02020000 SR SF1,SF1 02040000 SR LT1,LT1 02060000 IC SF1,2(RB) SCALE FACTOR OF NUMBER TO SF1 02080000 IC LT1,1(RB) PRECISION OF NUMBER TO LT1 02100000 LR SCR,LT1 SAVE PRECISION IN SCR 02120000 SRL LT1,1 LENGTH CODE TO LT1 02140000 SR SFT,SFT 02160000 IC SFT,2(RD) DESIRED SCALE FACTOR TO SFT 02180000 SR SFT,SF1 COMPUTE NECESSARY SHIFT 02200000 BZ NSHFT BRANCH IF NO SHIFT (2) 02220000 BP LSHFT BRANCH IF PLUS (LEFT SHIFT) (3) 02240000 SPACE 02260000 SPACE 02280000 * (1) SHIFT NUMBER RIGHT BY DIFFERENCE IN SCALE FACTORS AND LOAD 02300000 * INTO 16 BYTE FIELD POINTED TO BY WKF 02320000 SPACE 02340000 LPR SFT,SFT 02360000 CR SFT,SCR COMPARE SHIFT WITH PRECISION OF ARG 02380000 BNL FINIS IF SHIFT GE PRECISION RETURN ZERO 02400000 LR SFS,SFT SAVE SFT (SHIFT) 02420000 SRL SFT,1 SFT = FLOOR(S/2) 02440000 SR SFT,LT1 SFT = FLOOR(S/2)- LENGTH OF NUMBER 02460000 LPR LTH,SFT LENGTH OF PART OF ARG TO BE MOVED 02480000 * TO LTH 02500000 AR SFT,WKF 02520000 EX LTH,MVC10 LOAD AND SHIFT INTO 16 BYTE FIELD 02540000 LA SCR,1 02560000 NR SCR,SFS TEST IF SHIFT ODD OR EVEN 02580000 BZ LEVEN BRANCH IF EVEN 02600000 MVO 0(16,WKF),0(15,WKF) IF ODD SHIFT RIGHT ONE MORE PLACE 02620000 B LEVEN 02640000 EJECT 02660000 * (2) SHIFT IS ZERO, SO COPY ARGUMENT TO 16 BYTE FIELD 02680000 SPACE 02700000 NSHFT LA LT1,X'F0'(LT1) 02720000 EX LT1,ZAP10 ZERO AND ADD INTO FIELD 02740000 B FINIS 02760000 SPACE 02780000 * (3) SHIFT NUMBER LEFT BY DIFFERENCE IN SCALE FACTORS AND LOAD 02800000 * INTO 16 BYTE FIELD POINTED TO BY WKF 02820000 SPACE 02840000 LSHFT CH SFT,H031 IF SHIFT IS LESS THAN 31 DIGITS 02860000 BL SHFLS BRANCH TO LEFT SHIFT 02880000 EX LT1,CP010 WAS THE NUMBER ZERO 02900000 BZ FINIS IF YES RETURN ZERO RESULT 02920000 BAL SAV,RFOFL IF NUMBER WAS NON-ZERO, RAISE 02940000 B FINIS FIXEDOVERFLOW THEN RETURN ZERO 02960000 SPACE 02980000 SHFLS LR LCS,SFT LCS = SHIFT (S) 03000000 SRL LCS,1 LCS = FLOOR(S/2) 03020000 LCR LCS,LCS 03040000 LA LCS,15(LCS) LCS = 15 - FLOOR(S/2) 03060000 SLL LCS,4 SHIFT LEFT 4 AND OR IN LENGTH 03080000 OR LCS,LT1 OF ARGUMENT FOR EX INSTRUCTION 03100000 EX LCS,ZAP10 LOAD AND SHIFT INTO 16 BYTE FIELD 03120000 * (MAY CAUSE OVERFLOW) 03140000 SRL LCS,4 LCS = 15 - FLOOR(S/2) 03160000 AR LCS,WKF 03180000 NI 0(LCS),X'F0' CLEAR SIGN 03200000 LA SCR,1 03220000 NR SCR,SFT TEST FOR ODD OR EVEN SHIFT 03240000 BZ LEVEN 03260000 TM 0(WKF),X'F0' IF ODD TEST FIRST DIGIT BEFORE SHIFT 03280000 BZ LODDD OF ONE MORE PLACE 03300000 BAL SAV,RFOFL IF NON-ZERO RAISE FIXEDOVERFLOW 03320000 LODDD MVO 0(16,WKF),0(16,WKF) IF ZERO SHIFT LEFT ONE MORE PLACE 03340000 NI 15(WKF),X'0F' CLEAR EXTRA SIGN INTRODUCED 03360000 LEVEN AR RA,LT1 03380000 MVN 15(1,WKF),0(RA) MOVE SIGN TO RESULT IN WORKSPACE 03400000 FINIS TM OFBR+3(RJ),2 TEST ENTRY POINT 03420000 BO NOASS BRANCH IF 16 BYTE RESULT REQD. 03440000 SR LTH,LTH 03460000 IC LTH,1(RD) COMPUTE LENGTH CODE OF TARGET 03480000 SRL LTH,1 03500000 SLL LTH,4 03520000 * ASSIGN TO 8 BYTE FIELD AND TEST 03540000 ZAP OPW8(8,WSP),OPWK(16,WSP) FOR FIXEDOVERFLOW 03560000 LH SCR,XSZE SIZE ON-CONDITION CODE 03580000 IHEPRV ERR,SCR,OP=STH 03600000 EX LTH,STORE STORE RESULT IN TARGET 03620000 TM 1(RD),1 TEST FOR ODD TARGET PRECISION 03640000 BO LEAVE BRANCH IF ODD 03660000 TM 0(RC),X'F0' IF EVEN, TEST FIRST DIGIT OF TARGET 03680000 BZ LEAVE 03700000 L BR,VXEP IF NON-ZERO BRANCH TO EXEP TO 03720000 BALR LR,BR INDICATE SIZE ERROR 03740000 LEAVE SR SCR,SCR CLEAR IHEQERR 03760000 IHEPRV ERR,SCR,OP=STH 03780000 RSTOR L DR,OFDR(DR) 03800000 LM LR,WR,OFLR(DR) RESTORE REGISTERS 03820000 MVI OFLR(DR),X'FF' 03840000 BR LR RETURN TO CALLER 03860000 SPACE 03880000 NOASS MVC 0(16,RC),OPWK(WSP) MOVE 16 BYTE RESULT TO TARGET 03900000 B RSTOR 03920000 SPACE 03940000 RFOFL LH SCR,XFOF 03960000 IHEPRV ERR,SCR,OP=STH SUBROUTINE TO RAISE 03980000 L BR,VXEP FIXEDOVERFLOW 04000000 BALR LR,BR 04020000 BR SAV 04040000 SPACE 04060000 * EXECUTED INSTRUCTIONS 04080000 SPACE 04100000 CP010 CP ZERO,0(0,RA) 04120000 ZAP10 ZAP 0(0,WKF),0(0,RA) 04140000 MVC10 MVC 15(0,SFT),0(RA) 04160000 STORE ZAP 0(0,RC),OPW8(8,WSP) 04180000 EJECT 04200000 * CONSTANTS 04220000 SPACE 04240000 H031 DC H'31' 04260000 XSZE DC X'2000' SIZE ON CONDITION CODE 04280000 XFOF DC X'2800' FIXEDOVERFLOW ON CONDITION CODE 04300000 ZERO DC PL1'0' 04320000 VXEP DC V(IHEERRB) 04340000 SPACE 4 04360000 END 04380000 ./ ADD SSI=03010085,SOURCE=1,NAME=IHEATL4 ATL TITLE ' IHEATL LONG FLOAT REAL ATAN, ATAND *00400001 OS/360 PL/I LIBRARY' 00800001 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 01200001 * 01600001 * STATUS CHANGE LEVEL - 0. 02000001 * 02400001 * SIZE 480 BYTES 02800001 * 03200001 * FUNCTION ATAN(X), ATAND(X), ATAN(Y,X), ATAND(Y,X), WHERE 03600001 * X AND Y ARE LONG FLOAT REAL 04000001 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 04400001 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 04800001 * 05200001 * ENTRY POINTS 05600001 * IHEATL1 - ATAN(X) 06000001 * RA = A(PLIST) 06400001 * PLIST = A(X) 06800001 * A(TARGET) 07200001 * IHEATL2 - ATAN(Y,X) 07600001 * RA = A(PLIST) 08000001 * PLIST = A(Y) 08400001 * A(X) 08800001 * A(TARGET) 09200001 * IHEATL3 - ATAND(X) 09600001 * RA = A(PLIST) 10000001 * PLIST = A(X) 10400001 * A(TARGET) 10800001 * IHEATL4 - ATAND(Y,X) 11200001 * RA = A(PLIST) 11600001 * PLIST = A(Y) 12000001 * A(X) 12400001 * A(TARGET) 12800001 * 13200001 * INPUT N/A 13600001 * 14000001 * OUTPUT N/A 14400001 * 14800001 * EXTERNAL MODULES 15200001 * N/A 15600001 * 16000001 * EXITS NORMAL 16400001 * RETURN TO CALLER VIA LINK REGISTER. 16800001 * ERROR 17200001 * BRANCH TO THE ENTRY POINT IHEERRC OF THE EXECUTION 17600001 * ERROR PACKAGE IF X = Y = 0 GIVEN AS ARGUMENTS TO 18000001 * ATAN(Y,X) OR ATAND(Y,X) 18400001 * 18800001 * TABLES/WORK-AREA 19200001 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 19600001 * 20000001 * ATTRIBUTES READ-ONLY AND REENTRANT. 20400001 * 20800001 * PRIVATE MACROS 21200001 * IHELIB,IHESDR 21600001 * 22000001 * ASSEMBLY REQUIREMENTS 22400001 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 22800001 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 23200001 * 23600001 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 24000001 * STANDARDS. 24400001 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 24800001 * A PARTICULAR INTERNAL REPRESENTATION OF THE 25200001 * EXTERNAL CHARACTER SET. 25600001 EJECT 26000001 IHEATL CSECT 26400001 SPACE 2 26800001 IHELIB 27200001 SPACE 27600001 * PRIVATE OFFSETS 28000001 SPACE 28400001 OFSN EQU 72 28800001 EJECT 29200001 IHEATL CSECT 29600001 SPACE 30000001 * ENTRY POINTS 30400001 SPACE 30800001 ENTRY IHEATL4,IHEATL2,IHEATL3,IHEATL1 31200001 SPACE 31600001 * *********************** 32000001 * * ENTRY POINT * 32400001 * * FOR ATAND(Y/X) * 32800001 * *********************** 33200001 SPACE 33600001 USING *,BR 34000001 IHEATL4 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 34400001 SR RE,RE SET RE DEGREES 34800001 BAL BR,AT010 35200001 * *********************** 35600001 * * ENTRY POINT * 36000001 * * FOR ATAN(Y/X) * 36400001 * *********************** 36800001 USING *,BR 37200001 IHEATL2 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 37600001 LA RE,4 SET RE RADIANS 38000001 AT010 LA RD,1 SET RD FOR DOUBLE ARG. ENTRY 38400001 IHESDR LW0,RB 38800001 LM RA,RC,0(RA) 39200001 BC 15,AT030 39600001 * *********************** 40000001 * * ENTRY POINT * 40400001 * * FOR ATAND(X) * 40800001 * *********************** 41200001 USING *,BR 41600001 IHEATL3 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 42000001 SR RE,RE SET RE DEGREES 42400001 BAL BR,AT020 42800001 * *********************** 43200001 * * ENTRY POINT * 43600001 * * FOR ATAN(X) * 44000001 * *********************** 44400001 USING *,BR 44800001 IHEATL1 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 45200001 LA RE,4 SET RE RADIANS 45600001 AT020 SR RD,RD SET RD FOR SINGLE ARG. ENTRY 46000001 IHESDR LW0,RB 46400001 L RC,4(RA) RC POINTS TO TARGET 46800001 L RA,0(RA) RA POINTS TO SINGLE ARGUMENT 47200001 AT030 LD FA,0(RA) OBTAIN FIRST OR ONLY ARGUMENT 47600001 STE FA,OFSN(DR) SAVE ITS SIGN 48000001 BALR BR,0 SAVE PROGRAM MASK 48400001 USING *,BR 48800001 SPM RE DISABLE UNDERFLOW 49200001 LTR RD,RD 49600001 BC 8,AT070 IF SINGLE ARGUMENT ENTRY BRANCH 50000001 * TO MAIN CIRCUIT 50400001 LD FB,0(RB) OBTAIN 2ND ARGUMENT X 50800001 L RD,0(RB) SAVE ITS SIGN 51200001 STE FB,OFSN+4(DR) 51600001 LM RA,RB,OFSN(DR) IF X = 0, OR IF ABS(Y/X) IS 52000001 N RB,MASK GREATER THAN 2**56, GIVE 52400001 BC 8,AT040 SIGN(Y)*PI/2 AS ANSWER 52800001 N RA,MASK 53200001 SR RA,RB 53600001 C RA,BIAS 54000001 BC 12,AT060 54400001 BC 15,AT045 54800001 AT040 LTER FA,FA 55200001 BC 8,AT050 IF Y = X = 0 ERROR 55600001 AT045 LD FA,DONE 56000001 SD FA,PIB2 56400001 BC 15,AT120 56800001 AT050 SPM BR RESTORE PROGRAM MASK 57200001 L BR,VXEP 57600001 BALR RA,BR 58000001 DC H'269' ERROR CODE 58400001 SPACE 58800001 AT060 DDR FA,FB JOIN MAIN CIRCUIT WITH 59200001 SPACE 59600001 * MAIN CIRCUIT 60000001 SPACE 60400001 AT070 LPER FA,FA 60800001 LD FC,DONE 61200001 SR RA,RA INITIALISE RA,RB 61600001 LA RB,ZERO TO DISTINGUISH CASES 62000001 CER FA,FC 62400001 BC 12,AT080 62800001 LDR FB,FC IF X GREATER THAN 1, TAKE 63200001 DDR FB,FA INVERSE AND INCREMENT RA BY 16 63600001 LDR FA,FB 64000001 LA RA,16 64400001 AT080 CE FA,TN15 64800001 BC 12,AT090 65200001 LDR FB,FA IF X GREATER THAN TAN(PI/12), 65600001 MD FA,R3M1 (X*SQRT3 - 1)/(X + SQRT3) 66000001 SDR FA,FC COMPUTE X*SQRT3 - 1 AS 66400001 * X*(SQRT3 - 1) - 1 + X 66800001 ADR FA,FB 67200001 AD FB,ROT3 TO GAIN ACCURACY 67600001 DDR FA,FB 68000001 LA RB,8(RB) INCREMENT RB BY 8 68400001 SPACE 68800001 * COMPUTE ARCTAN OF REDUCED ARGUMENT BY 69200001 * ARCTAN(X) = X(1 +F*X**2) 69600001 * WHERE F = C1+C2/(X**2+C3+C4/(X**2+C5+C6/(X**2+C7))) 70000001 SPACE 70400001 AT090 LDR FD,FA 70800001 MDR FA,FA 71200001 LD FC,GAM7 71600001 ADR FC,FA 72000001 LD FB,GAM6 72400001 DDR FB,FC 72800001 AD FB,GAM5 73200001 ADR FB,FA 73600001 LD FC,GAM4 74000001 DDR FC,FB 74400001 AD FC,GAM3 74800001 ADR FC,FA 75200001 LD FB,GAM2 75600001 DDR FB,FC 76000001 AD FB,GAM1 76400001 MDR FA,FB 76800001 MDR FA,FD 77200001 ADR FA,FD 77600001 SPACE 78000001 AD FA,0(RA,RB) DEPENDING ON THE CASE 78400001 LNR RA,RA EITHER ADD 0 OR PI/6 78800001 SD FA,ZERO(RA) OR SUBTRACT FROM PI/3 OR PI/2 79200001 LPER FA,FA THE LATTER IN TWO STEPS 79600001 LTR RD,RD 80000001 BC 10,AT120 IF DOUBLE ENTRY AND X < 0 80400001 SD FA,PI SUBTRACT FA FROM PI 80800001 LPER FA,FA 81200001 AT120 TM OFSN(DR),X'80' SIGN OF RESULT SHOULD AGREE 81600001 BC 8,AT130 WITH SIGN OF ARGUMENT 82000001 LCER FA,FA 82400001 AT130 BC 15,AT140(RE) DEGREE TEST 82800001 AT140 MD FA,CONV 83200001 STD FA,0(RC) RESULT TO TARGET 83600001 L DR,OFDR(DR) 84000001 LM RB,RE,OFRB(DR) RESTORE REGISTERS 84400001 SPM BR RESTORE PROGRAM MASK 84800001 BCR 15,LR RETURN TO CALLER 85200001 SPACE 85600001 * CONSTANTS 86000001 SPACE 86400001 VXEP DC V(IHEERRC) 86800001 MASK DC X'7FFFFFFF' 87200001 TN15 DC X'40449851' TAN(15DEG) 87600001 BIAS DC X'0E000000' 88000001 DS 0D 88400001 PI DC X'413243F6A8885A31' PI 88800001 R3M1 DC X'40BB67AE8584CAAB' SQRT(3) - 1 89200001 GAM1 DC X'BF1E31FF1784B965' C1=-0.7371899082768562E-2 89600001 GAM2 DC X'C0ACDB34C0D1B35D' C2=-0.6752198191404210 90000001 GAM3 DC X'412B7CE45AF5C165' C3=-0.271799121409680E+1 90400001 GAM4 DC X'C11A8F923B178C78' C4=-0.166005156596000E+1 90800001 GAM5 DC X'412AB4FD5D433FF6' C5=0.2669186939532663E+1 91200001 GAM6 DC X'C02298BB68CFD869' C6=-0.135143006409492 91600001 GAM7 DC X'41154CEE8B70CA99' C7=0.1331282181443987E+1 92000001 DONE DC X'4110000000000000' 1 THESE 92400001 ROT3 DC X'411BB67AE8584CAB' SQRT(3) SIX 92800001 ZERO DC D'0' CONSTANTS 93200001 DC X'40860A91C16B9B2C' PYE/6 MUST 93600001 PIB2 DC X'C0921FB54442D184' -PI/2+1 BE 94000001 DC X'BFC152382D736574' -(PI/3-F)+1 CONSECUTIVE 94400001 CONV DC X'42394BB834C783EF' 180/PI 94800001 SPACE 4 95200001 END 95600001 ./ ADD SSI=03010090,SOURCE=1,NAME=IHEATS1 ATS TITLE ' IHEATS SHORT FLOAT REAL ATAN,ATAND *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 364 BYTES 00140001 * 00160000 * FUNCTION ATAN(X), ATAND(X), ATAN(Y,X), ATAND(Y,X), WHERE 00180000 * X AND Y ARE SHORT FLOAT REAL. 00200000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00220000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00240000 * 00260000 * ENTRY POINTS 00280000 * IHEATS1 - ATAN(X) 00300000 * RA = A(PLIST) 00320000 * PLIST = A(X) 00340000 * A(TARGET) 00360000 * IHEATS2 - ATAN(Y,X) 00380000 * RA = A(PLIST) 00400000 * PLIST = A(Y) 00420000 * A(X) 00440000 * A(TARGET) 00460000 * IHEATS3 - ATAND(X) 00480000 * RA = A(PLIST) 00500000 * PLIST = A(X) 00520000 * A(TARGET) 00540000 * IHEATS4 - ATAND(Y,X) 00560000 * RA = A(PLIST) 00580000 * PLIST = A(Y) 00600000 * A(X) 00620000 * A(TARGET) 00640000 * 00660000 * INPUT N/A 00680000 * 00700000 * OUTPUT N/A 00720000 * 00740000 * EXTERNAL MODULES 00760000 * N/A 00780000 * 00800000 * EXITS NORMAL 00820000 * RETURN TO CALLER VIA LINK REGISTER. 00840000 * ERROR 00860000 * BRANCH TO THE ENTRY POINT IHERRC OF THE EXECUTION 00880000 * PACKAGE IF X = Y = 0 GIVEN AS ARGUMENTS TO 00900000 * ATAN(Y,X) OR ATAND(Y,X). 00920000 * 00940000 * TABLES/WORK-AREA 00960000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00980000 * 01000000 * ATTRIBUTES READ-ONLY AND REENTRANT. 01020000 * 01040000 * PRIVATE MACROS 01060000 * IHELIB,IHESDR 01080000 * 01100000 * ASSEMBLY REQUIREMENTS 01120000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 01140000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01160000 * 01180000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01200000 * STANDARDS. 01220000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01240000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01260000 * EXTERNAL CHARACTER SET. 01280000 EJECT 01300000 IHEATS CSECT 01320000 SPACE 2 01340000 IHELIB 01360000 SPACE 01500000 * PRIVATE OFFSETS 01520000 SPACE 01540000 OFSN EQU 72 01560000 EJECT 01580000 IHEATS CSECT 01600000 SPACE 01620000 * ENTRY POINTS 01640000 SPACE 01660000 ENTRY IHEATS1,IHEATS2,IHEATS3,IHEATS4 01680000 SPACE 01700000 * *********************** 01720000 * * ENTRY POINT * 01740000 * * FOR ATAND(Y/X) * 01760000 * *********************** 01780000 SPACE 01800000 USING *,BR 01820000 IHEATS4 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01840000 SR RE,RE SET RE DEGREES 01860001 BAL BR,AT010 01880000 * *********************** 01900000 * * ENTRY POINT * 01920000 * * FOR ATAN(Y/X) * 01940000 * *********************** 01960000 USING *,BR 01980000 IHEATS2 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 02000000 LA RE,4 SET RE RADIANS 02020001 AT010 LA RD,1 SET RD FOR DOUBLE ARG. ENTRY 02040001 IHESDR LW0,RB 02060000 LM RA,RC,0(RA) 02080000 BC 15,AT030 02100000 * *********************** 02120000 * * ENTRY POINT * 02140000 * * FOR ATAND(X) * 02160000 * *********************** 02180000 USING *,BR 02200000 IHEATS3 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 02220000 SR RE,RE SET RE DEGREES 02240001 BAL BR,AT020 02260000 * *********************** 02280000 * * ENTRY POINT * 02300000 * * FOR ATAN(X) * 02320000 * *********************** 02340000 USING *,BR 02360000 IHEATS1 STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 02380000 LA RE,4 SET RE RADIANS 02400001 AT020 SR RD,RD SET RD FOR SINGLE ARG. ENTRY 02420001 IHESDR LW0,RB 02440000 L RC,4(RA) RC POINTS TO TARGET 02460000 L RA,0(RA) RA POINTS TO SINGLE ARGUMENT 02480000 AT030 LE FA,0(RA) OBTAIN FIRST OR ONLY ARGUMENT 02500000 STE FA,OFSN(DR) SAVE ITS SIGN 02520000 BALR BR,0 SAVE PROGRAM MASK 02540000 USING *,BR 02560000 SPM RE DISABLE UNDERFLOW 02580001 LTR RD,RD 02600001 BC 8,AT070 IF SINGLE ARGUMENT ENTRY BRANCH 02640000 * TO MAIN CIRCUIT 02660000 LE FB,0(RB) OBTAIN 2ND ARGUMENT X 02680000 L RD,0(RB) 02690001 STE FB,OFSN+4(DR) SAVE ITS SIGN 02700000 LM RA,RB,OFSN(DR) IF X = 0, OR IF ABS(Y/X) IS 02720000 N RB,MASK GREATER THAN 2**24, GIVE 02740000 BC 8,AT040 SIGN(Y)*PI/2 AS ANSWER 02760001 N RA,MASK 02780000 SR RA,RB 02800000 C RA,BIAS 02810001 BC 12,AT060 02820001 BC 15,AT045 02830001 AT040 LTER FA,FA 02860000 BC 8,AT050 IF Y = X = 0 ERROR 02880000 AT045 LE FA,PIB2 02910001 BC 15,AT110 02940001 AT050 SPM BR RESTORE PROGRAM MASK 02980000 L BR,VXEP 03000000 BALR RA,BR 03020000 DC H'261' ERROR CODE 03040000 SPACE 03060000 AT060 DER FA,FB JOIN MAIN CIRCUIT WITH Y/X 03080001 SPACE 03120000 * MAIN CIRCUIT 03140000 SPACE 03160000 AT070 LPER FA,FA FORCE SIGN POSITIVE 03180000 LE FC,EONE 03190001 SR RA,RA RA FOR DISTINGUISHING CASES 03200001 CER FA,FC 03210001 BC 12,AT080 03240000 LER FB,FC IF X GREATER THAN 1, TAKE 03260001 DER FB,FA INVERSE AND 03280001 LER FA,FB 03300000 LA RA,8 INCREMENT RA BY 8 03320001 AT080 CE FA,TN15 03340000 BC 12,AT090 03360000 LER FB,FA IF X GREATER THAN TAN(PI/12) 03380000 ME FA,RT3M1 REDUCE X BY USING 03400001 SER FA,FC ATAN(X) = PI/6 + ATAN(Y) 03420001 AER FA,FB Y=(X*SQRT(3)-1)/(X+SQRT(3)) USE 03440001 AE FB,ROT3 X(SQRT(3)-1)-1+X FOR X*SQRT(3)-1 03460001 DER FA,FB TO PROTECT SIGNIFICANT DIGITS. 03480001 LA RA,4(RA) INCREMENT RA BY 4 03500001 SPACE 03520000 * COMPUTE ARCTAN OF REDUCED ARGUMENT BY 03540000 * ATAN(X)/X = D + C*X*X + B/(X*X + A) 03560001 SPACE 03580000 AT090 LER FC,FA NOW MAGNITUDE OF REDUCED 03600001 MER FA,FA ARGUMENT IS LESS THAN 03620001 LER FB,FA TAN(PI/12) = 0.26795 03640001 ME FA,XATC 03660001 AE FB,XATA COMPUTE ANGLE BY 03680001 LE FD,XATB ATAN(X)/X=D+C*XSQ+B/(XSQ+A) 03700001 DER FD,FB 03720001 AER FA,FD 03740001 AE FA,XATD 03780000 MER FA,FC 03800000 SPACE 03820000 AE FA,ZERO(RA) DEPENDING ON THE SECTION 03850001 LPER FA,FA TO WHICH THE ANSWER BELONGS 03880001 LTR RD,RD 03910001 BC 10,AT120 03940001 SE FA,XXPI IF ENTRY WAS IHEATS2 OR 4 AND X2 03970001 AT110 LPER FA,FA IS NEGATIVE SUBTRACT FA FROM PI 04000001 AT120 TM OFSN(DR),X'80' 04030001 BC 8,AT130 04060001 LCER FA,FA 04090001 AT130 BC 15,AT140(RE) DEGREE TEST 04120001 AT140 ME FA,CONV 04180000 STE FA,0(RC) RESULT TO TARGET 04200000 SPM BR RESTORE PROGRAM MASK 04220000 L DR,OFDR(DR) 04240000 LM RB,RE,OFRB(DR) RESTORE REGISTERS 04260000 BCR 15,LR RETURN TO CALLER 04300000 EJECT 04320000 * CONSTANTS 04340000 SPACE 04360000 VXEP DC V(IHEERRC) 04400000 XXPI DC X'413243F7' PI 04420000 EONE DC X'41100000' 1 04440000 TN15 DC X'40449851' TAN(15DEG) 04460000 ROT3 DC X'411BB67B' SQRT(3) 04500000 RT3M1 DC X'40BB67AF' SQRT(3)-1 04510001 XATA DC X'41168A5E' 1.4087812 04520000 XATB DC X'408F239C' 0.55913709 04540000 XATC DC X'BFD35F49' -0.051604543 04560001 XATD DC X'409A6524' 0.60310579 04580000 ZERO DC F'0' 04600000 DC X'40860A92' PI/6 04620000 PIB2 DC X'C11921FB' -PI/2 04640001 DC X'C110C152' -PI/3 04660001 BIAS DC X'06000000' 04680000 MASK DC X'7FFFFFFF' 04700000 CONV DC X'42394BB8' 180/PI 04720000 SPACE 4 04740000 END 04760000 ./ ADD SSI=03010050,SOURCE=1,NAME=IHEATWN ATW TITLE ' IHEATW SHORT FLOAT COMPLEX ATAN, ATANH *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 288 BYTES 00140001 * 00160000 * FUNCTION ATAN(Z), ATANH(Z) WHERE Z IS SHORT FLOAT COMPLEX. 00180000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00200000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEATWN - ATAN(Z) 00280000 * RA = A(PLIST) 00300000 * PLIST = A(Z) 00320000 * A(TARGET) 00340000 * IHEATWH - ATANH(Z) 00360000 * RA = A(PLIST) 00380000 * PLIST = A(Z) 00400000 * A(TARGET) 00420000 * 00440000 * INPUT N/A 00460000 * 00480000 * OUTPUT N/A 00500000 * 00520000 * EXTERNAL MODULES 00540000 * IHEATS - ATAN(Y,X) WHERE X AND Y ARE SHORT FLOAT REAL 00560000 * IHEHTS - ATANH(X) WHERE X IS SHORT FLOAT REAL 00580000 * 00600000 * EXITS NORMAL 00620000 * RETURN TO CALLER VIA LINK REGISTER. 00640000 * ERROR 00660000 * BRANCH TO THE ENTRY POINT IHEERRC OF THE EXECUTION 00680000 * ERROR PACKAGE IF Z = 0 + 1I OR 0 - 1I IS GIVEN AS 00700000 * ARGUMENT TO IHEATWN OR IF Z = 1 + 0I OR -1 + 0I IS 00720000 * GIVEN AS ARGUMENT TO IHEATWH 00740000 * 00760000 * TABLES/WORK-AREA 00780000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00800000 * 00820000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00840000 * 00860000 * PRIVATE MACROS 00880000 * IHELIB,IHESDR 00900000 * 00920000 * ASSEMBLY REQUIREMENTS 00940000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00960000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00980000 * 01000000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01020000 * STANDARDS. 01040000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01060000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01080000 * EXTERNAL CHARACTER SET. 01100000 EJECT 01120000 IHEATW CSECT 01140000 SPACE 2 01160000 IHELIB 01180000 SPACE 01200000 SPACE 01280000 * PRIVATE OFFSETS 01300000 SPACE 01320000 OP00 EQU 72 01340000 OP04 EQU 76 01360000 OP08 EQU 80 01380000 OP12 EQU 84 01400000 OP16 EQU 88 01420000 OP20 EQU 92 01440000 EJECT 01460000 IHEATW CSECT 01480000 SPACE 01500000 * ENTRY POINTS 01520000 SPACE 01540000 ENTRY IHEATWN,IHEATWH 01560000 SPACE 01580000 * *********************** 01600000 * * ENTRY POINT * 01620000 * * FOR ATAN(Z) * 01640000 * *********************** 01660000 SPACE 01680000 USING *,BR 01700000 IHEATWN STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01720000 IHESDR LW2,LR 01740000 LM RA,RB,0(RA) RA CONTAINS ADDRESS OF X AND Y 01760000 * RB CONTAINS ADDRESS OF TARGET 01780000 LE FA,4(RA) 01800000 LCER FA,FA FA = -Y = U 01820000 LE FB,0(RA) FB = X = V 01840000 SR RC,RC SET RC FOR ATAN 01860001 BAL BR,MERGE 01880000 * *********************** 01900000 * * ENTRY POINT * 01920000 * * FOR ATANH(Z) * 01940000 * *********************** 01960000 USING *,BR 01980000 IHEATWH STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 02000000 IHESDR LW2,LR 02020000 LM RA,RB,0(RA) RA CONTAINS ADDRESS OF X AND Y 02040000 * RB CONTAINS ADDRESS OF TARGET 02060000 LE FA,0(RA) FA = X = U 02080000 LE FB,4(RA) FB = Y = V 02100000 LA RC,6 SET RC FOR ATANH 02120001 MERGE LPER FC,FA 02140000 LPER FD,FB 02160000 BC 7,ARGOK OK IF V NON-ZERO 02180000 CE FC,EONE TEST U 02200000 BC 7,ARGOK OK IF U NOT 1 02220000 L BR,VXEP IF U=1, V=0 02240000 BALR RA,BR BRANCH TO EXEP 02260000 DC H'280' ERROR CODE 02280000 ARGOK CE FC,XMAX BRANCH IF ABS(U) OR ABS(V) 02300000 BC 10,LARGE GREATER THAN LIMIT 02320000 CE FD,XMAX 02340000 BC 10,LARGE 02360000 LER FC,FA FC = U 02380000 LER FD,FB FD = V 02400000 AER FD,FD FD = 2*V 02420000 STE FD,OP00(DR) 02440000 BALR RD,0 SAVE PROGRAM MASK 02460000 USING *,RD 02480000 SPM RC DISABLE UNDERFLOW 02500001 MER FA,FA U*U 02520000 MER FB,FB V*V 02540000 ADR FA,FB COMPUTE U*U + V*V IN FA 02560000 SWR FB,FB IN DOUBLE PRECISION 02580000 LER FB,FA AND ROUND TO 02600000 SWR FB,FA SINGLE LENGTH 02620000 SWR FA,FB 02640000 LCER FB,FA FB = -(U*U + V*V) 02660000 AE FA,EONE FA = 1 + U*U + V*V 02680000 AE FB,EONE FB = 1 - (U*U + V*V) 02700000 AER FC,FC FC = 2*U 02720000 DER FC,FA FC = 2*U/(1+(U*U+V*V)) 02740000 * = ARGUMENT FOR ARCTANH 02760000 STE FC,OP08(DR) SAVE FC 02780000 STE FB,OP04(DR) SAVE FB = 1 -(U*U + V*V) 02800000 LA BR,OP00(DR) 02820000 LA R0,OP04(DR) CONSTRUCT ARGUMENT LIST 02840000 LA RA,OP12(DR) FOR ARCTAN IN TARGET 02860000 STM BR,RA,OP20(DR) 02880000 LA RA,OP20(DR) POINT RA AT LIST 02900000 L BR,VATN 02920000 BALR LR,BR 02940000 SPACE 02960000 * AFTER BRANCH TO ARCTAN ROUTINE OP12 CONTAINS 02980000 * ARCTAN(2*V/(1-(U*U + V*V))) 03000000 SPACE 03020000 USING *,LR 03040000 LA R0,OP08(DR) ARGUMENT FOR ARCTANH 03060000 ST R0,OP16(DR) 03080000 LA RA,OP16(DR) POINT RA AT LIST 03100000 L BR,VATH 03120000 BALR LR,BR 03140000 SPACE 03160000 * AFTER BRANCH TO ARCTANH ROUTINE OP00 CONTAINS 03180000 * ARCTANH(2*U/(1 + U*U + V*V) 03200000 SPACE 03220000 USING *,LR 03240000 LE FA,OP00(DR) 03260000 HER FA,FA COMPUTE (ARCTANH(...))/2 03280001 LE FB,OP12(DR) 03300000 HER FB,FB COMPUTE (ARCTAN(...))/2 03320001 SPM RD RESTORE PROGRAM MASK 03340000 ENTST BALR LR,0 03360000 USING *,LR 03380000 BC 15,ALTER(RC) 03400001 ALTER LER FC,FA IF ARCTAN ENTRY, SWITCH REAL 03420000 LER FA,FB AND IMAGINARY PARTS AND TAKE 03440000 LCER FB,FC COMPLEMENT OF LATTER 03460000 STE FA,0(RB) REAL PART TO TARGET 03480000 STE FB,4(RB) IMAG PART TO TARGET 03500000 L DR,OFDR(DR) 03520000 LM LR,RD,OFLR(DR) RESTORE REGISTERS 03540000 BCR 15,LR RETURN TO CALLER 03580000 SPACE 03600000 DROP LR 03620000 DROP RD 03640000 LARGE SER FA,FA 03660000 LE FC,PIB2 03680000 LTER FB,FB 03700000 BC 10,RJOIN IF U AND V LARGE SET RESULT 03720000 LCER FC,FC TO 0 + PI/2*I FOR POSITIVE V 03740000 RJOIN LER FB,FC AND 0 -PI/2*I FOR NEGATIVE V 03760000 BC 15,ENTST 03780000 EJECT 03800001 * CONSTANTS 03820000 SPACE 03840000 VXEP DC V(IHEERRC) 03860000 VATN DC V(IHEATS2) 03880000 VATH DC V(IHEHTS0) 03900000 XMAX DC X'602D413D' SQRT((16**63)/2) 03920000 EONE DC X'41100000' 1 03960000 PIB2 DC X'411921FB' PI/2 03980000 SPACE 4 04000000 END 04020000 ./ ADD SSI=03010090,SOURCE=1,NAME=IHEATZN ATZ TITLE ' IHEATZ LONG FLOAT COMPLEX ATAN,ATANH *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 288 BYTES 00140001 * 00160000 * FUNCTION ATAN(Z), ATANH(Z) WHERE Z IS LONG FLOAT COMPLEX. 00180000 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 00200000 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEATZN - ATAN(Z) 00280000 * RA = A(PLIST) 00300000 * PLIST = A(Z) 00320000 * A(TARGET) 00340000 * IHEATZH - ATANH(Z) 00360000 * RA = A(PLIST) 00380000 * PLIST = A(Z) 00400000 * A(TARGET) 00420000 * 00440000 * INPUT N/A 00460000 * 00480000 * OUTPUT N/A 00500000 * 00520000 * EXTERNAL MODULES 00540000 * IHEATL - ATAN(Y,X) WHERE X AND Y ARE LONG FLOAT REAL 00560000 * IHEHTL - ATANH(X) WHERE X IS LONG FLOAT REAL 00580000 * 00600000 * EXITS NORMAL 00620000 * RETURN TO CALLER VIA LINK REGISTER. 00640000 * ERROR 00660000 * BRANCH TO THE ENTRY POINT IHEERRC OF THE EXECUTION 00680000 * ERROR PACKAGE IF Z = 0+1I OR 0-1I IS GIVEN AS ARGUMENT 00700000 * TO IHEATZN OR IF Z = 1+0I OR -1+0I IS GIVEN AS ARGUMENT 00720000 * TO IHEATZH 00740000 * 00760000 * TABLES/WORK-AREA 00780000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00800000 * 00820000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00840000 * 00860000 * PRIVATE MACROS 00880000 * IHELIB,IHESDR 00900000 * 00920000 * ASSEMBLY REQUIREMENTS 00940000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00960000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00980000 * 01000000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01020000 * STANDARDS. 01040000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01060000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01080000 * EXTERNAL CHARACTER SET. 01100000 EJECT 01120000 IHEATZ CSECT 01140000 SPACE 2 01160000 IHELIB 01180000 SPACE 01260000 * PRIVATE OFFSETS 01280000 SPACE 01300000 OP00 EQU 72 01320000 OP08 EQU 80 01340000 OP16 EQU 88 01360000 OP24 EQU 96 01380000 EJECT 01400000 IHEATZ CSECT 01420000 SPACE 01440000 * ENTRY POINTS 01460000 SPACE 01480000 ENTRY IHEATZN,IHEATZH 01500000 SPACE 01520000 * *********************** 01540000 * * ENTRY POINT * 01560000 * * FOR ATAN(Z) * 01580000 * *********************** 01600000 SPACE 01620000 USING *,BR 01640000 IHEATZN STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01660000 IHESDR LW2,LR 01680000 LM RA,RB,0(RA) RA CONTAINS ADDRESS OF X AND Y 01700000 * RB CONTAINS ADDRESS OF TARGET 01720000 LD FA,8(RA) 01740000 LCER FA,FA FA = -Y = U 01760000 LD FB,0(RA) FB = X = V 01780000 SR RC,RC SET RC FOR ATAN 01800001 BAL BR,MERGE 01820000 * *********************** 01840000 * * ENTRY POINT * 01860000 * * FOR ATANH(Z) * 01880000 * *********************** 01900000 USING *,BR 01920000 IHEATZH STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01940000 IHESDR LW2,LR 01960000 LM RA,RB,0(RA) RA CONTAINS ADDRESS OF X AND Y 01980000 * RB CONTAINS ADDRESS OF TARGET 02000000 LD FA,0(RA) FA = X = U 02020000 LD FB,8(RA) FB = Y = V 02040000 LA RC,6 SET RC FOR ATANH 02060001 MERGE LPDR FC,FA 02080000 LPDR FD,FB 02100000 BC 7,ARGOK OK IF V NON-ZERO 02120000 CD FC,DONE TEST U 02140000 BC 7,ARGOK OK IF U NOT 1 02160000 L BR,VXEP IF U=1, V=0 02180000 BALR RA,BR BRANCH TO EXEP 02200000 DC H'281' ERROR CODE 02220000 ARGOK CE FC,XMAX BRANCH IF ABS(U) OR ABS(V) 02240000 BC 10,LARGE GREATER THAN LIMIT 02260000 CE FD,XMAX 02280000 BC 10,LARGE 02300000 LDR FC,FA FC = U 02320000 LDR FD,FB FD = V 02340000 ADR FD,FD FD = 2*V 02360000 STD FD,OP00(DR) 02380000 BALR RD,0 SAVE PROGRAM MASK 02400000 USING *,RD 02420000 SPM RC DISABLE UNDERFLOW 02440001 MDR FA,FA U*U 02460000 MDR FB,FB V*V 02480000 ADR FA,FB FA = U*U + V*V 02500000 LCDR FB,FA FB = -(U*U + V*V) 02520000 AD FA,DONE FA = 1 + U*U + V*V 02540000 AD FB,DONE FB = 1 - (U*U + V*V) 02560000 ADR FC,FC FC = 2*U 02580000 DDR FC,FA FC = 2*U/(1+(U*U+V*V)) 02600000 * = ARGUMENT FOR ARCTANH 02620000 STD FC,OP16(DR) SAVE FC 02640000 STD FB,OP08(DR) SAVE FB = 1 -(U*U + V*V) 02660000 LA BR,OP00(DR) 02680000 LA R0,OP08(DR) CONSTRUCT ARGUMENT LIST 02700000 LA RA,OP24(DR) FOR ARCTAN IN TARGET 02720000 STM BR,RA,0(RB) 02740000 LR RA,RB POINT RA AT LIST 02760000 L BR,VATN 02780000 BALR LR,BR 02800000 SPACE 02820000 * AFTER BRANCH TO ARCTAN ROUTINE OP24 CONTAINS 02840000 * ARCTAN(2*V/(1-(U*U + V*V))) 02860000 SPACE 02880000 USING *,LR 02900000 LA R0,OP16(DR) ARGUMENT FOR ARCTANH 02920000 LA RA,OP00(DR) TARGET FOR ARCTANH 02940000 STM R0,RA,0(RB) SET UP LIST 02960000 LR RA,RB POINT RA AT LIST 02980000 L BR,VATH 03000000 BALR LR,BR 03020000 SPACE 03040000 * AFTER BRANCH TO ARCTANH ROUTINE OP00 CONTAINS 03060000 * ARCTANH(2*U/(1 + U*U + V*V) 03080000 SPACE 03100000 USING *,LR 03120000 LD FA,OP00(DR) 03140000 HDR FA,FA 03160001 * COMPUTE (ARCTANH(...))/2 03180001 LD FB,OP24(DR) 03200000 HDR FB,FB 03220001 * COMPUTE (ARCTAN(...))/2 03240001 SPM RD RESTORE PROGRAM MASK 03260000 ENTST BALR LR,0 03280000 USING *,LR 03300000 BC 15,ALTER(RC) 03320001 ALTER LDR FC,FA IF ARCTAN ENTRY, SWITCH REAL 03340000 LDR FA,FB AND IMAGINARY PARTS AND TAKE 03360000 LCDR FB,FC COMPLEMENT OF LATTER 03380000 STD FA,0(RB) REAL PART TO TARGET 03400000 STD FB,8(RB) IMAG PART TO TARGET 03420000 L DR,OFDR(DR) 03440000 LM LR,RD,OFLR(DR) RESTORE REGISTERS 03460000 BCR 15,LR RETURN TO CALLER 03500000 SPACE 03520000 DROP LR 03540000 DROP RD 03560000 LARGE SDR FA,FA 03580000 LD FC,PIB2 03600000 LTER FB,FB 03620000 BC 10,RJOIN IF U AND V LARGE, SET RESULT 03640000 LCER FC,FC TO 0 + PI/2*I FOR +VE V 03660000 RJOIN LDR FB,FC OR 0 - PI/2*I FOR -VE V 03680000 BC 15,ENTST 03700000 EJECT 03720001 * CONSTANTS 03740000 SPACE 03760000 VXEP DC V(IHEERRC) 03780000 VATN DC V(IHEATL2) 03800000 VATH DC V(IHEHTL0) 03820000 XMAX DC X'602D413D' SQRT((16**63)/2) 03840000 DS 0D 03860000 DONE DC X'4110000000000000' 1 03880000 PIB2 DC X'411921FB54442D18' PI/2 03900000 SPACE 4 03920000 END 03940000 ./ ADD SSI=02011972,SOURCE=1,NAME=IHEBEGN BEG4 TITLE 'STORAGE MANAGEMENT WTO MODULE OS/360 PL/I LIBRARY' 05000015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*BEG000-TSS 07000001 IHEBEG CSECT 10000015 * ----------------------------------------------------BEG000-TSS 12000001 ENTRY IHEBEGN,IHEBEGA 15000015 IHELIB 20000015 IHEBEG CSECT 25000015 USING *,BR 30000015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*BEG001-TSS 30400001 IHEBEGN EQU * I9 30800016 BALR WR,0 I9 31600016 USING *,WR I9 32400016 GETMAIN R,LV=136 I9 33200016 ST DR,OFDR(RA) I9 34000016 LR DR,RA I9 34800016 * PUT OUT MESSAGE - NO MAIN PROCEDURE I9 35600016 LINK EP=IHETOMA I9 36400016 LR RA,DR I9 37200016 FREEMAIN R,LV=136,A=(1) I9 38000016 L DR,OFDR(DR) I9 38800016 LM LR,PR,OFLR(DR) 40000015 LA BR,4008 RETURN CODE 45000015 BR LR 50000015 * ----------------------------------------------------BEG001-TSS 52000001 * 55000015 * * * * 60000015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*BEG002-TSS 62000001 USING *,BR 65000015 IHEBEGA EQU * I9 65800016 BALR WR,0 I9 66600016 USING *,WR I9 67400016 GETMAIN R,LV=144 I9 68200016 ST DR,OFDR(RA) I9 69000016 LR DR,RA I9 69800016 * PUT OUT MESSAGE - PRV GT 4096 I9 70600016 LINK EP=IHETOMB I9 71400016 LR RA,DR I9 72200016 FREEMAIN R,LV=144,A=(1) I9 73000016 L DR,OFDR(DR) I9 73800016 LM LR,PR,OFLR(DR) 75000015 LA BR,4004 80000015 BR LR 85000015 * ----------------------------------------------------BEG002-TSS 87000001 END 90000015 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEBSA0 BSA TITLE ' IHEBSA BIT STRING ''AND'' *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 296 BYTES 00140000 * 00160000 * FUNCTION TO IMPLEMENT THE 'AND' OPERATOR BETWEEN TWO BYTE-ALIGNED 00180000 * BIT STRINGS, PLACING THE RESULT IN A BYTE-ALIGNED 00200000 * TARGET FIELD. 00220000 * THE CURRENT LENGTH OF THE TARGET STRING IS SET EQUAL TO 00240000 * EITHER THE MAXIMUM OF THOSE OF THE OPERANDS, OR THE 00260000 * MAXIMUM LENGTH OF THE TARGET FIELD (WHEN TRUNCATION IS 00280000 * NECESSARY TO AVOID EXCEEDING THE LENGTH OF THIS FIELD). 00300000 * THE MINIMUM OF THE LENGTHS OF THE OPERANDS AND THE 00320000 * TARGET FIELD IS THEN USED TO CONTROL THE MOVING OF THE 00340000 * FIRST OPERAND TO THE TARGET FIELD AND THE SUBSEQUENT 00360000 * STORAGE-TO-STORAGE 'AND' (NC) INSTRUCTION(S). INCOMPLETE 00380000 * LAST BYTES ARE HANDLED IN REGISTERS AND ANY BITS 00400000 * REMAINING UP TO THE CURRENT LENGTH CALCULATED FOR THE 00420000 * TARGET FIELD ARE SET TO ZERO. 00440000 * 00460000 * ENTRY POINTS 00480000 * IHEBSA0 00500000 * RA = A(SDV OF FIRST OPERAND) 00520000 * RB = A(SDV OF SECOND OPERAND) 00540000 * RC = A(SDV OF TARGET FIELD) 00560000 * 00580000 * INPUT N/A 00600000 * 00620000 * OUTPUT N/A 00640000 * 00660000 * EXTERNAL MODULES 00680000 * N/A 00700000 * 00720000 * EXITS NORMAL 00740000 * RETURN TO CALLER VIA LINK REGISTER. 00760000 * 00780000 * TABLES/WORK-AREA 00800000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00820000 * 00840000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00860000 * 00880000 * PRIVATE MACROS 00900000 * IHELIB,IHESDR 00920000 * 00940000 * ASSEMBLY REQUIREMENTS 00960000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00980000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01000000 * 01020000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01040000 * STANDARDS. 01060000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01080000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01100000 * EXTERNAL CHARACTER SET. 01120000 EJECT 01140000 IHEBSA CSECT 01160000 SPACE 2 01180000 IHELIB 01200000 SPACE 01220000 * PRIVATE REGISTER ASSIGNMENTS. 01240000 SPACE 01260000 IND EQU R0 01280000 RS1 EQU RA 01300000 RS2 EQU RB 01320000 RT1 EQU RC 01340000 RE1 EQU RD MUST BE 01360000 RO1 EQU RE EVEN-ODD PAIR. 01380000 OFF EQU RF 01400000 LNK EQU LR 01420000 BAS EQU BR 01440000 SPACE 01460000 * PRIVATE OFFSETS. 01480000 SPACE 01500000 LFLD EQU 6 01520000 MFLD EQU 4 01540000 EJECT 01560000 IHEBSA CSECT 01580000 SPACE 01600000 ENTRY IHEBSA0 01620000 SPACE 2 01640000 USING *,BAS 01660000 IHEBSA0 STM LR,RX,OFLR(DR) 01680000 IHESDR LW0,RE 01700000 LH IND,LFLD(RS1) 01720000 LH RE1,LFLD(RS2) 01740000 LH RO1,MFLD(RT1) 01760000 CR IND,RO1 SET IND TO CURRENT LENGTH OF FIRST 01780000 BC 12,BA010 STRING OR MAXIMUM LENGTH OF TARGET 01800000 LR IND,RO1 WHICHEVER IS LEAST. 01820000 BA010 CR RE1,RO1 SET RE1 TO CURRENT LENGTH OF SECOND 01840000 BC 12,BA020 STRING OR MAXIMUM LENGTH OF TARGET 01860000 LR RE1,RO1 WHICHEVER IS LEAST. 01880000 BA020 SR IND,RE1 RE1 CONTAINS THE LENGTH TO BE AND-ED 01900000 BC 10,BA030 AND IND THE LENGTH TO BE ZEROED 01920000 AR RE1,IND (NEGATIVE IF STRING 2 LONGER) 01940000 BA030 LPR RO1,IND STORE THE SUM OF THESE LENGTHS 01960000 AR RO1,RE1 IN THE TARGET SDV CURRENT 01980000 STH RO1,LFLD(RT1) LENGTH SLOT. 02000000 L RS1,0(RS1) LOAD RS1,RS2,RT1 WITH THE ADDRESSES 02020000 L RS2,0(RS2) OF THE SOURCE AND TARGET 02040000 L RT1,0(RT1) FIELDS. 02060000 SRDL RE1,3 CONVERT THE LENGTH IN BITS TO A BYTE 02080000 SRL RO1,29 LENGTH AND BIT OVERLAP. 02100000 LCR OFF,RO1 SAVE THE COMPLEMENT OF THE OVERLAP. 02120000 SH RE1,BAX01+2 SUBTRACT 1 02140000 BC 4,BA040 BRANCH IF LENGTH LESS THAN A BYTE. 02160000 SRDL RE1,8 SET RE1 TO NUMBER OF TIMES THROUGH 02180000 SRL RO1,24 LOOP, RO1 TO LENGTH IN BYTES 02200000 BAX01 LA RE1,1(RE1,0) ON FIRST TIME 02220000 SPACE 02240000 BANCL EX RO1,BAMVI MOVE DATA FROM 1ST SOURCE TO TARGET. 02260000 EX RO1,BANCI 'AND' 2ND SOURCE DATA WITH IT. 02280000 LA RT1,1(RO1,RT1) ADD LENGTH MOVED TO TARGET 02300000 LA RS1,1(RO1,RS1) AND SOURCE 02320000 LA RS2,1(RO1,RS2) ADDRESSES 02340000 LA RO1,255 SET RO1 TO 255 AFTER FIRST SEGMENT. 02360000 BCT RE1,BANCL LOOP IF MORE SEGMENTS 02380000 SPACE 02400000 BA040 LPR RE1,IND RE1 NOW HAS LENGTH TO BE ZEROED. 02420000 SR RE1,OFF ADD BIT OVERLAP TO LENGTH IN RE1. 02440000 BC 8,BA070 RETURN IF LENGTH ZERO. THIS BRANCH 02460000 * IS TAKEN ONLY WHEN THE STRINGS 02480000 * ARE OF EQUAL LENGTH AND END ON A 02500000 * BYTE BOUNDARY 02520000 IC RS1,0(RS1) THE BYTES ADDRESSED BY RS1 AND RS2 02540000 IC RS2,0(RS2) CONTAIN THE OVERLAPPED BITS AT THE 02560000 NR RS1,RS2 END OF THE DATA TO BE 'AND'ED.THE 02580000 SRL RS1,8(OFF) BITS ARE'AND'-ED INTO RS1 AND 02600000 SLL RS1,8(OFF) ZEROS PUT IN THE REST OF THE BYTE. 02620000 SRDL RE1,3 CONVERT TO BYTE LENGTH AND BIT 02640000 SRL RO1,29 OVERLAP IN RE1 02660000 LR OFF,RO1 AND OFF RESPECTIVELY 02680000 SH RE1,BAX01+2 SUBTRACT 1 02700000 BC 4,BA060 BRANCH IF LENGTH LESS THAN A BYTE 02720000 STC RS1,0(RT1) STORE BYTE HELD BY RS1 IN TARGET. 02740000 SH RE1,BAX01+2 SUBTRACT 1 02760000 BC 4,BA050 BRANCH IF LESS THAN A BYTE. 02780000 LA RT1,1(0,RT1) ADD 1 TO TARGET ADDRESS. 02800000 MVI 0(RT1),X'00' MOVE IN A BYTE OF ZEROS. 02820000 SH RE1,BAX01+2 SUBTRACT 1 02840000 BC 4,BA050 BRANCH IF LESS THAN A BYTE. 02860000 SRDL RE1,8 SET RE1 TO NUMBER OF TIMES THROUGH 02880000 SRL RO1,24 LOOP, RO1 TO LENGTH IN BYTES 02900000 LA RE1,1(0,RE1) OF FIRST MOVE. 02920000 SPACE 02940000 BAMZL EX RO1,BAMZI PROPAGATE ZEROS THROUGH LENGTH RO1 02960000 LA RT1,1(RO1,RT1) ADD LENGTH MOVED TO TARGET ADDRESS. 02980000 LA RO1,255 SET RO1 TO 255 AFTER FIRST SEGMENT 03000000 BCT RE1,BAMZL LOOP IF MORE SEGMENTS 03020000 SPACE 03040000 BA050 LTR OFF,OFF TEST FOR ZERO OVERLAP 03060000 BC 8,BA070 IF SO, RETURN TO CALLER. 03080000 SR RS1,RS1 ZERO RS1 FOR USE IN OR INSTRUCTION 03100000 LA RT1,1(0,RT1) ADDRESS LAST BYTE 03120000 BA060 IC RO1,0(RT1) ZERO BITS OVERLAPPING 03140000 SLL RO1,24(OFF) LAST 03160000 SRL RO1,24(OFF) BYTE 03180000 OR RO1,RS1 RS1 IS ZERO EXCEPT WHERE SOURCE 03200000 * STRINGS HAD SAME NUMBER OF FULL 03220000 * BYTES. 03240000 STC RO1,0(RT1) STORE. 03260000 BA070 L DR,OFDR(DR) 03280000 LM RB,RF,OFRB(DR) 03300000 MVI OFLR(DR),X'FF' 03320000 BCR 15,LNK RETURN TO CALLER 03340000 EJECT 03360000 * EXECUTED INSTRUCTIONS. 03380000 SPACE 03400000 BAMVI MVC 0(1,RT1),0(RS1) EXECUTED MOVE INSTRUCTION. 03420000 BANCI NC 0(1,RT1),0(RS2) EXECUTED 'AND' INSTRUCTION 03440000 BAMZI MVC 1(1,RT1),0(RT1) EXECUTED ZERO PROPAGATION INSTR. 03460000 SPACE 4 03480000 END 03500000 ./ ADD SSI=03011640,SOURCE=1,NAME=IHEBSC0 BSC TITLE ' IHEBSC BIT STRING ALIGNED COMPARE *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 272 BYTES 00140000 * 00160000 * FUNCTION TO COMPARE TWO BYTE-ALIGNED BIT STRINGS AND TO RETURN 00180000 * A CONDITION CODE AS FOLLOWS 00200000 * 0 IF THE STRINGS ARE EQUAL 00220000 * 1 IF THE SECOND STRING HAS A 1 AT THE FIRST INEQUALITY 00240000 * 2 IF THE FIRST STRING HAS A 1 AT THE FIRST INEQUALITY 00260000 * THE SHORTER STRING IS TREATED AS THOUGH EXTENDED WITH 00280000 * ZEROS TO THE LENGTH OF THE LONGER. 00300000 * THE TWO STRINGS ARE COMPARED USING THE STORAGE-TO- 00320000 * STORAGE 'COMPARE LOGICAL' (CLC) INSTRUCTION, UP TO THE 00340000 * CURRENT LENGTH OF THE SHORTER STRING. SUBSEQUENT BYTES 00360000 * OF THE LONGER STRING ARE COMPARED WITH ZEROS ONE BYTE AT 00380000 * A TIME. INCOMPLETE LAST BYTES OF FIELDS ARE DEALT WITH 00400000 * IN REGISTERS. 00420000 * 00440000 * ENTRY POINTS 00460000 * IHEBSC0 00480000 * RA = A(SDV OF FIRST OPERAND) 00500000 * RB = A(SDV OF SECOND OPERAND) 00520000 * RC = A(TARGET) 00540000 * 00560000 * INPUT N/A 00580000 * 00600000 * OUTPUT N/A 00620000 * 00640000 * EXTERNAL MODULES 00660000 * N/A 00680000 * 00700000 * EXITS NORMAL 00720000 * RETURN TO CALLER VIA LINK REGISTER. 00740000 * 00760000 * TABLES/WORK-AREA 00780000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00800000 * 00820000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00840000 * 00860000 * PRIVATE MACROS 00880000 * IHELIB,IHESDR 00900000 * 00920000 * ASSEMBLY REQUIREMENTS 00940000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00960000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00980000 * 01000000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01020000 * STANDARDS. 01040000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01060000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01080000 * EXTERNAL CHARACTER SET. 01100000 EJECT 01120000 IHEBSC CSECT 01140000 SPACE 2 01160000 IHELIB 01180000 SPACE 01200000 * PRIVATE REGISTER ASSIGNMENTS. 01220000 SPACE 01240000 IND EQU R0 01260000 RS1 EQU RA 01280000 RS2 EQU RB 01300000 RT1 EQU RC 01320000 OFF EQU RC 01340000 RE1 EQU RD MUST BE 01360000 RO1 EQU RE EVEN-ODD PAIR. 01380000 LNK EQU LR 01400000 BAS EQU BR 01420000 SPACE 01440000 * PRIVATE OFFSETS. 01460000 SPACE 01480000 LFLD EQU 6 01500000 EJECT 01520000 IHEBSC CSECT 01540000 SPACE 01560000 ENTRY IHEBSC0 01580000 SPACE 2 01600000 USING *,BAS 01620000 IHEBSC0 STM LR,RX,OFLR(DR) 01640000 IHESDR LW0,RD 01660000 LR RF,RC SAVE TARGET ADDRESS. 01680000 LH IND,LFLD(RS1) SET RE1 TO THE LENGTH OF THE SHORTER 01700000 LH RE1,LFLD(RS2) STRING, IND TO THE DIFFERENCE IN 01720000 SR IND,RE1 LENGTH OF THE TWO STRINGS, 01740000 BC 10,BC010 NEGATIVE IF THE 01760000 AR RE1,IND SECOND STRING IS LONGER. 01780000 BC010 L RS1,0(RS1) 01800000 L RS2,0(RS2) 01820000 SRDL RE1,3 CONVERT TO BYTE LENGTH AND BIT 01840000 SRL RO1,29 OVERLAP IN RE1,RO1 RESPECTIVELY 01860000 LCR OFF,RO1 SAVE COMPLEMENT OF OVERLAP. 01880000 SH RE1,BCX01+2 SUBTRACT 1 01900000 BC 4,BC020 BRANCH IF LESS THAN A BYTE 01920000 SRDL RE1,8 SET RE1 TO NUMBER OF TIMES THROUGH 01940000 SRL RO1,24 LOOP, RO1 TO LENGTH 01960000 BCX01 LA RE1,1(RE1,0) OF FIRST COMPARE. 01980000 SPACE 02000000 BCCCL EX RO1,BCCCI EXECUTE COMPARISON 02020000 BC 6,BC070 RETURN CONDITION CODE IF NOT EQUAL. 02040000 LA RS1,1(RO1,RS1) OTHERWISE ADD LENGTH COMPARED TO 02060000 LA RS2,1(RO1,RS2) ADDRESSES OF STRINGS. 02080000 LA RO1,255 SET RO1 TO 255 AFTER FIRST COMPARE. 02100000 BCT RE1,BCCCL LOOP IF MORE SECTIONS 02120000 SPACE 02140000 BC020 LPR RE1,IND RE1 HAS LENGTH OF LONGER STRING TO 02160000 * BE COMPARED WITH ZEROS. 02180000 SR RE1,OFF ADD BIT OVERLAP. 02200000 BC 8,BC070 RETURN CONDITION CODE 0 IF STRINGS 02220000 * ARE OF EQUAL LENGTH AND END ON A 02240000 * BYTE BOUNDARY. 02260000 LTR IND,IND TEST IND 02280000 BC 8,BC060 BRANCH IF STRINGS SAME LENGTH. 02300000 BC 2,BC030 BRANCH IF FIRST LONGER, 02320000 XR RS1,RS2 OTHERWISE INTERCHANGE 02340000 XR RS2,RS1 STRING ADDRESS POINTERS SO THAT 02360000 XR RS1,RS2 RS1 POINTS AT LONGER STRING. 02380000 BC030 IC RO1,0(RS2) PICK UP LAST BYTE OF SHORTER STRING 02400000 LR RS2,RO1 IN BITS 24-31 WITH ZEROS IN 0-23. 02420000 SRL RS2,8(OFF) ZERO UNWANTED 02440000 SLL RS2,8(OFF) BITS. 02460000 SRDL RE1,3 SET RE1,RO1 TO BYTE LENGTH AND 02480000 SRL RO1,29 OVERLAP 02500000 LCR OFF,RO1 SAVE COMPLEMENT OF OVERLAP. 02520000 SH RE1,BCX01+2 SUBTRACT 1 02540000 BC 4,BC050 BRANCH IF LENGTH LESS THAN A BYTE. 02560000 EX RS2,BCCIL OTHERWISE EXECUTE COMPARE. 02580000 BC 2,BC1G2 IF UNEQUAL, BRANCH TO SET CONDITION 02600000 BC 4,BC1L2 CODE CORRECTLY, 02620000 LA RS1,1(0,RS1) OTHERWISE ADD 1 TO STRING ADDRESS. 02640000 LTR RE1,RE1 TEST LENGTH REMAINING 02660000 BC 8,BC040 BRANCH IF LESS THAN A BYTE. 02680000 SPACE 02700000 BCCIL CLI 0(RS1),X'00' COMPARE WITH ZERO. 02720000 BC 2,BC1G2 BRANCH IF HIGH TO SET C.C. CORRECTLY 02740000 LA RS1,1(0,RS1) IF EQUAL ADD 1 TO SOURCE ADDRESS 02760000 BCT RE1,BCCIL LOOP IF MORE BYTES TO COMPARE. 02780000 SPACE 02800000 BC040 SR RS2,RS2 ZERO RS2 02820000 BC050 IC RO1,0(RS1) PICK UP LAST BYTE OF LONGER STRING 02840000 * IN BITS 24-31 WITH ZEROS IN 0-23. 02860000 SRL RO1,8(OFF) ZERO UNWANTED 02880000 SLL RO1,8(OFF) BITS 02900000 CLR RO1,RS2 COMPARE OVERLAPPING BITS. 02920000 BC 8,BC070 IF EQUAL, RETURN C.C. ZERO. 02940000 BC 2,BC1G2 02960000 BC1L2 LCR IND,IND RETURN C.C. 1 IF FIRST STRING LONGER 02980000 BC 15,BC070 C.C. 2 IF SECOND STRING LONGER. 03000000 SPACE 03020000 BC1G2 LTR IND,IND RETURN C.C. 2 IF FIRST STRING LONGER 03040000 BC 15,BC070 C.C. 1 IF SECOND STRING LONGER. 03060000 SPACE 03080000 BC060 IC RE1,0(RS1) IF STRINGS ARE THE SAME LENGTH, 03100000 IC RO1,0(RS2) INSERT THE OVERLAPPED BITS IN 03120000 SRL RE1,8(OFF) THE BOTTOM END OF 2 REGISTERS WITH 03140000 SRL RO1,8(OFF) ALL ZEROS TO THE LEFT. 03160000 CLR RE1,RO1 COMPARE. 03180000 BC070 BALR RA,0 OBTAIN CONDITION CODE AND PROGRAM 03200000 ST RA,0(RF) MASK AND STORE IN BITS 2-7 OF 03220000 L DR,OFDR(DR) TARGET FIELD. 03240000 LM RB,RF,OFRB(DR) 03260000 MVI OFLR(DR),X'FF' 03280000 BCR 15,LNK 03300000 SPACE 03320000 * EXECUTED INSTRUCTIONS. 03340000 SPACE 03360000 BCCCI CLC 0(1,RS1),0(RS2) EXECUTED COMPARE LOGICAL INSTRUCTION 03380000 END 03400000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEBSD0 BSD TITLE ' IHEBSD BIT STRING GENERAL COMPARE *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 192 BYTES 00140000 * 00160000 * FUNCTION TO COMPARE TWO BIT STRINGS AND RETURN A CONDITION 00180000 * CODE AS FOLLOWS 00200000 * 0 IF THE STRINGS ARE EQUAL 00220000 * 1 IF THE SECOND STRING HAS A 1 AT THE FIRST INEQUALITY 00240000 * 2 IF THE FIRST STRING HAS A 1 AT THE FIRST INEQUALITY 00260000 * THE SHORTER STRING IS TREATED AS THOUGH EXTENDED WITH 00280000 * ZEROS TO THE LENGTH OF THE LONGER. 00300000 * CORRESPONDING PORTIONS, UP TO 32 BITS LONG, OF THE TWO 00320000 * STRINGS ARE ALIGNED IN EVEN-ODD PAIRS OF REGISTERS AND 00340000 * THEN COMPARED, USING THE CLR INSTRUCTION. 00360000 * 00380000 * ENTRY POINTS 00400000 * IHEBSD0 00420000 * RA = A(SDV OF FIRST OPERAND) 00440000 * RB = A(SDV OF SECOND OPERAND) 00460000 * RC = A(TARGET) 00480000 * 00500000 * INPUT N/A 00520000 * 00540000 * OUTPUT N/A 00560000 * 00580000 * EXTERNAL MODULES 00600000 * N/A 00620000 * 00640000 * EXITS NORMAL 00660000 * RETURN TO CALLER VIA LINK REGISTER. 00680000 * 00700000 * TABLES/WORK-AREA 00720000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00740000 * 00760000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00780000 * 00800000 * PRIVATE MACROS 00820000 * IHELIB,IHESDR 00840000 * 00860000 * ASSEMBLY REQUIREMENTS 00880000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00900000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00920000 * 00940000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00960000 * STANDARDS. 00980000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01000000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01020000 * EXTERNAL CHARACTER SET. 01040000 EJECT 01060000 IHEBSD CSECT 01080000 SPACE 2 01100000 IHELIB 01120000 SPACE 01140000 * PRIVATE REGISTER ASSIGNMENTS. 01160000 SPACE 01180000 RE3 EQU R0 MUST BE 01200000 RO3 EQU RA EVEN-ODD PAIR 01220000 RS1 EQU RA 01240000 RS2 EQU RB 01260000 RE4 EQU RB MUST BE 01280000 RO4 EQU RC EVEN-ODD PAIR 01300000 RE1 EQU RD MUST BE 01320000 RO1 EQU RE EVEN-ODD PAIR 01340000 RE2 EQU RF MUST BE 01360000 RO2 EQU RG EVEN-ODD PAIR 01380000 RL1 EQU RH 01400000 RL2 EQU RI 01420000 LNK EQU LR 01440000 BAS EQU BR 01460000 SPACE 01480000 * PRIVATE OFFSETS. 01500000 SPACE 01520000 LFLD EQU 6 01540000 EJECT 01560000 IHEBSD CSECT 01580000 SPACE 01600000 ENTRY IHEBSD0 01620000 SPACE 2 01640000 USING *,BAS 01660000 IHEBSD0 STM LR,RX,OFLR(DR) 01680000 IHESDR LW0,RD 01700000 LR RJ,RC SAVE TARGET ADDRESS. 01720000 L RE1,0(RS1) LOAD RE1 AND RE2 WITH 01740000 L RE2,0(RS2) ADDRESSES OF STRINGS 01760000 LH RL1,LFLD(RS1) LOAD RL1 AND RL2 WITH 01780000 LH RL2,LFLD(RS2) THEIR LENGTHS. 01800000 LR RO1,RE1 CONVERT 01820000 SRDL RE1,2 ADDRESSES 01840000 SLL RE1,2 TO WORD 01860000 SRL RO1,27 ADDRESSES IN RE1, RE2 01880000 LR RO2,RE2 AND 01900000 SRDL RE2,2 WORD 01920000 SLL RE2,2 OFFSETS 01940000 SRL RO2,27 IN RO1, RO2. 01960000 SPACE 01980000 BD010 LM RE3,RO3,0(RE1) SET NEXT 32 BITS OF STRING 1 DATA IN 02000000 SLDL RE3,0(RO1) REGISTER RE3. 02020000 LA RE1,4(0,RE1) ADDRESS NEXT WORD OF STRING 1. 02040000 SH RL1,X020 SUBTRACT 32 FROM STRING 1 LENGTH. 02060000 BC 10,BD020 BRANCH IF STILL NON-NEGATIVE 02080000 LPR RO3,RL1 OTHERWISE ZERO 02100000 SRL RE3,0(RO3) UNWANTED 02120000 SLL RE3,0(RO3) BITS. 02140000 SPACE 02160000 BD020 LTR RL2,RL2 TEST REMAINING LENGTH OF 2ND STRING 02180000 BC 2,BD030 BRANCH IF POSITIVE. 02200000 SR RE4,RE4 OTHERWISE SET ZEROS IN 2ND STRING 02220000 BC 15,BD040 DATA REGISTER AND BRANCH. 02240000 SPACE 02260000 BD030 LM RE4,RO4,0(RE2) SET NEXT 32 BITS OF STRING 2 DATA IN 02280000 SLDL RE4,0(RO2) REGISTER RE4. 02300000 LA RE2,4(0,RE2) ADDRESS NEXT WORD OF STRING 2. 02320000 SH RL2,X020 SUBTRACT 32 FROM STRING 2 LENGTH 02340000 BC 10,BD050 BRANCH IF STILL NON-NEGATIVE 02360000 LPR RO4,RL2 OTHERWISE ZERO 02380000 SRL RE4,0(RO4) UNWANTED 02400000 SLL RE4,0(RO4) BITS. 02420000 BD040 CLR RE3,RE4 COMPARE DATA. 02440000 BC 6,BD045 RETURN WITH COND. CODE IF UNEQUAL. 02460000 LTR RL1,RL1 OTHERWISE TEST IF STRING 1 IS 02480000 BC 2,BD010 ALSO EXHAUSTED. IF NOT, BRANCH 02500000 SR RE3,RE3 OTHERWISE SET CONDITION CODE TO 0. 02520000 BD045 BALR RA,0 OBTAIN CONDITION CODE AND PROGRAM 02540000 ST RA,0(RJ) MASK AND STORE IN BITS 2-7 OF 02560000 L DR,OFDR(DR) TARGET FIELD. 02580000 LM RB,RJ,OFRB(DR) 02600000 MVI OFLR(DR),X'FF' 02620000 BCR 15,LNK 02640000 SPACE 02660000 BD050 CLR RE3,RE4 COMPARE DATA. 02680000 BC 6,BD045 RETURN WITH COND. CODE IF UNEQUAL. 02700000 LTR RL1,RL1 TEST REMAINING LENGTH OF 1ST STRING. 02720000 BC 2,BD010 BRANCH IF POSITIVE 02740000 SR RE3,RE3 OTHERWISE SET ZEROS IN 1ST STRING 02760000 BC 15,BD020 DATA REGISTER AND BRANCH. 02780000 SPACE 02800000 * CONSTANTS 02820000 SPACE 02840000 X020 DC X'0020' HALFWORD CONSTANT OF 32. 02860000 SPACE 2 02880000 END 02900000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEBSF0 BSF TITLE ' IHEBSF BOOL *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 480 BYTES 00140000 * 00160000 * FUNCTION BOOL - TO TAKE TWO SOURCE STRINGS AND PERFORM ONE OF 00180000 * THE 16 POSSIBLE LOGICAL OPERATIONS BETWEEN CORRESPONDING 00200000 * BITS OF THEM ACCORDING TO A BIT PATTERN N1-N2-N3-N4 00220000 * SUPPLIED AS AN ARGUMENT. THE SHORTER STRING IS TREATED 00240000 * AS THOUGH EXTENDED WITH ZEROS TO THE LENGTH OF THE 00260000 * LONGER. 00280000 * THE CURRENT LENGTH OF THE TARGET STRING IS SET EQUAL TO 00300000 * EITHER THE MAXIMUM OF THE CURRENT LENGTHS OF THE SOURCE 00320000 * STRINGS OR TO THE MAXIMUM LENGTH OF THE TARGET FIELD 00340000 * (WHEN TRUNCATION IS NECESSARY TO AVOID EXCEEDING THE 00360000 * LENGTH OF THIS FIELD). CORRESPONDING PORTIONS, UP TO 32 00380000 * BITS IN LENGTH, OF THE SOURCE STRINGS ARE ALIGNED WITH 00400000 * THEIR TARGET FIELD IN PAIRS OF REGISTERS, AND THE 00420000 * NECESSARY OPERATION IS PERFORMED, USING A TABLE OF 00440000 * INSTRUCTIONS AND THE EXECUTE (EX) INSTRUCTION. THE 00460000 * RESULT IS THEN STORED IN THE TARGET FIELD. IF ONE STRING 00480000 * IS SHORTER THAN THE OTHER, IT IS REGARDED AS BEING 00500000 * EXTENDED ON THE RIGHT WITH ZERO BITS TO THE LENGTH OF 00520000 * THE LONGER. THE FIELD BETWEEN THE CALCULATED CURRENT 00540000 * LENGTH AND THE MAXIMUM LENGTH OF THE TARGET IS LEFT 00560000 * UNCHANGED. 00580000 * 00600000 * ENTRY POINTS 00620000 * IHEBSF0 00640000 * RA = A(PLIST) 00660000 * PLIST = A(SDV OF FIRST SOURCE STRING) 00680000 * A(SDV OF SECOND SOURCE STRING) 00700000 * A(FULL-WORD CONTAINING BIT PATTERN 00720000 * N1-N2-N3-N4 RIGHT JUSTIFIED) 00740000 * A(SDV OF TARGET) 00760000 * 00780000 * INPUT N/A 00800000 * 00820000 * OUTPUT N/A 00840000 * 00860000 * EXTERNAL MODULES 00880000 * N/A 00900000 * 00920000 * EXITS NORMAL 00940000 * RETURN TO CALLER VIA LINK REGISTER. 00960000 * 00980000 * TABLES/WORK-AREA 01000000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 01020000 * 01040000 * ATTRIBUTES READ-ONLY AND REENTRANT. 01060000 * 01080000 * PRIVATE MACROS 01100000 * IHELIB,IHESDR 01120000 * 01140000 * ASSEMBLY REQUIREMENTS 01160000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 01180000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01200000 * 01220000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01240000 * STANDARDS. 01260000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01280000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01300000 * EXTERNAL CHARACTER SET. 01320000 EJECT 01340000 IHEBSF CSECT 01360000 SPACE 2 01380000 IHELIB 01400000 SPACE 01420000 * PRIVATE REGISTER ASSIGNMENTS. 01440000 SPACE 01460000 RS1 EQU RA 01480000 RS2 EQU RB 01500000 ROP EQU RC 01520000 RT1 EQU RD 01540000 RD1 EQU R0 01560000 RE4 EQU R0 MUST BE 01580000 RO4 EQU RA EVEN-ODD PAIR 01600000 RE3 EQU RB MUST BE 01620000 RO3 EQU RC EVEN-ODD PAIR 01640000 RE1 EQU RD MUST BE 01660000 RO1 EQU RE EVEN-ODD PAIR 01680000 OPR EQU RF 01700000 TMP EQU RG 01720000 RD2 EQU RG 01740000 RE2 EQU RH MUST BE 01760000 RO2 EQU RI EVEN-ODD PAIR 01780000 RL1 EQU RJ 01800000 RL2 EQU RX 01820000 WKR EQU DR 01840000 MOD EQU LR 01860000 LNK EQU LR 01880000 BAS EQU BR 01900000 SPACE 01920000 * PRIVATE OFFSETS. 01940000 SPACE 01960000 MFLD EQU 4 01980000 LFLD EQU 6 02000000 EJECT 02020000 IHEBSF CSECT 02040000 SPACE 02060000 ENTRY IHEBSF0 02080000 SPACE 2 02100000 USING *,BAS 02120000 IHEBSF0 STM LNK,RL2,OFLR(WKR) 02140000 IHESDR LW0,RB 02160000 LM RS1,RT1,0(RS1) LOAD RS1 RS2 RT1,ROP FROM PARAM.LIST 02180000 L OPR,0(ROP) 02200000 CLC LFLD(2,RS1),LFLD(RS2) 02220000 BC 10,BF005 BRANCH UNLESS 2ND STRING LONGER. 02240000 XR RS1,RS2 OTHERWISE EXCHANGE 02260000 XR RS2,RS1 SOURCE STRING 02280000 XR RS1,RS2 POINTERS. 02300000 TM 3(ROP),X'06' 02320000 BC 11,BF005 BRANCH IF SYMMETRICAL. 02340000 LA TMP,6 OTHERWISE CORRECT OP CODE 02360000 XR OPR,TMP FOR STRING REVERSAL. 02380000 BF005 SR MOD,MOD CONVERT 4-BIT OP. CODE TO AN OFFSET 02400000 TM 3(ROP),X'08' TO BE USED BY THE EXECUTE INSTR. 02420000 BC 8,BF010 AND SET MOD FOR USE AFTER BF090 02440000 BCTR MOD,0 AND BF150. (OPERATION CODES 02460000 XR OPR,MOD 0-7 PERFORM THE INVERSE OF OP. 02480000 BF010 SLL OPR,29 CODES 15-8 RESPECTIVELY. THE OP. 02500000 SRL OPR,27 CODES 0,1,...7 CORRESPOND TO 02520000 * OFFSETS 0,4,..28 WITH MOD ALL 02540000 * ZEROS, OP. CODES 8-15 TO OFFSETS 02560000 * 28,24,..0 WITH MODIFIER ALL ONES.) 02580000 LH RL1,LFLD(0,RS1) 02600000 LH RL2,LFLD(0,RS2) 02620000 LH TMP,MFLD(0,RT1) 02640000 CR RL1,TMP CHECK IF FIRST STRING CURRENT LENGTH 02660000 BC 12,BF030 EXCEEDS TARGET MAXIMUM. IF SO, USE 02680000 LR RL1,TMP TARGET MAX. AS SOURCE 1 LENGTH. 02700000 CR RL2,TMP CHECK IF SECOND STRING CURR. LENGTH 02720000 BC 12,BF030 EXCEEDS TARGET MAXIMUM. IF SO, USE 02740000 LR RL2,TMP TARGET MAX. AS SOURCE 2 LENGTH. 02760000 BF030 STH RL1,LFLD(0,RT1) STORE LONGER STRING LENGTH IN 02780000 * TARGET CURRENT LENGTH SLOT. 02800000 LTR RL1,RL1 TEST LENGTH OF LONGER STRING 02820000 BC 8,BF100 RETURN TO CALLER IF ZERO. 02840000 L RE2,0(0,RS2) LOAD RE1,RE2,RE3, WITH ADDRESS SLOTS 02860000 L RE3,0(0,RT1) OF SOURCE AND TARGET 02880000 L RE1,0(0,RS1) SDVS RESPECTIVELY. 02900000 LR RO3,RE3 SET RE3,RO3 TO 02920000 SRDL RE3,2 WORD ADDRESS AND 02940000 SLL RE3,2 WORD OFFSET OF 02960000 SRL RO3,27 TARGET STRING. 02980000 LR RO1,RE1 SET RE1,RO1 03000000 SRDL RE1,2 TO WORD ADDRESS 03020000 SLL RE1,2 AND WORD OFFSET 03040000 SRL RO1,27 OF FIRST SOURCE STRING. 03060000 LR RO2,RE2 SET RE2,RO2 03080000 SRDL RE2,2 TO WORD ADDRESS 03100000 SLL RE2,2 AND WORD OFFSET 03120000 SRL RO2,27 OF SECOND SOURCE STRING. 03140000 SR RO2,RO3 CHECK RELATIVE ALIGNMENT OF SHORTER 03160000 BC 2,BFSL2 STRING AND TARGET DATA 03180000 L RE4,0(0,RE2) BRANCH TO ALIGN 03200000 BC 4,BFSR2 IF NECESSARY 03220000 BF040 LA RE2,4(0,RE2) POINT TO NEXT WORD OF SHORTER STRING 03240000 BF050 LR RD2,RE4 LOAD SOURCE 2 DATA REGISTER FROM RE4 03260000 SR RO1,RO3 CHECK RELATIVE ALIGNMENT OF LONGER 03280000 BC 2,BFSL1 STRING AND TARGET DATA. 03300000 L RE4,0(0,RE1) BRANCH TO ALIGN 03320000 BC 4,BFSR1 IF NECESSARY. 03340000 BF060 LA RE1,4(0,RE1) POINT TO NEXT WORD OF LONGER STRING. 03360000 BF070 LH RO4,XFFF SET UP MASK 03380000 SRL RO4,0(RO3) IN RO4. 03400000 SH RO3,X020 SUBTRACT 32 FROM TARGET OFFSET. 03420000 AR RL2,RO3 TEST IF SHORTER STRING IS EXHAUSTED. 03440000 BC 10,BF080 IF NOT, BRANCH. 03460000 LCR RE2,RL2 OTHERWISE ZERO 03480000 SRL RD2,0(RE2) UNWANTED BITS 03500000 SLL RD2,0(RE2) IN RD2. 03520000 BF080 AR RL1,RO3 TEST IF LONGER STRING IS EXHAUSTED. 03540000 BC 10,BF090 IF NOT, BRANCH. 03560000 LCR RO3,RL1 OTHERWISE MODIFY 03580000 SRL RO4,0(RO3) MASK IN RO4 TO 03600000 BF085 SLL RO4,0(RO3) SAVE RELEVANT TARGET BITS. 03620000 BF090 EX 0,BFIII(OPR) EXECUTE ONE OF OPERATIONS 0-7. 03640000 XR RE4,MOD INVERT IF MODIFIER ALL ONES. 03660000 NR RE4,RO4 ZERO UNWANTED DATA 03680000 LH TMP,XFFF IN RE4 03700000 XR RO4,TMP AND 03720000 N RO4,0(0,RE3) REPLACE WITH REQUIRED 03740000 OR RE4,RO4 TARGET BITS. 03760000 ST RE4,0(0,RE3) STORE RE4 IN TARGET WORD. 03780000 LTR RL1,RL1 TEST IF STRINGS EXHAUSTED. 03800000 BC 2,BF110 BRANCH IF NOT. 03820000 BF100 L DR,OFDR(DR) 03840000 LM LNK,RL2,OFLR(WKR) RESTORE CALLER'S REGS. 03860000 BCR 15,LNK RETURN TO CALLER 03880000 SPACE 03900000 BF110 LTR RL2,RL2 TEST IF SHORTER STRING EXHAUSTED. 03920000 BC 2,BF120 BRANCH IF NOT. 03940000 SR RD2,RD2 OTHERWISE SET SOURCE 2 DATA REG. 03960000 BC 15,BF140 TO ZERO, SKIP DATA LOAD. 03980000 SPACE 04000000 BF120 LM RE4,RO4,0(RE2) LOAD DATA FROM SHORTER STRING. 04020000 LA RE2,4(0,RE2) UPDATE SHORTER STRING ADDRESS. 04040000 SLDL RE4,0(RO2) ALIGN 32 BITS WITH TARGET. 04060000 SH RL2,X020 SUBTRACT 32 FROM STRING LENGTH. 04080000 BC 10,BF130 BRANCH IF STILL POSITIVE, 04100000 LCR RE2,RL2 OTHERWISE 04120000 SRL RE4,0(RE2) ZERO UNWANTED 04140000 SLL RE4,0(RE2) BITS 04160000 BF130 LR RD2,RE4 LOAD INTO SOURCE 2 DATA REGISTER. 04180000 BF140 LM RE4,RO4,0(RE1) LOAD DATA FROM LONGER STRING. 04200000 LA RE1,4(0,RE1) UPDATE LONGER STRING ADDRESS. 04220000 LA RE3,4(0,RE3) UPDATE TARGET ADDRESS. 04240000 SLDL RE4,0(RO1) ALIGN 32 BITS WITH TARGET. 04260000 SH RL1,X020 SUBTRACT 32 FROM STRING LENGTH. 04280000 BC 2,BF150 BRANCH IF STILL POSITIVE. 04300000 LH RO4,XFFF OTHERWISE SET UP MASK 04320000 LPR RO3,RL1 TO SAVE RELEVANT 04340000 BC 15,BF085 TARGET BITS. 04360000 SPACE 04380000 BF150 EX 0,BFIII(OPR) EXECUTE ONE OF OPERATIONS 0-7. 04400000 XR RE4,MOD INVERT IF MODIFIER ALL ONES. 04420000 ST RE4,0(0,RE3) STORE RE4 IN TARGET WORD. 04440000 BC 15,BF110 LOOP. 04460000 SPACE 04480000 BFSL1 LM RE4,RO4,0(RE1) ALIGN SOURCE 04500000 SLDL RE4,0(RO1) DATA 04520000 BC 15,BF060 WITH TARGET 04540000 SPACE 04560000 BFSR1 LCR RO4,RO1 ALIGN SOURCE 04580000 SRL RE4,0(RO4) DATA 04600000 LA RO1,32(0,RO1) WITH 04620000 BC 15,BF070 TARGET 04640000 SPACE 04660000 BFSL2 LM RE4,RO4,0(RE2) ALIGN SOURCE 04680000 SLDL RE4,0(RO2) DATA 04700000 BC 15,BF040 WITH TARGET 04720000 SPACE 04740000 BFSR2 LCR RO4,RO2 ALIGN SOURCE 04760000 SRL RE4,0(RO4) DATA 04780000 LA RO2,32(0,RO2) WITH 04800000 BC 15,BF050 TARGET. 04820000 SPACE 04840000 BFIII SR RD1,RD1 OPERATION CODE 0 04860000 DS 2C 04880000 NR RD1,RD2 OPERATION CODE 1 04900000 DS 2C 04920000 BAL RO3,BF170 OPERATION CODE 2. 04940000 BCR 0,0 OPERATION CODE 3 04960000 DS 2C 04980000 BAL RO3,BF180 OPERATION CODE 4. 05000000 LR RD1,RD2 OPERATION CODE 5 05020000 XFFF DC X'FFFF' HALFWORD OF ONES 05040000 XR RD1,RD2 OPERATION CODE 6 05060000 X020 DC X'0020' CONSTANT OF 32 05080000 OR RD1,RD2 OPERATION CODE 7 05100000 SPACE 05120000 BF170 NR RD2,RD1 05140000 XR RD1,RD2 05160000 BCR 15,RO3 05180000 SPACE 05200000 BF180 NR RD1,RD2 05220000 XR RD1,RD2 05240000 BCR 15,RO3 05260000 SPACE 2 05280000 END 05300000 ./ ADD SSI=03011680,SOURCE=1,NAME=IHEBSI0 BSI TITLE ' IHEBSI BIT STRING INDEX *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 296 BYTES 00140000 * 00160000 * FUNCTION TO COMPARE TWO BIT STRINGS TO SEE IF THE SECOND IS 00180000 * IDENTICAL TO A SUBSTRING OF THE FIRST, AND IF SO, TO 00200000 * PRODUCE A BINARY INTEGER (THE INDEX) WHICH INDICATES 00220000 * THE FIRST BIT POSITION IN THE FIRST STRING AT WHICH 00240000 * SUCH A SUBSTRING OCCURS. IF NO SUCH INDEX IS FOUND, OR 00260000 * IF EITHER STRING IS NULL, THE FUNCTION VALUE RETURNED 00280000 * IS ZERO. 00300000 * EVEN-ODD PAIRS OF REGISTERS ARE LOADED WITH PORTIONS OF 00320000 * THE TWO STRINGS. SHIFT AND COMPARE INSTRUCTIONS ARE USED 00340000 * TO LOCATE THE POINT REQUIRED. THE BINARY INTEGER FOUND 00360000 * IS STORED IN THE TARGET FIELD PROVIDED. 00380000 * 00400000 * ENTRY POINTS 00420000 * IHEBSI0 00440000 * RA = A(PLIST) 00460000 * PLIST = A(SDV OF FIRST SOURCE STRING) 00480000 * A(SDV OF SECOND SOURCE STRING) 00500000 * A(TARGET) 00520000 * 00540000 * INPUT N/A 00560000 * 00580000 * OUTPUT N/A 00600000 * 00620000 * EXTERNAL MODULES 00640000 * N/A 00660000 * 00680000 * EXITS NORMAL 00700000 * RETURN TO CALLER VIA LINK REGISTER. 00720000 * 00740000 * TABLES/WORK-AREA 00760000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00780000 * 00800000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00820000 * 00840000 * PRIVATE MACROS 00860000 * IHELIB,IHESDR 00880000 * 00900000 * ASSEMBLY REQUIREMENTS 00920000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00940000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00960000 * 00980000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01000000 * STANDARDS. 01020000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01040000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01060000 * EXTERNAL CHARACTER SET. 01080000 EJECT 01100000 IHEBSI CSECT 01120000 SPACE 2 01140000 IHELIB 01160000 SPACE 01180000 * PRIVATE REGISTER ASSIGNMENTS. 01200000 SPACE 01220000 IND EQU R0 01240000 RPP EQU RA 01260000 RL1 EQU RA 01280000 RE2 EQU RB MUST BE 01300000 RO2 EQU RC EVEN-ODD PAIR. 01320000 WSP EQU RC 01340000 RE3 EQU RD THESE MUST BE 01360000 RO3 EQU RE KEPT 01380000 RL2 EQU RF AS ADJACENT REGISTERS. 01400000 TST EQU RG 01420000 RE1 EQU RH MUST BE 01440000 RO1 EQU RI EVEN-ODD PAIR. 01460000 TMP EQU RI 01480000 RS1 EQU RH 01500000 RS2 EQU RI 01520000 RT1 EQU RJ 01540000 COM EQU RX 01560000 WKR EQU DR 01580000 ADD EQU LR 01600000 LNK EQU LR 01620000 BAS EQU BR 01640000 SPACE 01660000 * PRIVATE OFFSETS. 01680000 SPACE 01700000 LFLD EQU 6 01720000 EJECT 01740000 IHEBSI CSECT 01760000 SPACE 01780000 ENTRY IHEBSI0 01800000 SPACE 2 01820000 USING *,BAS 01840000 IHEBSI0 STM LNK,COM,OFLR(WKR) 01860000 IHESDR LW0,RB 01880000 LM RS1,RT1,0(RPP) LOAD RS1,RS2,RT1 FROM PARAMETER LIST 01900000 LH RL1,LFLD(0,RS1) SET RL1 TO DIFFERENCE BETWEEN 01920000 LH RL2,LFLD(0,RS2) INDEXED AND INDEXING STRING LENGTH 01940000 SR RL1,RL2 RL2 TO LENGTH OF INDEXING STRING. 01960000 BC 4,IZERO BRANCH IF INDEXING STRING IS LONGER 01980000 LTR RL2,RL2 OR IS NULL. 02000000 BC 8,IZERO 02020000 LA IND,1(0,RL1) ADD 1 TO IND FOR BCT INSTRUCTION. 02040000 L RE2,0(0,RS2) SET RE2 TO WORD ADDRESS, 02060000 LR RO2,RE2 RO2 TO WORD 02080000 SRDL RE2,2 OFFSET OF 02100000 SLL RE2,2 INDEXING 02120000 SRL RO2,27 STRING.(STRING 2) 02140000 L TST,0(0,RE2) LOAD TST WITH 1ST WORD OF STRING 2. 02160000 AR RL2,RO2 CHECK IF INDEXING STRING OVERLAPS 02180000 SH RL2,X020 A WORD BOUNDARY. 02200000 BC 10,IN010 BRANCH IF IT DOES, OTHERWISE SHIFT 02220000 LCR RO1,RL2 OUT UNWANTED BITS TO RIGHT OF 02240000 SRL TST,0(RO1) INDEXING STRING, LENGTHEN WORD 02260000 SR RO2,RL2 OVERLAP IN RO2 BY NO.OF BITS LOST. 02280000 IN010 SR TMP,TMP SET UP MASK TO 02300000 BCTR TMP,0 EXCLUDE 02320000 SRL TMP,0(RO2) UNWANTED LEFT-HAND 02340000 ST TMP,OFPR(0,WKR) BITS IN COMPARISON. STORE. 02360000 NR TST,TMP USE MASK ON TST. 02380000 L RE1,0(RS1) 02400000 LR RO1,RE1 SET RE1 TO WORD ADDRESS, 02420000 SRDL RE1,2 RO1 TO WORD OFFSET 02440000 SLL RE1,2 OF INDEXED 02460000 SRL RO1,27 STRING (STRING 1) 02480000 LM RE3,RO3,0(RE1) LOAD FIRST 2 WORDS OF INDEXED STRING 02500000 SR RO2,RO1 CHECK ALIGNMENT WITH BITS IN TST. 02520000 BC 8,IN0SH BRANCH IF THE SAME 02540000 BC 4,INLSH BRANCH FOR LEFT SHIFT 02560000 SRDL RE3,0(RO2) OTHERWISE SHIFT RIGHT 02580000 BC 15,INCOM 02600000 SPACE 02620000 INLSH LCR RO1,RO2 SHIFT 02640000 SLDL RE3,0(RO1) LEFT 02660000 IN0SH LA RE1,4(0,RE1) UPDATE WORD ADDRESS AND ADD 32 TO 02680000 IN012 LA RO2,32(RO2,0) RO2 (WAS 0 OR MINUS)IF NOT R.SHIFT 02700000 INCOM N RE3,OFPR(WKR) USE MASK ON BITS OF INDEXED STRING. 02720000 CLR RE3,TST COMPARE FIRST SECTION OF INDEXING 02740000 * STRING IN TST WITH BITS OF INDEXED 02760000 * STRING IN RE3 02780000 BC 8,INEQR BRANCH IF EQUAL 02800000 INBCT BCT IND,IN020 OTHERWISE CONTINUE IF IND NOT ZERO 02820000 IZERO SR RL1,RL1 SET INDEX ZERO. 02840000 SPACE 02860000 IN015 ST RL1,0(RT1) STORE INDEX FOUND. 02880000 L DR,OFDR(DR) 02900000 LM LNK,COM,OFLR(WKR) RESTORE CALLERS REGISTERS. 02920000 MVI OFLR(WKR),X'FF' TRACE STOPPER. 02940000 BCR 15,LNK RETURN TO CALLER. 02960000 SPACE 02980000 INPOS SR RL1,IND SET INDEX TO 03000000 LA RL1,2(0,RL1) VALUE FOUND. 03020000 BC 15,IN015 03040000 SPACE 03060000 IN020 SLDL RE3,1 SHIFT OUT 1 BIT FROM INDEXED STRING 03080000 BCT RO2,INCOM LOOP IF DATA IN RE3,RO3 NOT 03100000 LA RE1,4(0,RE1) EXHAUSTED, OTHERWISE ADDRESS NEXT 03120000 L RO3,0(0,RE1) WORD OF INDEXED STRING, LOAD IT. 03140000 BC 15,IN012 BRANCH TO SET RO2 BACK TO 32. 03160000 SPACE 03180000 INEQR LTR RL2,RL2 TEST IF MORE OF STRINGS TO COMPARE 03200000 BC 12,INPOS IF NOT, BRANCH TO SET INDEX. 03220000 STM RE3,RL2,OFBR(WKR) IF MORE, STORE RE3,RO3,RL2. 03240000 SR ADD,ADD ZERO REGISTER ADD 03260000 LCR RO1,RO2 03280000 INEQL LA ADD,4(0,ADD) ADD 4 TO REGISTER ADD. 03300000 SLDL RE3,0(RO2) SHIFT UNTESTED BITS OF INDEXING 03320000 L RO3,0(ADD,RE1) STRING TO RE3, LOAD RO3 WITH NEXT 03340000 SLDL RE3,32(RO1) 32 BITS, ALIGN IN RE3. 03360000 L COM,0(ADD,RE2) LOAD COM WITH NEXT 32 BITS OF 03380000 * INDEXING STRING. 03400000 SH RL2,X020 CHECK IF FULL 32 BITS TO BE COMPARED 03420000 BC 2,IN040 BRANCH IF MORE THAN 32 03440000 BC 8,IN030 BRANCH IF EXACTLY 32. 03460000 LCR RL2,RL2 OTHERWISE ZERO UNWANTED 03480000 SRL RE3,0(RL2) BITS BEFORE 03500000 SRL COM,0(RL2) COMPARISON. 03520000 IN030 CLR RE3,COM COMPARE. 03540000 BC 8,INPOS IF EQUAL, BRANCH TO SET INDEX. 03560000 BC 15,IN050 OTHERWISE BRANCH TO RESTORE REGS. 03580000 SPACE 03600000 IN040 CLR RE3,COM COMPARE. 03620000 BC 8,INEQL IF EQUAL BRANCH TO COMPARE MORE 03640000 IN050 LM RE3,RL2,OFBR(WKR) OTHERWISE RESTORE REGISTERS 03660000 BC 15,INBCT BRANCH TO CONTINUE INDEXING. 03680000 SPACE 03700000 * CONSTANTS 03720000 SPACE 03740000 X020 EQU IN012+2 03760000 SPACE 2 03780000 END 03800000 ./ ADD SSI=05011681,SOURCE=1,NAME=IHEBSKK BSK TITLE ' IHEBSK BIT STRING CONCATENATE, REPEAT, ASSIGN *00300013 OS/360 PL/I LIBRARY' 00600013 * VERSION FOURTH VERSION OF F-LEVEL PL/1 COMPILER 00900015 * 01200013 * STATUS CHANGE LEVEL - 0. 01500013 * 01800013 * SIZE 472 BYTES 02100015 * 02400013 * FUNCTION IHEBSKK - TO CONCATENATE TWO BIT STRINGS INTO A TARGET. 02700013 * IHEBSKR - TO CONCATENATE N+1 INSTANCES OF A SINGLE 03000013 * SOURCE STRING INTO A TARGET. 03300013 * IHEBSKA - TO ASSIGN A BIT STRING TO A TARGET FIELD 03600013 * WITHOUT ZERO FILLING. THE CURRENT LENGTH IN THE TARGET 03900013 * SDV IS SET APPROPRIATELY. 04200013 * THE CURRENT LENGTH OF THE TARGET FIELD IS MADE EQUAL TO 04500013 * THE SMALLER OF TWO VALUES - THE SUM OF THE CURRENT 04800013 * LENGTHS OF THE SOURCE STRINGS, AND THE MAXIMUM LENGTH OF 05100013 * THE TARGET FIELD. THE ROUTINE USES A SUBROUTINE 05400013 * WHICH MOVES DATA FROM THE SOURCE FIELDS TO THE TARGET 05700013 * FIELD. THIS USES A PAIR OF REGISTERS TO ALIGN THE 06000013 * BITS IN SECTIONS OF UP TO 32 AT A TIME. BITS BEYOND THE 06300013 * RANGE OF THE CURRENT LENGTH CALCULATED FOR THE TARGET 06600013 * REMAIN UNALTERED. 06900013 * 07200013 * ENTRY POINTS 07500013 * IHEBSKK - CONCATENATE 07800013 * RA = A(SDV OF FIRST OPERAND) 08100013 * RB = A(SDV OF SECOND OPERAND) 08400013 * RC = A(SDV OF TARGET FIELD) 08700013 * IHEBSKR - REPEAT 09000013 * RA = A(SDV OF STRING) 09300013 * RB = A(N) 09600013 * RC = A(SDV OF TARGET FIELD) 09900013 * IHEBSKA - GENERAL ASSIGN 10200013 * RA = A(SDV OF STRING) 10500013 * RB = A(SDV OF TARGET) 10800013 * 11100013 * INPUT N/A 11400013 * 11700013 * OUTPUT N/A 12000013 * 12300013 * EXTERNAL MODULES 12600013 * N/A 12900013 * 13200013 * EXITS NORMAL 13500013 * RETURN TO CALLER VIA LINK REGISTER. 13800013 * 14100013 * TABLES/WORK-AREA 14400013 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 14700013 * 15000013 * ATTRIBUTES READ-ONLY AND REENTRANT. 15300013 * 15600013 * PRIVATE MACROS 15900013 * IHELIB,IHESDR 16200013 * 16500013 * ASSEMBLY REQUIREMENTS 16800013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 17100013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 17400013 * 17700013 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 18000013 * STANDARDS. 18300013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 18600013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 18900013 * EXTERNAL CHARACTER SET. 19200013 EJECT 19500013 IHEBSK CSECT 19800013 SPACE 2 20100013 IHELIB 20400013 SPACE 20700013 * PRIVATE REGISTER ASSIGNMENTS. 21000013 SPACE 21300013 RE2 EQU R0 MUST BE 21600013 RO2 EQU RA EVEN-ODD PAIR 21900013 RM1 EQU RA 22200013 RS1 EQU RB 22500013 RT1 EQU RC 22800013 REP EQU RD 23100013 RE1 EQU RF MUST BE 23400013 RO1 EQU RG EVEN-ODD PAIR 23700013 RE3 EQU RH MUST BE 24000013 RO3 EQU RI EVEN-ODD PAIR 24300013 RL1 EQU RJ 24600013 CON EQU WR 24900013 LNK EQU LR 25200013 BAS EQU BR 25500013 SPACE 25800013 * PRIVATE OFFSETS. 26100013 SPACE 26400013 MFLD EQU 4 26700013 LFLD EQU 6 27000013 OFRP EQU 72 27300013 EJECT 27600013 IHEBSK CSECT 27900013 SPACE 28200013 ENTRY IHEBSKK,IHEBSKA,IHEBSKR 28500013 SPACE 2 28800013 * *********************** 29100013 * * REPEAT ENTRY * 29400013 * *********************** 29700013 SPACE 30000013 USING *,BAS 30300013 IHEBSKR STM LR,RX,OFLR(DR) 30600013 IHESDR LW0,RD 30900013 L REP,0(0,RB) GET NUMBER OF REPETITIONS. 31200013 CH REP,X32K IF VERY LARGE, 31500013 BH BK000 DON'T ADD 1, OTHERWISE 31800013 AH REP,H001 INCR BY 1 FOR THE ALGORITHM. 32100013 BC 2,BK000 DON'T BRANCH IF REP WAS LT 0, 32400013 BKH01 LA REP,1 AND SET REP TO 1. 32700013 BK000 LR RS1,RA RS1 POINTS TO SOURCE SDV 33000013 BAL BAS,MDIFY 33300013 SPACE 2 33600013 * *********************** 33900013 * * CONCATENATE ENTRY * 34200013 * *********************** 34500013 SPACE 34800013 USING *,BAS 35100013 IHEBSKK STM LR,WR,OFLR(DR) 35400013 IHESDR LW0,RD 35700013 LA REP,2 SET NUMBER OF REPETITIONS TO 2. 36000013 CR RA,RT1 TEST FOR FIRST SOURCE = TARGET 36300013 BE BK090 SDV AND BRANCH IF SO 36600013 MDIFY BAL BAS,BK010 MODIFY BASE REGISTER 36900013 SPACE 2 37200013 * *********************** 37500013 * * ASSIGN ENTRY * 37800013 * *********************** 38100013 SPACE 38400013 USING *,BAS 38700013 IHEBSKA STM LR,WR,OFLR(DR) 39000013 IHESDR LW0,RD 39300013 LA REP,1 SET NUMBER OF REPETITIONS TO 1 39600013 LR RT1,RB SET RT1 TO TARGET SDV. 39900013 BK010 LH RL1,LFLD(0,RA) CHECK IF FIRST STRING CURRENT LENGT 40200013 CH RL1,MFLD(0,RT1) EXCEEDS TARGET MAXIMUM 40500013 BC 12,BK020 BRANCH IF NOT, 40800013 LH RL1,MFLD(0,RT1) OTHERWISE SET REP TO 1, USE TARGET 41100013 LA REP,1 MAXIMUM AS SOURCE CURRENT LENGTH. 41400013 BK020 STH RL1,LFLD(0,RT1) STORE LENGTH TO BE MOVED IN TARG.SDV 41700013 L RE3,0(0,RT1) CONVERT TARGET ADDRESS TO 42000013 LR RO3,RE3 A WORD ADDRESS 42300013 SRDL RE3,2 IN RE3 AND A 42600013 SLL RE3,2 BIT OFFSET 42900013 SRL RO3,27 IN RO3 43200013 LR CON,RA CON POINTS AT SOURCE SDV 43500013 BAL LNK,BKMVR MOVE SOURCE TO TARGET 43800013 CH REP,H002 TEST NUMBER OF REPETITIONS 44100013 BL FINIS TERMINATE IF REP = 1 44400013 LR CON,RS1 CON POINTS AT SOURCE SDV 44700013 BE ONEMR IF REP = 2, DO ONE MORE MOVE 45000013 CH REP,H004 IF REP GT 3, BRANCH TO USE 45300013 BNL USELP LOOP 45600013 BAL LNK,MOVIT PERFORM 1 OR 2 MORE SOURCE 45900013 ONEMR BAL LNK,MOVIT MOVES ACCORDING AS REP=2 OR 3 46200013 FINIS L DR,OFDR(DR) 46500013 LM LR,WR,OFLR(DR) RESTORE REGISTERS 46800013 MVI OFLR(DR),X'FF' 47100013 BR LR RETURN TO CALLER 47400013 SPACE 47700013 USELP STH REP,OFRP(0,DR) SET COMPARISON 48000013 SLOOP SRDL REP,1 SHIFT ALL BITS FROM 48300013 LTR REP,REP REP SO THEY ARE LEFT ALIGNED 48600013 BNZ SLOOP IN REP+1 48900013 SLDL REP,1 49200013 POOLS LR CON,RT1 SET CON TO TARGET SDV 49500013 BAL LNK,MOVIT CONCATENATE TARGET WITH ITSELF 49800013 LTR REP+1,REP+1 TEST HIGH ORDER BIT OF REP+1 50100013 BNM CMPRE 50400013 LR CON,RS1 IF BIT WAS 1, THEN CONCATENATE 50700013 BAL LNK,MOVIT TARGET FIELD WITH SOURCE 51000013 CMPRE SLDL REP,1 51300013 CH REP,OFRP(0,DR) TEST WHETHER ALL BITS OF REP 51600013 BNE POOLS HAVE BEEN USED AND LOOP IF NOT 51900013 B FINIS ELSE BRANCH TO FINISH 52200013 SPACE 52500013 MOVIT LA RO3,32(0,RL1) SET RO3 TO NEW WORD OFFSET OF TARGET 52800013 BK075 LH RL1,LFLD(0,CON) CHECK IF SOURCE CURRENT 53100013 LH RO2,MFLD(0,RT1) LENGTH WILL FIT INTO TARGET 53400013 SH RO2,LFLD(0,RT1) SPACE LEFT 53700013 CR RL1,RO2 54000013 BC 12,BK080 BRANCH IF ROOM 54300013 LA LNK,FINIS ELSE, SET LNK TO FINISH 54600013 LR RL1,RO2 LEFT AS CURRENT LENGTH OF SOURCE. 54900013 BK080 LH RO2,LFLD(0,RT1) ADD THE CALCULATED SOURCE CURRENT 55200013 AR RO2,RL1 LENGTH INTO THE TARGET SDV 55500013 STH RO2,LFLD(0,RT1) CURRENT LENGTH SLOT. 55800013 SPACE 56100013 * MOVE ROUTINE 56400013 SPACE 56700013 BKMVR L RE1,0(0,CON) LOAD RE1 WITH SOURCE ADDRESS 57000013 LR RO1,RE1 CONVERT SOURCE ADDRESS TO A 57300013 BKH02 SRDL RE1,2 WORD ADDRESS IN 57600013 SLL RE1,2 RE1 AND A BIT 57900013 SRL RO1,27 OFFSET IN RO1 58200013 SR RO1,RO3 CHECK RELATIVE ALIGNMENT OF SOURCE 58500013 BC 2,BKSLR AND TARGET DATA, 58800013 L RE2,0(0,RE1) BRANCH IF 59100013 BC 4,BKSRR NOT THE SAME. 59400013 BK030 LA RE1,4(0,RE1) POINT TO NEXT WORD OF SOURCE 59700013 BK040 LH RM1,XFFF SET MASK 60000013 SRL RM1,0(RO3) IN RM1 60300013 SH RL1,X020 SUBTRACT 32 FROM LENGTH TO BE MOVED 60600013 AR RL1,RO3 ADD THE TARGET WORD OFFSET 60900013 BC 10,BK050 BRANCH IF NON-NEGATIVE 61200013 LCR RO3,RL1 OTHERWISE MODIFY MASK (THE SOURCE 61500013 SRL RM1,0(RO3) DATA FILLS LESS THAN A WORD 61800013 BK045 SLL RM1,0(RO3) OF THE TARGET) 62100013 BK050 NR RE2,RM1 PREPARE SOURCE DATA FOR 62400013 X RM1,XFFF STORAGE IN CORRESPONDING 62700013 N RM1,0(0,RE3) WORD OF TARGET,PRESERVING DATA 63000013 OR RE2,RM1 OUTSIDE AREA OF TARGET. 63300013 SPACE 2 63600013 * MOVE LOOP 63900013 SPACE 64200013 BKMVL ST RE2,0(0,RE3) 64500013 LTR RL1,RL1 TEST LENGTH TO BE MOVED. 64800013 BCR 12,LNK BRANCH IF NOT POSITIVE (INDICATES 65100013 * ALL THE SOURCE STRING IS NOW MOVED 65400013 * TO THE TARGET) 65700013 LM RE2,RO2,0(RE1) OTHERWISE LOAD NEXT 32 BITS OF 66000013 SLDL RE2,0(RO1) SOURCE DATA INTO RE2 66300013 LA RE3,4(0,RE3) UPDATE SOURCE AND TARGET POINTERS 66600013 LA RE1,4(0,RE1) TO NEXT WORD 66900013 SH RL1,X020 SUBTRACT 32 FROM LENGTH TO BE MOVED 67200013 BC 10,BKMVL BRANCH IF NON-NEGATIVE TO STORE DATA 67500013 SPACE 67800013 LH RM1,XFFF OTHERWISE SET MASK 68100013 LPR RO3,RL1 TO PRESERVE TARGET DATA. 68400013 BC 15,BK045 68700013 SPACE 69000013 BKSLR LM RE2,RO2,0(RE1) ALIGN SOURCE 69300013 SLDL RE2,0(RO1) DATA WITH 69600013 BC 15,BK030 TARGET AREA 69900013 SPACE 70200013 BKSRR LCR RO2,RO1 ALIGN SOURCE DATA 70500013 SRL RE2,0(RO2) WITH 70800013 BKX20 LA RO1,32(RO1,0) TARGET 71100013 BC 15,BK040 AREA. 71400013 SPACE 71700013 BK090 BCTR REP,0 IF 1ST SOURCE = TARGET, SET REP = 1 72000013 LA BAS,IHEBSKA-IHEBSKK(0,BAS) 72300013 * MODIFY BASE REGISTER 72600013 L RE3,0(0,RT1) UPDATE TARGET ADDRESS PAST 72900013 LR RO3,RE3 FIRST STRING AND CONVERT 73200013 SLDL RE3,3 TO A WORD ADDRESS 73500013 AH RE3,LFLD(0,RA) IN RE3 73800013 SRDL RE3,5 AND A BIT 74100013 SLL RE3,2 OFFSET 74400013 SRL RO3,27 IN RO3 74700013 LR CON,RS1 75000013 LA LNK,FINIS 75100015 B BK075 75300013 SPACE 75600013 * CONSTANTS 75900013 SPACE 76200013 X32K DC X'7FFF' 76500013 XFFF DC F'-1' FULL WORD OF ONES 76800013 H001 EQU BKH01+2 77100013 H002 EQU BKH02+2 77400013 H004 EQU FINIS+2 77700013 X020 EQU BKX20+2 HALFWORD CONSTANT OF 32. 78000013 SPACE 2 78300013 END 78600013 ./ ADD SSI=03011640,SOURCE=1,NAME=IHEBSMF BSM TITLE ' IHEBSM BIT STRING ASSIGN, FILL *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 384 BYTES 00140000 * 00160000 * FUNCTION IHEBSMF - TO ASSIGN A BYTE-ALIGNED STRING TO A 00180000 * BYTE-ALIGNED FIXED-LENGTH TARGET, FILLING OUT WITH ZERO 00200000 * BITS IF NECESSARY. 00220000 * THE MINIMUM OF THE SOURCE CURRENT LENGTH AND TARGET 00240000 * MAXIMUM LENGTH IS CALCULATED, AND THIS IS USED TO 00260000 * CONTROL THE MOVING OF THE SOURCE STRING WITH THE MVC 00280000 * INSTRUCTION. INCOMPLETE LAST BYTES ARE HANDLED IN 00300000 * REGISTERS. ZERO FILLING IS PERFORMED IF NECESSARY. 00320000 * THE CURRENT LENGTH IN THE TARGET SDV IS SET EQUAL TO 00340000 * THE MAXIMUM LENGTH. 00360000 * IHEBSMV - TO ASSIGN A BYTE-ALIGNED STRING TO A 00380000 * BYTE-ALIGNED VARIABLE-LENGTH TARGET. 00400000 * THE SOURCE STRING IS MOVED TO THE TARGET FIELD AS IN 00420000 * IHEBSMF, BUT WITHOUT ZERO FILLING. THE CURRENT LENGTH 00440000 * IN THE TARGET SDV IS SET APPROPRIATELY. 00460000 * IHEBSMZ - TO FILL OUT THE TARGET AREA FROM ITS CURRENT 00480000 * LENGTH TO ITS MAXIMUM LENGTH WITH ZERO BITS. 00500000 * NI, MVI, MVC INSTRUCTIONS ARE USED TO PROPOGATE 00520000 * ZEROS. THE CURRENT LENGTH IN THE SDV IS SET EQUAL TO 00540000 * THE MAXIMUM LENGTH. 00560000 * 00580000 * ENTRY POINTS 00600000 * IHEBSMF - FIXED-LENGTH ASSIGN 00620000 * RA = A(SDV OF SOURCE STRING) 00640000 * RB = A(SDV OF TARGET FIELD) 00660000 * IHEBSMV - VARIABLE-LENGTH ASSIGN 00680000 * RA = A(SDV OF SOURCE STRING) 00700000 * RB = A(SDV OF TARGET FIELD) 00720000 * IHEBSMZ - ZERO FILL. 00740000 * RA = A(SDV OF STRING). 00760000 * 00780000 * INPUT N/A 00800000 * 00820000 * OUTPUT N/A 00840000 * 00860000 * EXTERNAL MODULES 00880000 * N/A 00900000 * 00920000 * EXITS NORMAL 00940000 * RETURN TO CALLER VIA LINK REGISTER. 00960000 * 00980000 * TABLES/WORK-AREA 01000000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 01020000 * 01040000 * ATTRIBUTES READ-ONLY AND REENTRANT. 01060000 * 01080000 * PRIVATE MACROS 01100000 * IHELIB,IHESDR 01120000 * 01140000 * ASSEMBLY REQUIREMENTS 01160000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 01180000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01200000 * 01220000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01240000 * STANDARDS. 01260000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01280000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01300000 * EXTERNAL CHARACTER SET. 01320000 EJECT 01340000 IHEBSM CSECT 01360000 SPACE 2 01380000 IHELIB 01400000 SPACE 01420000 * PRIVATE REGISTER ASSIGNMENTS. 01440000 SPACE 01460000 SVL EQU R0 01480000 RS1 EQU RA 01500000 RT1 EQU RB 01520000 SVR EQU RC 01540000 RE1 EQU RD MUST BE 01560000 RO1 EQU RE EVEN-ODD PAIR. 01580000 RE2 EQU RF MUST BE 01600000 RO2 EQU RG EVEN-ODD PAIR. 01620000 LNK EQU LR 01640000 BAS EQU BR 01660000 SPACE 01680000 * PRIVATE OFFSETS. 01700000 SPACE 01720000 MFLD EQU 4 01740000 LFLD EQU 6 01760000 EJECT 01780000 IHEBSM CSECT 01800000 SPACE 01820000 ENTRY IHEBSMF,IHEBSMV,IHEBSMZ 01840000 SPACE 2 01860000 * *********************** 01880000 * * FIXED ENTRY POINT * 01900000 * *********************** 01920000 SPACE 01940000 USING *,BAS 01960000 IHEBSMF STM LR,RX,OFLR(DR) 01980000 LA BAS,IHEBSMV 02000000 USING IHEBSMV,BAS 02020000 BAL LNK,BM015 BRANCH TO VAR. ASSIGN ROUTINE 02040000 L LNK,OFLR(DR) RESTORE LINK REGISTER. 02060000 LR RS1,RT1 GO TO ZERO FILL WITH RE2,RO2 SET TO 02080000 BC 15,BMZZZ BYTE ADDRESS AND OFFSET OF FIRST 02100000 * BIT RESPECTIVELY. 02120000 SPACE 2 02140000 * *********************** 02160000 * * VAR. ENTRY POINT * 02180000 * *********************** 02200000 SPACE 02220000 USING *,BAS 02240000 IHEBSMV STM LR,RX,OFLR(DR) 02260000 BM015 IHESDR LW0,RD 02280000 LH RE1,LFLD(RS1) LOAD THE LESSER OF 02300000 LH RO1,MFLD(RT1) SOURCE CURRENT AND TARGET MAXIMUM 02320000 CR RE1,RO1 LENGTH INTO 02340000 BC 12,BM020 REGISTER 02360000 LR RE1,RO1 RE1 AND 02380000 BM020 STH RE1,LFLD(RT1) STORE INTO TARGET SDV. 02400000 L RS1,0(RS1) LOAD BYTE ADDRESSES OF 02420000 L RE2,0(RT1) SOURCE AND TARGET STRINGS 02440000 SRDL RE1,3 GET LENGTH IN BYTES IN RE1 02460000 SRL RO1,29 BIT OVERLAP IN RO1. 02480000 LCR RO2,RO1 GET COMPLEMENT OF BIT OVERLAP IN RO2 02500000 SH RE1,X001 SUBTRACT 1 02520000 BC 4,BM030 BRANCH IF LESS THAN BYTE TO MOVE. 02540000 SRDL RE1,8 GET NUMBER OF TIMES THROUGH MOVE 02560000 SRL RO1,24 LOOP IN RE1, LENGTH OF FIRST MOVE 02580000 LA RE1,1(0,RE1) IN RO1 02600000 SPACE 02620000 BMMVL EX RO1,BMMVI EXECUTE MOVE. 02640000 LA RE2,1(RO1,RE2) ADD LENGTH MOVED TO SOURCE AND 02660000 LA RS1,1(RO1,RS1) TARGET ADDRESSES. 02680000 LA RO1,255 SET RO1 TO 255 AFTER FIRST MOVE 02700000 BCT RE1,BMMVL LOOP IF MORE DATA. 02720000 SPACE 02740000 BM030 LTR RO2,RO2 RETURN IF BIT OVERLAP 02760000 BC 8,BM035 IS ZERO. 02780000 IC RE1,0(RS1) PUT LAST BYTE OF SOURCE IN RE1 02800000 LA RO1,X'FF' AND ZERO OUT 02820000 SLL RO1,8(RO2) UNWANTED 02840000 NR RE1,RO1 BITS. 02860000 SRL RO1,8 02880000 EX RO1,BMNII PUT BIT OVERLAP DATA INTO TARGET 02900000 EX RE1,BMOII CONSERVING REST OF TARGET BYTE. 02920000 BM035 L DR,OFDR(DR) 02940000 LM RB,RG,OFRB(DR) 02960000 MVI OFLR(DR),X'FF' 02980000 BCR 15,LNK RETURN. 03000000 SPACE 2 03020000 * *********************** 03040000 * * ZERO FILL ENTRY PT. * 03060000 * *********************** 03080000 SPACE 03100000 USING *,BAS 03120000 IHEBSMZ STM LR,RX,OFLR(DR) 03140000 BMZZZ IHESDR LW0,RD 03160000 BALR BAS,0 RESET USING REGISTER FOR ENTRY 03180000 USING *,BAS FROM IHEBSMF. 03200000 L RE2,0(RS1) CONVERT SOURCE STRING ADDRESS 03220000 LR RO2,RE2 TO A BIT ADDRESS 03240000 SLDL RE2,3 IN RE2. 03260000 AH RE2,LFLD(RS1) ADD THE CURRENT LENGTH AND CONVERT 03280000 SRDL RE2,3 TO A BYTE ADDRESS AND OFFSET IN 03300000 SRL RO2,29 REGISTERS RE2 AND RO2 RESPECTIVELY 03320000 LCR RO2,RO2 COMPLEMENT OFFSET. 03340000 LH RE1,MFLD(RS1) GET LENGTH FOR ZERO FILL IN RE1 03360000 LH RO1,LFLD(RS1) AND STORE MAXIMUM LENGTH IN 03380000 STH RE1,LFLD(RS1) CURRENT LENGTH 03400000 SR RE1,RO1 SLOT. 03420000 BC 8,BM100 RETURN IF CURRENT LENGTH WAS MAXIMUM 03440000 LA SVR,X'FF' SET MASK TO SAVE OFFSET 03460000 SLL SVR,8(RO2) BITS AT BEGINNING OF FIELD. 03480000 SR RE1,RO2 ADD OFFSET TO LENGTH OF FIELD 03500000 SH RE1,X008 SUBTRACT 8. 03520000 BC 2,BM040 BRANCH IF STILL POSITIVE. 03540000 LA RO1,X'FF' OTHERWISE SET MASK TO SAVE BITS AT 03560000 SRL RO1,8(RE1) END OF BYTE. 03580000 OR SVR,RO1 COMBINE TWO MASKS. 03600000 BC 15,BM090 BRANCH TO STORE ZERO BITS. 03620000 SPACE 03640000 BM040 EX SVR,BMNII ZERO REQUIRED BITS OF FIRST BYTE. 03660000 LA RE2,1(0,RE2) UPDATE ADDRESS OF STRING BY 1. 03680000 SRDL RE1,3 CONVERT LENGTH TO BYTES AND 03700000 SRL RO1,29 BIT OVERLAP. 03720000 LR RO2,RO1 SAVE BIT OVERLAP 03740000 SH RE1,X001 SUBTRACT 1 03760000 BC 4,BM080 BRANCH IF LESS THAN A BYTE LEFT. 03780000 BC 2,BM060 BRANCH IF AT LEAST 2 BYTES LEFT 03800000 MVI 0(RE2),X'00' MOVE IN A BYTE OF ZEROS AND BRANCH 03820000 BC 15,BM070 TO FILL BIT OVERLAP 03840000 SPACE 03860000 BM060 BCTR RE1,0 SUBTRACT 1 FROM LENGTH FOR MOVE 03880000 SRDL RE1,8 SET RE1 TO NUMBER OF TIMES THROUGH 03900000 SRL RO1,24 ZERO FILL LOOP,RO1 03920000 LA RE1,1(RE1) TO LENGTH OF FIRST FILL 03940000 MVI 0(RE2),X'00' MOVE IN A BYTE OF ZEROS. 03960000 SPACE 03980000 BMZLP EX RO1,BMMZI PROPAGATE ZEROS 04000000 LA RE2,1(RO1,RE2) ADD LENGTH MOVED TO BYTE ADDRESS 04020000 LA RO1,255 SET RO1 TO 255 AFTER FIRST FILL. 04040000 BCT RE1,BMZLP LOOP IF MORE TO FILL. 04060000 SPACE 04080000 BM070 LA RE2,1(RE2) SET RE2 TO LAST BYTE. 04100000 LTR RO2,RO2 TEST FOR ZERO OVERLAP 04120000 BC 8,BM100 BRANCH IF SO. 04140000 BM080 LA SVR,X'FF' SET UP MASK TO PRESERVE BITS OUTSIDE 04160000 SRL SVR,0(RO2) TARGET IN LAST BYTE. 04180000 BM090 EX SVR,BMNII AND MASK INTO LAST BYTE. 04200000 BM100 L DR,OFDR(DR) 04220000 LM RB,RG,OFRB(DR) 04240000 MVI OFLR(DR),X'FF' 04260000 BCR 15,LNK RETURN. 04280000 SPACE 04300000 * EXECUTED INSTRUCTIONS. 04320000 SPACE 04340000 BMMVI MVC 0(1,RE2),0(RS1) MOVE DATA INSTRUCTION 04360000 BMMZI MVC 1(1,RE2),0(RE2) PROPAGATE ZEROS INSTRUCTION 04380000 BMNII NI 0(RE2),X'00' MODIFIED BY MASK 04400000 BMOII OI 0(RE2),X'00' MODIFIED BY MASK 04420000 SPACE 04440000 * CONSTANTS 04460000 SPACE 04480000 X008 DC X'0008' HALFWORD CONSTANT OF 8. 04500000 X001 DC X'0001' HALFWORD CONSTANT OF 1. 04520000 END 04540000 ./ ADD SSI=03011681,SOURCE=1,NAME=IHEBSN0 BSN TITLE ' IHEBSN BIT STRING ''NOT'' *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 192 BYTES 00140000 * 00160000 * FUNCTION TO PRODUCE THE INVERSE OF A BYTE-ALIGNED BIT STRING 00180000 * IN A BYTE-ALIGNED TARGET. 00200000 * THE CURRENT LENGTH OF THE TARGET STRING IS SET EQUAL TO 00220000 * EITHER THE CURRENT LENGTH OF THE OPERAND OR TO THE 00240000 * MAXIMUM LENGTH OF THE TARGET FIELD (WHEN TRUNCATION IS 00260000 * NECESSARY TO AVOID EXCEEDING THE LENGTH OF THIS FIELD). 00280000 * THIS LENGTH IS USED TO CONTROL THE MOVING OF THE ONES TO 00300000 * THE TARGET FIELD AND THE SUBSEQUENT XC INSTRUCTION(S). 00320000 * INCOMPLETE LAST BYTES ARE HANDLED IN REGISTERS. THE 00340000 * REMAINDER OF THE TARGET FIELD BEYOND THE CALCULATED 00360000 * CURRENT LENGTH IS LEFT UNCHANGED. 00380000 * 00400000 * ENTRY POINTS 00420000 * IHEBSN0 00440000 * RA = A(SDV OF OPERAND) 00460000 * RB = A(SDV OF TARGET FIELD) 00480000 * 00500000 * INPUT N/A 00520000 * 00540000 * OUTPUT N/A 00560000 * 00580000 * EXTERNAL MODULES 00600000 * N/A 00620000 * 00640000 * EXITS NORMAL 00660000 * RETURN TO CALLER VIA LINK REGISTER. 00680000 * 00700000 * TABLES/WORK-AREA 00720000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00740000 * 00760000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00780000 * 00800000 * PRIVATE MACROS 00820000 * IHELIB,IHESDR 00840000 * 00860000 * ASSEMBLY REQUIREMENTS 00880000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00900000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00920000 * 00940000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00960000 * STANDARDS. 00980000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01000000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01020000 * EXTERNAL CHARACTER SET. 01040000 EJECT 01060000 IHEBSN CSECT 01080000 SPACE 2 01100000 IHELIB 01120000 SPACE 01140000 * PRIVATE REGISTER ASSIGNMENTS. 01160000 RS1 EQU RA 01180000 RT1 EQU RB 01200000 OFF EQU RC 01220000 RE1 EQU RD MUST BE 01240000 RO1 EQU RE EVEN-ODD PAIR. 01260000 LNK EQU LR 01280000 BAS EQU BR 01300000 SPACE 01320000 * PRIVATE OFFSETS. 01340000 SPACE 01360000 MFLD EQU 4 01380000 LFLD EQU 6 01400000 EJECT 01420000 IHEBSN CSECT 01440000 SPACE 01460000 ENTRY IHEBSN0 01480000 SPACE 2 01500000 USING *,BAS 01520000 IHEBSN0 STM LR,RX,OFLR(DR) 01540000 IHESDR LW0,RD 01560000 LH RE1,LFLD(RS1) SET RE1 TO CURRENT LENGTH OF SOURCE 01580000 LH RO1,MFLD(RT1) STRING OR MAXIMUM LENGTH OF 01600000 CR RE1,RO1 TARGET, WHICHEVER 01620000 BC 12,BN010 IS 01640000 LR RE1,RO1 LEAST. 01660000 BN010 STH RE1,LFLD(RT1) STORE IN TARGET SDV CURR.LENGTH SLOT 01680000 L RS1,0(RS1) LOAD RS1,RT1 WITH ADDRESSES OF 01700000 L RT1,0(RT1) SOURCE AND TARGET FIELDS. 01720000 SRDL RE1,3 CONVERT THE LENGTH IN BITS TO A BYTE 01740000 SRL RO1,29 LENGTH AND BIT OVERLAP. 01760000 LCR OFF,RO1 SAVE THE COMPLEMENT OF THE OVERLAP. 01780000 SH RE1,X001 SUBTRACT 1 01800000 BC 4,BN030 BRANCH IF LESS THAN A BYTE. 01820000 SRDL RE1,8 SET RE1 TO NUMBER OF TIMES THROUGH 01840000 SRL RO1,24 LOOP, RO1 TO LENGTH IN BYTES ON 01860000 LA RE1,1(RE1,0) FIRST TIME. 01880000 MVI 0(RT1),X'FF' MOVE A BYTE OF 1'S INTO TARGET. 01900000 SH RO1,X001 01920000 BC 4,BN020 BRANCH IF IT WAS A SINGLE BYTE. 01940000 SPACE 01960000 BNOTL EX RO1,BNMVI PROPAGATE 1'S THROUGH TARGET. 01980000 EX RO1,BNXCI EXCLUSIVE 'OR' SOURCE TO TARGET 02000000 * (LEAVING ONE FULL BYTE OF 1'S 02020000 * AT THE END OF THE TARGET) 02040000 LA RT1,1(RO1,RT1) ADD LENGTH MOVED TO TARGET AND 02060000 LA RS1,1(RO1,RS1) SOURCE ADDRESSES. 02080000 LA RO1,255 SET RO1 TO 255 AFTER FIRST SEGMENT 02100000 SPACE 02120000 BN020 BCT RE1,BNOTL LOOP IF MORE SEGMENTS. 02140000 SPACE 02160000 BNXCI XC 0(1,RT1),0(RS1) OTHERWISE EXCLUSIVE 'OR' LAST FULL 02180000 * BYTE OF SOURCE WITH 1'S ALREADY IN 02200000 * TARGET. NOTE THIS INSTRUCTION IS 02220000 * ALSO EXECUTED IN THE LOOP. 02240000 LA RS1,1(0,RS1) POINT SOURCE AND TARGET POINTERS AT 02260000 LA RT1,1(0,RT1) OVERLAP BYTE 02280000 BN030 NR OFF,OFF TEST LENGTH OF OVERLAP. 02300000 BC 8,BN040 RETURN IF ZERO. 02320000 IC RE1,0(RS1) PICK UP OVERLAP BYTE 02340000 LA RO1,X'FF' SET UP MASK FOR 02360000 SLL RO1,8(OFF) OVERLAP BITS 02380000 XR RE1,RO1 'NOT' OVERLAP BITS AND FILL 02400000 NR RE1,RO1 REST OF BYTE WITH ZEROS 02420000 SRL RO1,8 MODIFY MASK 02440000 EX RO1,BNNII MOVE RESULT TO TARGET, LEAVING REST 02460000 EX RE1,BNOII OF TARGET BYTE UNALTERED. 02480000 BN040 L DR,OFDR(DR) 02500000 LM RB,RE,OFRB(DR) 02520000 MVI OFLR(DR),X'FF' 02540000 BCR 15,LNK RETURN. 02560000 SPACE 2 02580000 * EXECUTED INSTRUCTIONS. 02600000 SPACE 02620000 BNMVI MVC 1(1,RT1),0(RT1) EXECUTED PROPAGATE ONES INSTRUCTION. 02640000 BNNII NI 0(RT1),X'00' EXECUTED BIT STORING 02660000 BNOII OI 0(RT1),X'00' INSTRUCTIONS. 02680000 SPACE 02700000 * CONSTANTS 02720000 SPACE 02740000 X001 DC X'0001' HALFWORD CONSTANT OF 1. 02760000 SPACE 2 02780000 END 02800000 ./ ADD SSI=03011681,SOURCE=1,NAME=IHEBSO0 BSO TITLE ' IHEBSO BIT STRING ''OR'' *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 312 BYTES 00140000 * 00160000 * FUNCTION TO IMPLEMENT THE 'OR' OPERATOR BETWEEN TWO BYTE- ALIGNED 00180000 * BIT STRINGS, PLACING THE RESULT IN A BYTE-ALIGNED TARGET 00200000 * FIELD. 00220000 * THE CURRENT LENGTH OF THE TARGET STRING IS SET TO EITHER 00240000 * THE MAXIMUM OF THOSE OF THE OPERANDS OR TO THE MAXIMUM 00260000 * LENGTH OF THE TARGET FIELD (WHEN TRUNCATION IS NECESSARY 00280000 * TO AVOID EXCEEDING THE LENGTH OF THIS FIELD). THE 00300000 * MINIMUM OF THE LENGTHS OF THE OPERANDS IS THEN USED TO 00320000 * CONTROL THE MOVING OF THE FIRST OPERAND TO THE TARGET 00340000 * FIELD AND THE SUBSEQUENT OC INSTRUCTION(S). INCOMPLETE 00360000 * LAST BYTES ARE HANDLED IN REGISTERS. ANY BITS REMAINING 00380000 * IN THE LONGER OPERAND FIELD ARE MOVED INTO THE TARGET 00400000 * FIELD UP TO THE CURRENT LENGTH CALCULATED FOR IT AND THE 00420000 * REMAINDER OF THE TARGET IS LEFT UNCHANGED. 00440000 * 00460000 * ENTRY POINTS 00480000 * IHEBSO0 00500000 * RA = A(SDV OF FIRST OPERAND) 00520000 * RB = A(SDV OF SECOND OPERAND) 00540000 * RC = A(SDV OF TARGET FIELD) 00560000 * 00580000 * INPUT N/A 00600000 * 00620000 * OUTPUT N/A 00640000 * 00660000 * EXTERNAL MODULES 00680000 * N/A 00700000 * 00720000 * EXITS NORMAL 00740000 * RETURN TO CALLER VIA LINK REGISTER. 00760000 * 00780000 * TABLES/WORK-AREA 00800000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00820000 * 00840000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00860000 * 00880000 * PRIVATE MACROS 00900000 * IHELIB,IHESDR 00920000 * 00940000 * ASSEMBLY REQUIREMENTS 00960000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00980000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01000000 * 01020000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01040000 * STANDARDS. 01060000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01080000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01100000 * EXTERNAL CHARACTER SET. 01120000 EJECT 01140000 IHEBSO CSECT 01160000 SPACE 2 01180000 IHELIB 01200000 SPACE 01220000 * PRIVATE REGISTER ASSIGNMENTS. 01240000 SPACE 01260000 IND EQU R0 01280000 RS1 EQU RA 01300000 RS2 EQU RB 01320000 RT1 EQU RC 01340000 RE1 EQU RD MUST BE 01360000 RO1 EQU RE EVEN-ODD PAIR. 01380000 OFF EQU RF 01400000 LNK EQU LR 01420000 BAS EQU BR 01440000 SPACE 01460000 * PRIVATE OFFSETS. 01480000 SPACE 01500000 MFLD EQU 4 01520000 LFLD EQU 6 01540000 EJECT 01560000 IHEBSO CSECT 01580000 SPACE 01600000 ENTRY IHEBSO0 01620000 SPACE 2 01640000 USING *,BAS 01660000 IHEBSO0 STM LR,RX,OFLR(DR) 01680000 IHESDR LW0,RD 01700000 LH IND,LFLD(RS1) 01720000 LH RE1,LFLD(RS2) 01740000 LH RO1,MFLD(RT1) 01760000 CR IND,RO1 SET IND TO CURRENT LENGTH OF FIRST 01780000 BC 12,BO010 STRING OR MAXIMUM LENGTH OF TARGET 01800000 LR IND,RO1 WHICHEVER IS LEAST. 01820000 BO010 CR RE1,RO1 SET RE1 TO CURRENT LENGTH OF SECOND 01840000 BC 12,BO020 STRING OR MAXIMUM LENGTH OF TARGET 01860000 LR RE1,RO1 WHICHEVER IS LEAST. 01880000 BO020 SR IND,RE1 RE1 CONTAINS THE LENGTH TO BE OR-ED 01900000 BC 10,BO030 AND IND THE FOLLOWING LENGTH MOVED 01920000 AR RE1,IND (NEGATIVE IF FROM STRING 2) 01940000 BO030 LPR RO1,IND STORE THE SUM OF THESE LENGTHS 01960000 AR RO1,RE1 IN THE TARGET SDV CURRENT 01980000 STH RO1,LFLD(RT1) LENGTH SLOT. 02000000 L RS1,0(RS1) LOAD RS1,RS2,RT1 WITH THE ADDRESSES 02020000 L RS2,0(RS2) OF THE TWO SOURCE AND TARGET 02040000 L RT1,0(RT1) FIELDS. 02060000 SRDL RE1,3 CONVERT THE LENGTH IN BITS TO A BYTE 02080000 SRL RO1,29 LENGTH AND BIT OVERLAP. 02100000 LCR OFF,RO1 SAVE THE COMPLEMENT OF THE OVERLAP 02120000 SH RE1,BOX01+2 SUBTRACT 1 FROM BYTE LENGTH 02140000 BC 4,BO040 BRANCH IF LENGTH LESS THAN A BYTE 02160000 SRDL RE1,8 SET RE1 TO NUMBER OF TIMES THROUGH 02180000 SRL RO1,24 LOOP,RO1 TO LENGTH IN BYTES 02200000 BOX01 LA RE1,1(RE1,0) ON FIRST TIME. 02220000 SPACE 02240000 BOOCL EX RO1,BOMVI MOVE DATA FROM 1ST SOURCE TO TARGET 02260000 EX RO1,BOOCI 'OR' 2ND SOURCE DATA WITH IT. 02280000 LA RT1,1(RO1,RT1) ADD LENGTH MOVED 02300000 LA RS1,1(RO1,RS1) TO TARGET AND 02320000 LA RS2,1(RO1,RS2) SOURCE ADDRESSES. 02340000 LA RO1,255 SET RO1 TO 255 AFTER FIRST SEGMENT. 02360000 BCT RE1,BOOCL LOOP IF MORE SEGMENTS. 02380000 SPACE 02400000 BO040 LPR RE1,IND RE1 NOW HAS LENGTH TO BE MOVED INTO 02420000 * TARGET FROM LONGER STRING. 02440000 SR RE1,OFF ADD BIT OVERLAP TO LENGTH IN RE1. 02460000 BC 8,BO075 RETURN IF LENGTH ZERO. THIS BRANCH 02480000 * IS TAKEN ONLY WHERE THE STRINGS 02500000 * ARE OF EQUAL LENGTH AND END ON A 02520000 * BYTE BOUNDARY. 02540000 LTR IND,IND TEST IND. 02560000 BC 8,BO080 IF ZERO, STRINGS ARE SAME LENGTH 02580000 BC 2,BO050 IF POSITIVE, FIRST IS LONGER 02600000 XR RS1,RS2 OTHERWISE INTERCHANGE POINTERS 02620000 XR RS2,RS1 SO THAT RS1 CONTAINS ADDRESS OF 02640000 XR RS1,RS2 LONGER. 02660000 BO050 IC RS2,0(RS2) PUT BITS OVERLAPPING SHORTER STRING 02680000 SRL RS2,8(OFF) WITH ZEROS IN THE REST OF THE BYTE 02700000 SLL RS2,8(OFF) INTO BITS 24-31 OF RS2. 02720000 SRDL RE1,3 CONVERT TO A BYTE LENGTH AND BIT 02740000 SRL RO1,29 OVERLAP. 02760000 LCR OFF,RO1 SAVE COMPLEMENT OF OVERLAP. 02780000 SH RE1,BOX01+2 SUBTRACT 1 FROM BYTE LENGTH 02800000 BC 4,BO090 BRANCH IF LENGTH LESS THAN A BYTE. 02820000 SRDL RE1,8 RE1 HAS NUMBER OF 256-BYTE SEGMENTS 02840000 SRL RO1,24 RO1 LENGTH OF FIRST MOVE. 02860000 EX RO1,BOMVI EXECUTE MOVE USING THIS LENGTH. 02880000 EX RS2,BOOII 'OR' IN LAST BYTE OF SHORTER FIELD. 02900000 LA RS1,1(RO1,RS1) ADD LENGTH TO LONGER FIELD ADDRESS 02920000 LA RT1,1(RO1,RT1) AND TARGET FIELD ADDRESS. 02940000 LTR RE1,RE1 TEST RE1. 02960000 BC 12,BO060 BRANCH IF NO 256-BYTE SEGMENTS 02980000 SPACE 03000000 BOMVL MVC 0(256,RT1),0(RS1) MOVE 256 BYTES OF LONGER FIELD 03020000 LA RS1,256(RS1) ADD 256 TO SOURCE AND 03040000 LA RT1,256(RT1) TARGET ADDRESSES. 03060000 BCT RE1,BOMVL LOOP IF MORE SEGMENTS. 03080000 SPACE 03100000 BO060 LTR OFF,OFF TEST FOR ZERO OVERLAP 03120000 BC 8,BO075 IF SO, RETURN TO CALLER. 03140000 IC RS1,0(RS1) INSERT LAST BYTE OF LONGER FIELD IN 03160000 BO070 LA RO1,X'FF' RS1, SET MASK IN RO1 03180000 SLL RO1,8(OFF) TO ZERO UNWANTED 03200000 NR RS1,RO1 BITS. 03220000 SRL RO1,8 MODIFY MASK FOR USE ON TARGET BYTE 03240000 EX RO1,BONII STORE BIT OVERLAP IN TARGET BYTE 03260000 EX RS1,BOOII LEAVING REMAINING BITS UNCHANGED. 03280000 BO075 L DR,OFDR(DR) 03300000 LM RB,RF,OFRB(DR) 03320000 MVI OFLR(DR),X'FF' 03340000 BCR 15,LNK RETURN TO CALLER. 03360000 SPACE 03380000 BO080 IC RS2,0(RS2) INSERT LAST BYTES OF SOURCE FIELDS 03400000 BO090 IC RS1,0(RS1) INTO RS1 AND RS2. 03420000 OR RS1,RS2 'OR' TOGETHER 03440000 BC 15,BO070 03460000 SPACE 2 03480000 * EXECUTED INSTRUCTIONS. 03500000 SPACE 03520000 BOMVI MVC 0(1,RT1),0(RS1) EXECUTED MOVE INSTRUCTION. 03540000 BOOCI OC 0(1,RT1),0(RS2) EXECUTED 'OR' INSTRUCTION. 03560000 BONII NI 0(RT1),X'00' EXECUTED BIT STORING 03580000 BOOII OI 0(RT1),X'00' INSTRUCTIONS. 03600000 SPACE 2 03620000 END 03640000 ./ ADD SSI=04011681,SOURCE=1,NAME=IHEBSS2 BSS TITLE ' IHEBSS BIT STRING SUBSTR *00600013 OS/360 PL/I LIBRARY' 01200013 * VERSION FOURTH VERSION OF F-LEVEL PL/1 COMPILER 01800015 * 02400013 * STATUS CHANGE LEVEL - 0. 03000013 * 03600013 * SIZE 240 BYTES 04200015 * 04800013 * FUNCTION TO PRODUCE A STRING DOPE VECTOR DESCRIBING THE SUBSTR 05400013 * PSEUDO-VARIABLE AND FUNCTION OF A BIT STRING. 06000013 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 06600013 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 07200013 * 07800013 * ENTRY POINTS 08400013 * IHEBSS2 - SUBSTR(S,I) 09000013 * RA = A(PLIST) 09600013 * PLIST = A(SDV OF SOURCE STRING) 10200013 * A(I) 10800013 * DUMMY ARGUMENT 11400013 * A(FIELD FOR TARGET SDV) 12000013 * IHEBSS3 - SUBSTR(S,I,J) 12600013 * RA = A(PLIST) 13200013 * PLIST = A(SDV OF SOURCE STRING) 13800013 * A(I) 14400013 * A(J) 15000013 * A(FIELD FOR TARGET SDV) 15600013 * 16200013 * INPUT N/A 16800013 * 17400013 * OUTPUT N/A 18000013 * 18600013 * EXTERNAL MODULES 19200013 * N/A 19800013 * 20400013 * EXITS NORMAL 21000013 * RETURN TO CALLER VIA LINK REGISTER. 21600013 * 22200013 * TABLES/WORK-AREA 22800013 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 23400013 * 24000013 * ATTRIBUTES READ-ONLY AND REENTRANT. 24600013 * 25200013 * PRIVATE MACROS 25800013 * IHELIB,IHESDR 26400013 * 27000013 * ASSEMBLY REQUIREMENTS 27600013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 28200013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 28800013 * 29400013 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 30000013 * STANDARDS. 30600013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 31200013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 31800013 * EXTERNAL CHARACTER SET. 32400013 EJECT 33000013 IHEBSS CSECT 33600013 SPACE 2 34200013 IHELIB 34800013 SPACE 35400013 * PRIVATE REGISTER ASSIGNMENTS. 36000013 SPACE 36600013 RW1 EQU R0 37200013 RE1 EQU R0 37800013 RO1 EQU RA 38400013 LTH EQU LR 38800015 SCR EQU BR 39200015 RS1 EQU RB SOURCE. 39600015 RII EQU RC I. 40000015 RJJ EQU RD J. 40400015 RT1 EQU RE TARGET. 40800015 SWJ EQU RF 41200015 BAS EQU RG 41600015 SPACE 42600013 * PRIVATE OFFSETS. 43200013 SPACE 43800013 LFLD EQU 4 LENGTH FIELD IN SDV. 44400013 OPRA EQU 16 GENERAL PART OF SAVE AREA. 45000013 SPACE 45600013 * BRANCH CONDITION MNEMONICS. 46200013 SPACE 46800013 NM EQU 11 47400013 NP EQU 13 48000013 A EQU 15 48600013 EJECT 49200013 IHEBSS CSECT 49800013 SPACE 50400013 ENTRY IHEBSS2,IHEBSS3 51000013 SPACE 2 51600013 * ************************************* 52200013 * * 2 ARGUMENTS, (J NOT SPECIFIED). * 52800013 * ************************************* 53400013 SPACE 54000013 IHEBSS2 NOPR 0 56000015 SPACE 2 58800013 * ************************************* 59400013 * * 3 ARGUMENTS, (J SPECIFIED). * 60000013 * ************************************* 60600013 SPACE 61200013 IHEBSS3 STM LR,WR,OFLR(DR) 61400015 BALR BAS,0 61600015 USING *,BAS 61800015 SR SWJ,SWJ INITIALISE SWJ 62000015 TM OFBR+3(DR),2 TEST ENTRY 62200015 IHESDR LW0,RB 62400015 BO BS005 BRANCH IF BSS3 ENTRY 62600015 LA SWJ,BS060-BS030 SET SWJ FOR J NOT SPECIFIED 62800015 BS005 LM RS1,RT1,0(RA) LOAD ARGUMENT LIST 63000015 L RII,0(RII) 63200015 LTR SWJ,SWJ 63400015 BNZ BS007 BRANCH IF J NOT SPECIFIED 63600015 L RJJ,0(RJJ) 63800015 LTR SCR,RJJ 64000015 BM BSTRG RAISE STRG IF J<0 64200015 CH RJJ,LFLD+2(RS1) 64400015 BH BSTRG RAISE STRG IF J>LTH 64600015 AR SCR,RII 64800015 BCTR SCR,0 65000015 CH SCR,LFLD+2(RS1) 65200015 BH BSTRG RAISE STRG IF I+J-1 >LTH 65400015 BS007 LTR RII,RII 65600015 BNP BSTRG RAISE STRG IF I<1 65800015 CH RII,LFLD+2(RS1) 66000015 BH BSTRG RAISE STRG IF I>LTH 66200015 BS009 LTR SWJ,SWJ 66400015 BNZ BS010 66600015 LTR RJJ,RJJ 66800015 BNP BSNUL NULL STRING IF J LE 0 67000015 BS010 C RII,XMIN IF I IS MAX NEG NO., 67200015 BE BS012 DON'T SUBTRACT 1. 68400013 SH RII,H001 RII = I-1. 69000013 BC NM,BS020 69600013 BS012 LTR SWJ,SWJ 70200013 BNZ BS015 BRANCH IF J NOT SPECIFIED. 70800013 AR RJJ,RII IF RII LT 0, SET RJJ = J+I-1 71400013 BC NP,BSNUL 72000013 BS015 SR RII,RII SET RII = 0. 72600013 BS020 LH LTH,LFLD+2(RS1) LOAD LENGTH OF SOURCE STRING. 73200013 SR LTH,RII SET LTH = LTH - RII. 73800013 BC NP,BSNUL 74400013 L RE1,0(RS1) CONVERT SOURCE 75000013 LR RO1,RE1 ADDRESS TO 75600013 SLDL RE1,3 A BIT ADDRESS IN RE1 76200013 AR RE1,RII ADD I, 76800013 SR RO1,RO1 RECONVERT TO A BYTE 77400013 SRDL RE1,3 ADDRESS AND 78000013 OR RE1,RO1 BIT OFFSET. 78600013 ST RE1,0(RT1) STORE RESULT IN TARGET SDV. 79200013 BC A,BS030(SWJ) IF J NOT SPECIFIED SUBSTR LENGTH=LTH 79800013 BS030 CR LTH,RJJ IF AVAILABLE LTH NOT GT J, THIS LTH 80400013 BC NP,BS060 MUST SERVE FOR THE SUBSTRING. 81000013 LR LTH,RJJ OTHERWISE SET LTH = J. 81600013 SPACE 82200013 BS060 STH LTH,LFLD(RT1) SET LENGTH FIELDS OF SDV. 82800013 STH LTH,LFLD+2(RT1) 83400013 BS070 L DR,OFDR(DR) 84000013 LM LR,RG,OFLR(DR) 84900015 BCR A,LR AND RETURN. 85800013 SPACE 86400013 BSTRG IHEPRV ERR,SCR,OP=LA 86600015 MVI 0(SCR),X'10' 86800015 L BR,VXEP 87000015 BALR LR,BR 87200015 B BS009 87400015 BSNUL SR RW1,RW1 IF SUBSTRING IS NULL, SET 87600013 ST RW1,LFLD(RT1) LENGTH FIELDS TO ZERO. 88200013 ST PR,0(RT1) SET ADDR TO DUMMY VALUE. 88800013 BC A,BS070 89400013 SPACE 90000013 * CONSTANTS 90600013 SPACE 91200013 H001 DC H'1' 91800013 DS 0F 92400013 XMIN DC X'80000000' 93000013 VXEP DC V(IHEERRB) 93300015 SPACE 2 93600013 END 94200013 ./ ADD SSI=00012091,SOURCE=1,NAME=IHEBSTA BST TITLE ' IHEBST BIT STRING TRANSLATE C00300001 OS/360 PL/1 LIBRARY' 00600001 * VERSION FIFTH VERSION OF F-LEVEL PL/1 COMPILER 00900001 * 01200001 * STATUS CHANGE LEVEL - 0 01500001 * 01800001 * SIZE 500 BYTES. 02100001 * 02400001 * FUNCTION THIS MODULE PERFORMS THE PL/1 TRANSLATE FUNCTION ON A 02700001 * TARGET BIT STRING GIVEN THE POSITIONAL AND REPLACEMENT 03000001 * BIT STRINGS 03300001 * 03600001 * ENTRY POINTS RA=A(PARAMETER LIST) 03900001 * PARAMETER LIST = A(SOURCE/TARGET SDV) 04200001 * A(REPLACEMENT SDV) 04500001 * A(POSITIONAL SDV) 04800001 * 05100001 * INPUT N/A 05400001 * 05700001 * OUTPUT N/A 06000001 * 06300001 * EXTERNAL MODULES 06600001 * IHEBSF - BOOL 06900001 * IHEBSI - INDEX 07200001 * IHEBSS - SUBSTRING 07500001 * 07800001 * EXITS NORMAL 08100001 * RETURN TO CALLER VIA LINK REGISTER 08400001 * 08700001 * TABLES/WORK-AREA 09000001 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 09300001 * 09600001 * ATTRIBUTES 09900001 * READ ONLY AND RE-ENTRANT 10200001 * 10500001 * PRIVATE MACROS 10800001 * IHELIB AND IHESDR 11100001 * 11400001 * ASSEMBLY REQUIREMENTS 11700001 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 12000001 * SUPPORT E.G. O/S 360 F-ASSEMBLER 12300001 * 12600001 * NOTES SEE O/S 360 PL/1 LIBRARY PLM FOR LIBRARY CONVENTIONS AND 12900001 * STANDARDS. 13200001 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON ANY 13500001 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL 13800001 * CHARACTER SET 14100001 EJECT 14400001 IHEBST CSECT 14700001 SPACE 15000001 IHELIB 15300001 * PRIVATE WORK AREA 15600001 SPACE 15900001 WORK DSECT 16200001 DS 72C 16500001 TEMPSDV DS D 16800001 BSDV DS D 17100001 POSITSDV DS D 17400001 SUBSDV DS D 17700001 INDEX0 DS F 18000001 INDEX1 DS F 18300001 IPLIST DS 3F 18600001 SPLIST DS 4F 18900001 BOOLMASK DS F 19200001 EJECT 19500001 IHEBST CSECT 19800001 SPACE 20100001 ENTRY IHEBSTA 20400001 SPACE 2 20700001 IHEBSTA EQU * 21000001 STM LR,RX,OFLR(DR) SAVE USERS REGISTERS 21300001 IHESDR LW1,RD 21600001 USING WORK,DR 21900001 BALR WR,0 ESTABLISH ADDRESSABILITY 22200001 USING *,WR 22500001 SPACE 22800001 * EXAMINE PROPERTIES OF POSITIONAL AND REPLACEMENT STRINGS 23100001 SPACE 23400001 LR RB,RA SAVE POINTER TO PARAMETER LIST. 23700001 LM RC,RE,0(RB) GET ADDRS OF S,R AND P SDVS. 24000001 LTR RD,RD + IS THERE A REPLACEMENT STRING. 24300001 BZ BST60 * NO.THEREFORE NO TRANSLATION. 24600001 LH RF,6(RD) GET LENGTH OF REP STRING. 24900001 LH RG,6(RC) GET LENGTH OF TARGET STRING. 25200001 LTR RG,RG + IS LENGTH ZERO. 25500001 BZ BST60 * YES.THEREFORE NO TRANSLATION. 25800001 SR RG,RG INITIALIZE BRANCH COUNT. 26100001 LTR RE,RE + IS THERE A POSITIONAL STRING. 26400001 BNZ BST10 * YES. 26700001 LA RE,POSIT ) 27000001 ST RE,POSITSDV )BUILD SDV FOR ASSUMED 27300001 L RE,X1 ) 27600001 AR RE,RE )POSITIONAL STRING. 27900001 ST RE,POSITSDV+4 ) 28200001 LA RE,POSITSDV GET ADDRESS OF POS SDV BUILT. 28500001 SPACE 28800001 BST10 EQU * 29100001 SPACE 29400001 LH RH,6(RE) GET LENGTH OF POS STRING. 29700001 LTR RH,RH + IS LENGTH OF POS STRING ZERO. 30000001 BZ BST60 * YES.THEREFORE NO TRANSLATION. 30300001 SPACE 30600001 * BUILD PART OF PARAMETER LIST OF IHEBSI WHICH IS COMMON 30900001 * TO ALL CALLS OF IHEBSI FROM THIS MODULE. 31200001 SPACE 31500001 ST RE,IPLIST 31800001 LA RJ,TEMPSDV 32100001 ST RJ,IPLIST+4 32400001 LA RJ,INDEX0 32700001 ST RJ,IPLIST+8 33000001 LA RJ,POSIT 33300001 ST RJ,TEMPSDV 33600001 L R0,X1 33900001 ST R0,TEMPSDV+4 34200001 SPACE 34500001 * BUILD PART OF PARAMETER LIST OF IHEBSS WHICH IS COMMON 34800001 * TO ALL CALLS OF IHEBSS FROM THIS MODULE. 35100001 SPACE 35400001 ST RD,SPLIST 35700001 LA RJ,ONE 36000001 ST RJ,SPLIST+4 36300001 ST RJ,SPLIST+8 36600001 LA RJ,SUBSDV 36900001 ST RJ,SPLIST+12 37200001 SPACE 37500001 LA RA,IPLIST SET UP PTR TO PARAMETER LIST. 37800001 L BR,VXEPI LOAD ENTRY POINT TO IHEBSI. 38100001 BALR LR,BR CALL IHEBSI TO LOCATE THE FIRST 38400001 L RH,INDEX0 ZERO BIT IN POSITIONAL STRING. 38700001 LTR RH,RH + IS RESULT ZERO. 39000001 BZ BST20 * YES.POS STRING ALL ONES. 39300001 OI TEMPSDV,X'20' 39600001 LA RJ,INDEX1 39900001 ST RJ,IPLIST+8 40200001 LA RA,IPLIST SET UP PTR TO PARAMETER LIST. 40500001 L BR,VXEPI LOAD ENTRY POINT TO IHEBSI. 40800001 BALR LR,BR CALL IHEBSI TO LOCATE THE FIRST 41100001 L RH,INDEX1 NON-ZERO BT IN POS STRING 41400001 LTR RH,RH + IS RESULT ZERO. 41700001 BZ BST21 * YES.POS STRING ALL ZEROS. 42000001 SPACE 42300001 * POSITIONAL STRING CONTAINS BOTH ZERO AND NON-ZERO BITS. 42600001 SPACE 42900001 C RF,INDEX0 43200001 BL BST30 * YES. 43500001 LA RJ,INDEX0 43800001 ST RJ,SPLIST+4 44100001 LA RA,SPLIST SET UP PTR TO PARAMETER LIST. 44400001 LA BR,BST70 44700001 BALR LR,BR 45000001 LTR RJ,RJ + IS IT A ZERO BIT. 45300001 BNM BST30 * YES. 45600001 LA RG,2(RG) STEP UP BRANCH COUNT BY TWO. 45900001 BST30 EQU * 46200001 C RF,INDEX1 46500001 BL BST40 * YES. 46800001 LA RJ,INDEX1 47100001 ST RJ,SPLIST+4 47400001 LA RA,SPLIST SET UP PTR TO PARAMETER LIST. 47700001 LA BR,BST70 48000001 BALR LR,BR 48300001 LTR RJ,RJ + IS IT A ZERO BIT. 48600001 BNM BST40 * YES. 48900001 LA RG,1(RG) STEP UP BRANCH COUNT BY ONE. 49200001 B BST40 49500001 SPACE 49800001 * POSITIONAL STRING CONTAINS ONLY NON-ZERO BITS. 50100001 SPACE 50400001 BST20 EQU * 50700001 LTR RF,RF IS LENGTH OF REP STRING ZERO. 51000001 BZ BST40 * YES. 51300001 LA RA,SPLIST SET UP PTR TO PARAMETER LIST. 51600001 LA BR,BST70 51900001 BALR LR,BR 52200001 LTR RJ,RJ + IS IT A ZERO BIT. 52500001 BNM BST40 * YES. 52800001 B BST60 * NO.THEREFORE NO TRANSLATION. 53100001 SPACE 53400001 * POSITIONAL STRING CONTAINS ONLY ZERO BITS. 53700001 SPACE 54000001 BST21 EQU * 54300001 LTR RF,RF IS LENGTH OF REP STRING ZERO. 54600001 BZ BST60 * YES. 54900001 LA RA,SPLIST SET UP PTR TO PARAMETER LIST. 55200001 LA BR,BST70 55500001 BALR LR,BR 55800001 LTR RJ,RJ + IS IT A ZERO BIT. 56100001 BNM BST60 * YES.THEREFORE NO TRANSLATION. 56400001 B BST52 * NO. TRANSLATE TO 'ALL ONES'. 56700001 BST40 EQU * 57000001 SR RJ,RJ 57300001 CR RJ,RG + BRANCH COUNT ZERO. 57600001 BE BST50 * YES. 57900001 LA RJ,1(RJ) NO. 58200001 CR RJ,RG + BRANCH COUNT ONE. 58500001 BE BST60 * YES. 58800001 LA RJ,1(RJ) NO. 59100001 CR RJ,RG + BRANCH COUNT TWO. 59400001 BE BST51 * YES. 59700001 LA RJ,1(RJ) NO. 60000001 CR RJ,RG + BRANCH COUNT THREE. 60300001 BE BST52 * YES. 60600001 SPACE 60900001 * SET UP APPROPRIATE MASK FOR CALL OF IHEBSF. 61200001 SPACE 61500001 BST50 EQU * 61800001 MVI BOOLMASK+3,X'00' SET MASK FOR 'ALL ZEROS'. 62100001 B BST53 62400001 BST51 EQU * 62700001 MVI BOOLMASK+3,X'0C' SET MASK FOR 'INVERSION'. 63000001 B BST53 63300001 BST52 EQU * 63600001 MVI BOOLMASK+3,X'0F' SET MASK FOR 'ALL ONES'. 63900001 SPACE 64200001 SPACE 64500001 * SET UP REMAINDER OF PARAMETER LIST TO DO THE TRANSLATION. 64800001 SPACE 65100001 BST53 EQU * 65400001 BPLIST EQU IPLIST 65700001 MVI BOOLMASK,X'00' 66000001 MVC BOOLMASK+1(2),BOOLMASK 66300001 LA RI,POSIT 66600001 ST RI,BSDV 66900001 L RI,X1 67200001 ST RI,BSDV+4 67500001 ST RC,BPLIST 67800001 LA RI,BSDV 68100001 ST RI,BPLIST+4 68400001 LA RI,BOOLMASK 68700001 ST RI,BPLIST+8 69000001 ST RC,BPLIST+12 69300001 LA RA,BPLIST 69600001 L BR,VXEPB LOAD ENTRY POINT TO EXT MODULE. 69900001 BALR LR,BR CALL IHEBSF. 70200001 B BST60 70500001 SPACE 70800001 BST70 EQU * 71100001 LRSAVE EQU BOOLMASK 71400001 ST LR,LRSAVE 71700001 L BR,VXEPS LOAD ENTRY POINT TO IHEBSS. 72000001 BALR LR,BR 72300001 L LR,LRSAVE 72600001 SR RH,RH 72900001 LA RI,SUBSDV 73200001 L RI,0(RI) 73500001 SLDL RH,3 73800001 SRL RI,3 74100001 IC RJ,0(RI) 74400001 SLL RJ,24(RH) 74700001 BR LR 75000001 SPACE 75300001 BST60 EQU * 75600001 L DR,OFDR(DR) 75900001 LM LR,WR,OFLR(DR) RESTORE USERS REGISTERS. 76200001 BR LR RETURN TO USER. 76500001 SPACE 76800001 * PROGRAM CONSTANTS 77100001 SPACE 77400001 POSIT DC X'40' 77700001 ONE DC F'1' 78000001 X1 DC X'00010001' 78300001 VXEPI DC V(IHEBSI0) 78600001 VXEPS DC V(IHEBSS3) 78900001 VXEPB DC V(IHEBSF0) 79200001 END 79500001 ./ ADD SSI=00011751,SOURCE=1,NAME=IHEBSVA BSV TITLE ' IHEBSV BIT STRING VERIFY X00400001 OS/360 PL/1 LIBRARY' 00800001 * VERSION FIFTH VERSION OF F-LEVEL PL/1 COMPILER. 01200001 * 01600001 * STATUS CHANGE LEVEL - 0. 02000001 * 02400001 * SIZE 408 BYTES 02800001 * 03200001 * FUNCTION THIS MODULE PERFORMS THE PL/1 VERIFY FUNCTION ON TWO 03600001 * GIVEN BIT STRINGS. 04000001 * EACH BIT OF A VERIFYING STRING IS COMPARED AGAINST EVERY 04400001 * BIT IN A VERIFIER STRING. IF ANY BIT OF THE VERIFYING 04800001 * CANNOT BE MATCHED IN THE VERIFIER STRING, THE OFFSET OF 05200001 * THAT BIT IS RETURNED IN A RESULT FIELD. 05600001 * THIS FUNCTION IS ACHEIVED BY FIRST CHECKING THE VERIFIER 06000001 * STRING TO SEE IF IT CONTAINS ONLY 1 OR 0 OR BOTH. USING 06400001 * THIS THE VERIFYING STRING IS THEN VERIFIED AGAINST THE 06800001 * EITHER 1 OR 0. IF THE VERIFIER STRING CONTAINS BOTH 1 07200001 * AND 0 THEN A ZERO RESULT IS RETURNED. 07600001 * 08000001 * ENTRY POINTS 08400001 * IHEBSVA 08800001 * RA = A(PLIST) 09200001 * PLIST = A(SDV OF VERIFYING STRING - E1) 09600001 * A(SDV OF VERIFIER STRING - E2) 10000001 * A(RESULT FIELD) 10400001 * 10800001 * INPUT N/A 11200001 * 11600001 * OUTPUT N/A 12000001 * 12400001 * EXTERNAL MODULES 12800001 * N/A 13200001 * 13600001 * EXITS NORMAL 14000001 * RETURN TO CALLER VIA LINK REGISTER. 14400001 * 14800001 * TABLES/WORK-AREA 15200001 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 15600001 * 16000001 * ATTRIBUTES 16400001 * READ-ONLY AND RE-ENTRANT. 16800001 * 17200001 * PRIVATE MACROS 17600001 * IHELIB,IHESDR 18000001 * 18400001 * ASSEMBLY REQUIREMENTS 18800001 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 19200001 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 19600001 * 20000001 * NOTES SEE OS/360 PL/1 LIBRARY PLM FOR LIBRARY CONVENTIONS AND 20400001 * STANDARDS. 20800001 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON A 21200001 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL 21600001 * CHARACTER SET 22000001 EJECT 22400001 IHEBSV CSECT 22800001 IHELIB 23200001 SPACE 2 23600001 * PRIVATE WORK AREA 24000001 SPACE 2 24400001 WORK DSECT 24800001 DS 72C 25200001 MASK DS C 25600001 E2FLAG DS C 26000001 BRFLAG DS C 26400001 NLFLAG DS C 26800001 MASK1 DS C 27000001 EJECT 27200001 IHEBSV CSECT 27600001 SPACE 28000001 ENTRY IHEBSVA 28400001 SPACE 2 28800001 IHEBSVA EQU * 29200001 STM LR,RX,OFLR(DR) SAVE USERS REGISTERS. 29600001 IHESDR LW0,RD 30000001 USING WORK,DR 30400001 BALR WR,0 ESTABLISH ADDRESSABILITY. 30800001 USING *,WR 31200001 SPACE 31600001 * EXAMINE PROPERTIES E1 AND E2 BIT STRINGS. 32000001 SPACE 32400001 MVI E2FLAG,X'0F' CLEAR VERIFY FLAG. 32800001 NI BRFLAG,X'00' INDICATE E2 BIT STR. 33200001 NI NLFLAG,X'00' CLEAR NULL STRING FLAG. 33600001 L RC,4(RA) GET A(E2 SDV) 34000001 BSV10 EQU * 34400001 L RG,0(RC) GET A(EX BIT STR). 34800001 LH RC,6(RC) GET L(EX BIT STR). 35200001 LTR RC,RC + IS EX A NULL STR. 35600001 BZ BSV28 * YES. WHAT TO DO. 36000001 SR RF,RF NO. CLEAR RF. 36400001 SLDL RF,3 GET BIT OFFSET E2 STR. 36800001 SRL RG,3 REAL A(EX BIT STR). 37200001 LA RI,0(RF) SAVE BIT OFFSET E2 STR. 37600001 LA RJ,7(RI,RC) TOT L(EX STR) IN BITS +7. 38000001 SRL RJ,3 CALC NO OF BYTES TO HOLD EX. 38400001 SR RH,RH SET BYTE COUNT EX TO 0. 38800001 TM BRFLAG,X'FF' + IS THIS E1 BIT STR. 39200001 BO BSV30 * YES. 39600001 SPACE 40000001 * GENERATE SPECIAL BYTE MASK FOR E2 40400001 SPACE 40800001 BSV20 EQU * 41200001 SR RD,RD INITIALIZE MASK GENERATION 41600001 LH RE,ALL1 REGISTERS TO 00 AND FF. 42000001 SLDL RD,0(RF) RD IS 00000XXX 42400001 LH RB,H008 42800001 SR RB,RF BITS E2 IN FIRST BYTE OF STR 43200001 CR RC,RB + E2 OVERLAPS BYTE BOUNDARY. 43600001 BNH BSV23 * NO. 44000001 SLL RD,0(RB) RD IS XXX00000. 44400001 B BSV24 * MASK NOW COMPLETE. 44800001 BSV23 EQU * 45200001 SLL RD,0(RC) RD IS 00XXX000. 45600001 SR RB,RC 46000001 SLDL RD,0(RB) RD IS XXX000XX. 46400001 BSV24 EQU * 46800001 X RD,ALL1-2 INVERT MASK. 47200001 SPACE 47600001 * CHECK E2 BYTE BY BYTE FOR ALL IS ALL 0S OR MIXED. 48000001 SPACE 48400001 EX RD,EXTM TEST A BYTE OF E2. 48800001 BM BSV39 E2 CONTAINS 1 AND 0S. 49200001 BO BSV25 E2 CONTAINS ONLY 1S. 49600001 TM E2FLAG,X'FF' + VERIFY FLAG SET TO ONE9 50000001 BO BSV39 * YES. SET RESULT TO ZERO. 50400001 NI E2FLAG,X'00' NO. E2 CONTAINS ONLY 0S. 50800001 B BSV26 INDICATE VERIFY BY 0. 51200001 BSV25 EQU * 51600001 TM E2FLAG,X'FF' + VERIFY FLAG SET TO ZERO. 52000001 BZ BSV39 * YES. SET RESULT TO ZERO. 52400001 OI E2FLAG,X'FF' NO. INDICATE VERIFY BY 1. 52800001 BSV26 EQU * 53200001 LA RH,1(RH) UP BYTE COUNT OF E2 STR. 53600001 CR RH,RJ + IS THIS THE LAST BYTE OF E2. 54000001 BNL BSV29 * YES.NOW VERIFY E1 BIT STR. 54400001 SH RC,H008 NO. REDUCE L(E2 BIT STR) BY 8. 54800001 AR RC,RF ALLOW FOR E2 BIT OFFSET. 55200001 SR RF,RF CLEAR E2 BIT OFFSET. 55600001 LA RG,1(RG) ADDRESS NEXT BYTE OF E2. 56000001 B BSV20 CHECK NEXT BYTE OF E2. 56400001 BSV28 EQU * 56800001 TM BRFLAG,X'FF' + IS THIS THE E1 STRING. 57200001 BO BSV39 * YES. RESULT IS ZERO. 57600001 OI NLFLAG,X'FF' NO. INDICATE E2 IS A NULL STR. 58000001 BSV29 EQU * 58400001 L RC,0(RA) GET A(E1 SDV). 58800001 OI BRFLAG,X'FF' INDICATE E1 BIT STR. 59200001 B BSV10 * NOW EXAMINE E1 BIT STR. 59600001 SPACE 60000001 * GENERATE SPECIAL BYTE MASK FOR E1. 60400001 SPACE 60800001 BSV30 EQU * 61200001 TM NLFLAG,X'FF' * IS E2 A NULL STR. 61600001 BO BSV41 * YES. RESULT IS ONE. 62000001 SR RD,RD 62400001 LH RE,ALL1 SET RE TO ALL ONES. 63400001 SLDL RD,0(RF) RD IS 00000XXX 65600001 LH RB,H008 66000001 SR RB,RF BITS E1 IN FIRST BYTE OF STR. 66400001 CR RC,RB + E1 OVERLAPS BYTE BOUNDARY. 66800001 BNH BSV33 * NO. 67200001 SLL RD,0(RB) RD IS XXX00000. 67600001 B BSV34 * MASK NOW COMPLETE. 68000001 BSV33 EQU * 68400001 SLL RD,0(RC) RD IS 00XXX000. 68800001 SR RB,RC 69200001 SLDL RD,0(RB) RD IS XXX000XX. 69600001 BSV34 EQU * 70000001 STC RD,MASK SAVE BYTE MASK FOR E1. 70400001 STC RD,MASK1 SAVE MASK BYTE FOR E1. 70600001 SPACE 70800001 * VERIFY E1 BYTE BY BYTE. 71200001 SPACE 71600001 OC MASK,0(RG) MASK A BYTE OF E1. 72000001 TM E2FLAG,X'FF' + VERIFY AGAINST 1. 72400001 BO BSV35 * YES. 72800001 XI MASK,X'FF' NO. SO INERT BYTE OF E1 AND 73200001 OC MASK,MASK1 AND RE-OR WITH MASK. 73400001 BSV35 EQU * VERIFY AGAINST ONE. 73600001 TM MASK,X'FF' + IS THIS BYTE OK. 74000001 BNO BSV36 * NO. CHECK BYTE BIT BY BIT. 74400001 LA RH,1(RH) YES. UP BYTE COUNT OF E1. 74800001 CR RH,RJ + IS THIS THE LAST BYTE OF E1. 75200001 BNL BSV39 * YES. SET RESULT TO ZERO. 75600001 SH RC,H008 NO. REDUCE L(E1 BIT STR) BY 8. 76000001 AR RC,RF ALLOW FOR E1 BIT OFFSET. 76400001 SR RF,RF CLEAR E1 BIT OFFSET. 76800001 LA RG,1(RG) ADDRESS NEXT BYTE E1. 77200001 B BSV30 CHECK NEXT BYTE E1. 77600001 SPACE 78000001 * VERIFY A BYTE OF E1 BIT BY BIT. 78400001 SPACE 78800001 BSV36 EQU * 79200001 IC RD,MASK GET BYTE E1 IN ERROR. 79600001 SRDL RD,8 80000001 LA RB,7 INITIAL BIT COUNT IS 7. 80400001 BSV37 EQU * 80800001 LTR RE,RE + IS THIS BIT IN ERROR. 81200001 BNM BSV38 * YES. 81600001 SLDL RD,1 NO. LOCATE NEXT BIT IN BYTE. 82000001 BCT RB,BSV37 CHECK NEXT BIT IN BYTE. 82400001 BSV38 EQU * 82800001 SLL RH,3 MULTIPLY BYTE COUNT BY 8. 83200001 LA RH,8(RH) SUBTRACT OFFSET OF BAD BIT. 83600001 SR RH,RB 84000001 SR RH,RI SUBTRACT INIT BIT OFFSET. 84400001 B BSV40 * STORE RESULT. 84800001 BSV41 EQU * 85200001 LA RH,1 RESULT IS ONE. 85600001 B BSV40 86000001 BSV39 EQU * 86400001 SR RH,RH RESULT IS ZERO. 86800001 BSV40 EQU * 87200001 L RA,8(RA) GET A(RESULT FIELD). 87600001 ST RH,0(RA) STORE RESULT. 88000001 L DR,OFDR(DR) 88400001 LM R0,WR,OFR0(DR) RESTORE USERS REGISTERS. 88800001 BR LR X RETURN TO USER. 89200001 SPACE 4 89600001 * PROGRAM CONSTANTS 90000001 SPACE 90400001 EXTM TM 0(RG),*-* 90800001 H008 DC H'8' 91200001 CNOP 2,4 91600001 ALL1 DC X'FFFF' 92000001 SPACE 4 92400001 END 92800001 ./ ADD SSI=05011972,SOURCE=1,NAME=IHECFAA CFA3 TITLE ' IHECFA ONLOC BUILT IN FUNCTION *01000013 OS/360 PL/I LIBRARY' 02000013 * VERSION THIRD VERSION OF F-LEVEL PL/1 COMPILER 03000013 * 04000013 * STATUS CHANGE LEVEL - 3 05000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CFA000-TSS 05300001 * ----------------------------------------------------CFA000-TSS 05600001 * 06000013 * SIZE 90 BYTES 07000013 * 08000013 * FUNCTION 09000013 * TO LOCATE THE BCD NAME OF THE ENTRY POINT OF THE 10000013 * PROCEDURE WHICH IMMEDIATELY EMBRACES THE INTERRUPT AND 11000013 * TO PLACE ITS ADDRESS IN A TARGET SDV - IF THE CALL TO 12000013 * ONLOC IS NOT MADE IN AN ON UNIT THEN A NULL STRING 13000013 * IS RETURNED 14000013 * 15000013 * ENTRY POINTS 16000013 * IHECFAA 17000013 * RA = A(PLIST) 18000013 * PLIST = A(TARGET SDV) 19000013 * 20000013 * INPUT 21000013 * AS ABOVE 22000013 * 23000013 * OUTPUT 24000013 * COMPLETED SDV 25000013 * 26000013 * EXTERNAL MODULES 27000013 * NONE 28000013 * 29000013 * SUPERVISOR MACROS 30000013 * NONE 31000013 * 32000013 * EXITS 33000013 * RETURN TO CALLER VIA LINK REGISTER 34000013 * 35000013 * TABLES/WORK AREA 36000013 * LWS LEVEL 0 37000013 * 38000013 * ATTRIBUTES READ ONLY AND REENTRANT 39000013 * 40000013 * PRIVATE MACROS 41000013 * IHELIB,IHESDR 42000013 * 43000013 * ASSEMBLY REQUIREMENTS 44000013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 45000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 46000013 * 47000013 * NOTES 48000013 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF LIBRARY 49000013 * CONVENTIONS AND STANDARDS. 50000013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 51000013 * UPON A PARTICULAR INTERNAL REPRESENTATION OF THE 52000013 * EXTERNAL CHARACTER SET. 53000013 EJECT 54000013 IHECFA CSECT 55000013 IHELIB 56000013 IHECFA CSECT 57000013 ENTRY IHECFAA 58000013 USING IHECFAA,PWR-1 59000013 IHECFAA STM LR,PWR,12(DR) SAVE REGS IN SAVE AREA 60000013 LR PWR-1,BR ESTABLISH ADDRESSABILITY 61000013 IHESDR LW0,RC UPDATE DR 62000013 L RA,0(RA) PICK UP ADDRESS OF TARGET 63000013 ST PR,0(RA) SET SDV FOR 63600013 XC 4(4,RA),4(RA) NULL STRING 64200013 LWSLP L RC,OFDR(RC) GET NEXT ELEMENT BACK 69200013 CLI 0(RC),X'25' IS IT LWS2 69400013 BE ONYES YES 69450015 CLI 0(RC),X'29' IS IT MAJOR TASK PRV VDA 69500015 BE LDR YES, ONLOC USED OUT OF CONTEXT 69550015 CLI 0(RC),X'2D' IS IT SUBTASK PRV 69600015 BE SUBPRV YES 69650015 CLI 0(RC),X'2F' IS IT SUBTASK PRV 69700015 BNE LWSLP NO 69750015 SUBPRV L RE,LPRV 69800015 L RC,8(RC,RE) CHAIN TO ATTACHORS DSA 69850015 B LWSLP 69900015 ONYES L RC,OFDR(RC) GET NEXT ELEMENT BACK 70000013 TM 0(RC),X'80' IS IT A DSA 71000013 BC 8,ONYES NO 72000013 TM 0(RC),X'10' IS IT A PROCEDURE DSA 73000013 BC 1,ONYES NO 74000013 NOPROC L RC,OFDR(RC) GET NEXT ELEMENT BACK 75000013 TM 0(RC),X'FF' SUPERVISOR SAVE AREA 76000013 BC 8,FOUND YES 77000013 TM 0(RC),X'80' IS IT A DSA 78000013 BC 8,NOPROC NO 79000013 FOUND L RC,OFBR(RC) ADDRESS OF CHAR STRING LENGTH 80000013 LA RC,4(RC) BUMP PAST BRANCH INSTRUCTION 81000013 MVC 5(1,RA),0(RC) INSERT LENGTH INTO DOPE VECTOR 82000013 MVC 7(1,RA),0(RC) MAX LENGTH=CURRENT LENGTH 83000013 LA RC,1(RC) ADDRESS OF CHAR STRING 84000013 ST RC,0(RA) INTO TARGET FIELD 85000013 LDR L DR,OFDR(DR) RESTORE DR 86000013 LM LR,PWR,12(DR) RESTORE REGS FROM SAVE AREA 87000013 BR LR RETURN TO CALLER 88000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CFA001-TSS 88500001 LPRV CXD 89000015 * ----------------------------------------------------CFA001-TSS 89500001 PWR EQU WR 90000013 END 91000013 ./ ADD SSI=06011970,SOURCE=1,NAME=IHECFBA CFB TITLE ' IHECFB ONCODE BUILT IN FUNCTION *00300015 OS/360 PL/I LIBRARY' 00600013 * VERSION FOURTH VERSION OF F-LEVEL PL/1 COMPILER 00900015 * 01200015 * STATUS CHANGE LEVEL - 0. 01500015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CFB000-TSS 01600001 * ----------------------------------------------------CFB000-TSS 01700001 * 01800013 * SIZE 02100013 * 02400013 * FUNCTION 02700013 * TO DETERMINE THE ONCODE OF THE ERROR OR INTERRUPT WHICH 03000013 * CAUSED ENTRY INTO THE ON UNIT AND TO STORE THIS ONCODE 03300013 * IN A 4-BYTE WORD ALIGNED TARGET 03600013 * 03900013 * ENTRY POINTS 04200013 * IHECFBA 04500013 * RA = A(PLIST) 04800013 * PLIST = A(4-BYTE WORD ALIGNED TARGET) 05100013 * 05400013 * INPUT 05700013 * VALUE OF WONC 06000013 * 06300013 * OUTPUT 06600013 * ONCODE VALUE IN TARGET 06900013 * 07200013 * EXTERNAL MODULES 07500013 * NONE 07800013 * 08100013 * SUPERVISOR MACROS 08400013 * NONE 08700013 * 09000013 * EXITS 09300013 * RETURN TO CALLER VIA LINK REGISTER 09600013 * 09900013 * TABLES/WORK AREA 10200013 * LWS LEVEL 0 10500013 * 10800013 * ATTRIBUTES READ ONLY AND REENTRANT 11100013 * 11400013 * PRIVATE MACROS 11700013 * IHELIB,IHEPRV,IHEZAP,IHESDR 12000013 * 12300013 * ASSEMBLY REQUIREMENTS 12600013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 12900013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 13200013 * 13500013 * NOTES 13800013 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF LIBRARY 14100013 * CONVENTIONS AND STANDARDS. 14400013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 14700013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 15000013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 15300013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 15600013 * CONSTANTS, BY REASSEMBLY, WILL RESULT IN A CORRECT 15900013 * MODULE FOR THE NEW DEFINITIONS. 16200013 EJECT 16500013 IHECFB CSECT 16800013 IHELIB 17100013 IHEZAP 17400013 IHEQLPR DXD A LENGTH OF PRV 17500001 IHECFB CSECT 17700013 ENTRY IHECFBA 18000013 USING *,PWR-1 18300013 USING IHEZLCA,PWR 18600013 USING IHEZDCL,RD 18900013 USING IHEZAPE,RE 19200013 IHECFBA STM LR,PWR,OFLR(DR) SAVE REGISTERS 19500013 LR PWR-1,BR ESTABLISH ADDRESSABILITY 19800013 IHESDR LW0,RH DR AT LW0 20100013 SR RB,RB 21300015 LWSLP L RH,OFDR(RH) GET NEXT ELEMENT BACK 21360015 CLI 0(RH),X'25' IS IT LWS2 21420015 BE GOTIT YES 21480015 CLI 0(RH),X'29' IS IT MAJOR TASK PRV VDA 21540015 BE LRA YES, ONCODE OUT OF CONTEXT 21600015 CLI 0(RH),X'2F' SUBTASK PRV VDA 21660015 BE SUBPRV YES 21720015 CLI 0(RH),X'2D' SUBTASK PRV VDA 21780015 BNE LWSLP NO 21840015 SUBPRV EQU * 21880001 IHEPRV LPR,RC,OP=L GET LENGTH OF PRV 21920001 L RH,8(RH,RC) CHAIN TO ATTECHORS DSA 21960015 B LWSLP 22020015 GOTIT LH PWR,LLWS 22080015 L PWR,16(PWR,RH) PWR AT LCA 22140015 SR RC,RC 22300015 IC RB,WONC PICK UP FIRST BYTE OF CODE 22800013 IC RC,WONC+1 PICK UP SECOND BYTE OF CODE 23100013 AR RC,RC DOUBLE SECOND BYTE 23400013 CLI WONC,X'10' IS CODE ON TYPE 23700015 BC 10,ONTYPE BRANCH IF YES 24000013 AR RB,RB DOUBLE FIRST BYTE 24300013 LH RB,ADTAB(RB) RB CONTAINS OFFSET INTO CODTAB 24600013 BC 15,COMMON 24900013 ONTYPE CLI WONC,X'C0' IS CODE IO CONVERSION 25200013 BNE NOTIOC BRANCH IF NOT 25500013 L RD,WFIL RD AT DECLARE CONTROL BLOCK 25800015 LH RE,DPRO RE HAS OFFSET TO PSEUDO REGISTER 26100013 L RE,0(RE,PR) RE AT DCBAPE 26400013 TM TFLX,TMIT IS TRANSMIT FLAG ON 26700013 BC 14,NOTIOC BRANCH IF NOT 27000013 LH RB,TRANSM RB CONTAINS OFFSET INTO CODTAB 27300013 BC 15,COMMON 27600013 NOTIOC SH RB,H16 SUBTRACT 16 27900015 SRA RB,2 AND MULTIPLY BY 4 28200013 LH RB,ONTAB(RB) RB CONTAINS OFFSET INTO CODTAB 28500013 COMMON LA RB,0(RB,RC) RB POINTS AT CODE 28800013 LH RB,CODTAB(RB) RB CONTAINS CODE 29100013 LRA L RA,0(RA) RA AT ADDRESS OF TARGET 29400013 ST RB,0(RA) ONCODE TO TARGET 29700013 L DR,OFDR(DR) RESTORE DR 30000013 LM LR,PWR,OFLR(DR) RESTORE REGISTERS 30300013 BR LR RETURN 30600013 H16 DC H'16' 31100015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CFB001-TSS 31140001 * ----------------------------------------------------CFB001-TSS 31180001 LLWS DC AL2(L'ZLSA+L'ZLW0+L'ZLW1+L'ZLW2+L'ZLW3+L'ZLW4+L'ZLWE) 31220015 ONTAB DC AL2(STRG-CODTAB) STRINGRANGE 31300015 DC AL2(OV-CODTAB) OVERFLOW 31500015 DC AL2(SIZ-CODTAB) SIZE 31800013 DC AL2(FOV-CODTAB) FIXED OVERFLOW 32100013 DC AL2(SUBR-CODTAB) SUBSCRIPT RANGE 32400013 DC AL2(CHLAB-CODTAB) CHECK(LABEL) 32700013 DC AL2(CONV-CODTAB) CONVERSION 33000013 DC AL2(CHVAR-CODTAB) CHECK(VARIABLE) 33300013 DC AL2(COND-CODTAB) CONDITION 33600013 DC AL2(FIN-CODTAB) FINISH 33900013 DC AL2(ERR-CODTAB) ERROR 34200013 DC AL2(ZDIV-CODTAB) ZERO DIVIDE 34500013 DC AL2(UNFLO-CODTAB) UNDERFLOW 34800013 DC AL2(AREA-CODTAB) AREA 35000015 DC H'0' 35200015 DC AL2(NAME-CODTAB) NAME 35400013 DC AL2(REC-CODTAB) RECORD 35700013 DC AL2(TRMIT-CODTAB) TRANSMIT 36000013 DC AL2(IOSIZE-CODTAB) IOSIZE 36300013 DC AL2(KEY-CODTAB) KEY 36600013 DC AL2(ENDP-CODTAB) ENDPAGE 36900013 DC AL2(ENDF-CODTAB) ENDFILE 37200013 DC AL2(IOCONV-CODTAB) IO CONVERSION 37500013 DC AL2(UFIL-CODTAB) UNDEFINED FILE 37800013 DC AL2(PEND-CODTAB) 37900001 TRANSM DC AL2(IOCOTR-CODTAB) IO CONVERSION (TRANSMIT) 38100013 ADTAB DC AL2(IOCODE-CODTAB) IOCODES 38400013 DC AL2(DPCODE-CODTAB) DPCODES 38700013 DC AL2(CSCODE-CODTAB) CSCODES 39000013 DC AL2(SPCODE-CODTAB) SOURCE PROGRAM ERRORS 39300013 DC AL2(CVCODE-CODTAB) CONVERSION ERRORS 39600013 DC AL2(PI-CODTAB) PROGRAM INTERRUPT 39900013 DC AL2(0) 39970015 DC AL2(0) 40040015 DC AL2(TE-CODTAB) TASKING ERRORS 40110015 CODTAB EQU * 40200013 PI DC H'8091' 40500013 DC H'8092' 40800013 DC H'8093' 41100013 DC H'8094' 41400013 DC H'8095' 41700013 DC H'8096' 42000013 DC H'8097' 42300013 TE DC H'3901' 42330015 DC H'3902' 42360015 DC H'3907' 42390015 DC H'3904' 42420015 DC H'3905' 42450015 DC H'3906' 42480015 DC H'3908' 42490015 DC H'3909' 42496001 DC H'3910' 42502001 STRG DC H'350' 42510015 OV DC H'300' 42600013 SIZ DC H'340' 42900013 FOV DC H'310' 43200013 SUBR DC H'520' 43500013 CHLAB DC H'510' 43800013 CONV DC H'600' 44100013 DC H'603' 44400013 DC H'606' 44700013 DC H'609' 45000013 DC H'612' 45300013 DC H'615' 45600013 DC H'618' 45900013 DC H'621' 46200013 DC H'624' 46500013 DC H'627' 46800013 CHVAR DC H'511' 47100013 COND DC H'500' 47400013 FIN DC H'4' 47700015 DC H'4' 48000015 ERR DC H'9' 48300013 ZDIV DC H'320' 48600013 UNFLO DC H'330' 48900013 AREA DC H'362' 48970015 DC H'361' 49040015 DC H'360' 49110015 NAME DC H'10' 49200013 REC DC H'20' 49500013 DC H'21' 49800013 DC H'22' 50100013 DC H'23' 50400013 DC H'24' 50700013 TRMIT DC H'40' 51000013 DC H'41' 51300013 DC H'42' 51600013 IOSIZE DC H'341' 51900013 KEY DC H'50' 52200013 DC H'51' 52500013 DC H'52' 52800013 DC H'53' 53100013 DC H'54' 53400013 DC H'55' 53700013 DC H'56' 54000013 DC H'57' 54300013 ENDP DC H'90' 54600013 ENDF DC H'70' 54900013 IOCONV DC H'601' 55200013 DC H'604' 55500013 DC H'607' 55800013 DC H'610' 56100013 DC H'613' 56400013 DC H'616' 56700013 DC H'619' 57000013 DC H'622' 57300013 DC H'625' 57600013 DC H'628' 57900013 IOCOTR DC H'602' 58200013 DC H'605' 58500013 DC H'608' 58800013 DC H'611' 59100013 DC H'614' 59400013 DC H'617' 59700013 DC H'620' 60000013 DC H'623' 60300013 DC H'626' 60600013 DC H'629' 60900013 UFIL DC H'80' 61200013 DC H'81' 61500013 DC H'82' 61800013 DC H'83' 62100013 DC H'84' 62400013 DC H'85' 62700013 DC H'81' 63000013 DC H'81' 63300013 DC H'81' 63600013 DC H'81' 63900013 DC H'81' 64200013 DC H'81' 64500013 DC H'86' 64600001 PEND DC H'100' 64700001 IOCODE DC H'1000' 64800013 DC H'1001' 65100013 DC H'1002' 65400013 DC H'1003' 65700013 DC H'1008' 66000013 DC H'1004' 66300013 DC H'1010' 66600013 DC H'1005' 66900013 DC H'1006' 67200013 DC H'1009' 67500013 DC H'1007' 67800013 DC H'1011' 68100013 DC H'1012' 68400013 DC H'1013' 68700013 DC H'1014' 69000013 DC H'1015' 69300013 DC H'1016' 69600013 DC H'1017' 69900013 DC H'1018' 70000015 DC H'1019' 70100015 DPCODE DC H'1500' 70200013 DC H'1502' 70500013 DC H'1504' 70800013 DC H'1506' 71100013 DC H'1508' 71400013 DC H'1510' 71700013 DC H'1512' 72000013 DC H'1514' 72300013 DC H'1501' 72600013 DC H'1503' 72900013 DC H'1505' 73200013 DC H'1507' 73500013 DC H'1509' 73800013 DC H'1511' 74100013 DC H'1513' 74400013 DC H'1515' 74700013 DC H'1550' 75000013 DC H'1551' 75300013 DC H'1552' 75600013 DC H'1553' 75900013 DC H'1554' 76200013 DC H'1555' 76500013 DC H'1556' 76800013 DC H'1557' 77100013 DC H'1558' 77400013 DC H'1559' 77700013 DC H'1560' 78000013 DC H'1561' 78300013 CSCODE DC H'9000' 78600013 DC H'9001' 78900013 DC H'2000' 79200013 DC H'2001' 79500013 DC H'9002' 79800013 DC H'9003' 80100013 SPCODE DC H'3' 80400013 DC H'3800' 80700013 DC H'3801' 81000013 DC H'4' 81300013 DC H'3900' 81600013 DC H'3903' 81700015 CVCODE DC H'3000' 81900013 DC H'3001' 82200013 DC H'3002' 82500013 DC H'3003' 82800013 DC H'3004' 83100013 DC H'3005' 83400013 DC H'3006' 83700013 DC H'3799' 84000013 DC H'3798' 84300013 PWR EQU WR 84600013 END 84900013 ./ ADD SSI=02012040,SOURCE=1,NAME=IHECFCA CFC TITLE ' IHECFC ONCOUNT BUILT IN FUNCTION *01000013 OS/360 PL/I LIBRARY' 02000013 * VERSION THIRD VERSION OF F-LEVEL PL/1 COMPILER 03000013 * 04000013 * STATUS CHANGE LEVEL - 3 05000013 * 06000013 * SIZE 07000013 * 08000013 * FUNCTION 09000013 * TO DETERMINE THE NUMBER OF INTERRUPTS (INCLUDING THE 10000013 * CURRENT ONE) THAT STILL HAVE TO BE HANDLED - THIS 11000013 * IS A MODEL 91 FACILITY 12000013 * 13000013 * ENTRY POINTS 14000013 * IHECFCA 15000013 * RA = A(PLIST) 16000013 * PLIST = A(4-BYTE WORD ALIGNED TARGET) 17000013 * 18000013 * INPUT 19000013 * VALUE OF ONCOUNT FROM LCA 20000013 * 21000013 * OUTPUT 22000013 * ONCOUNT VALUE IN TARGET 23000013 * 24000013 * EXTERNAL MODULES 25000013 * NONE 26000013 * 27000013 * SUPERVISOR MACROS 28000013 * NONE 29000013 * 30000013 * EXITS 31000013 * RETURN TO CALLER VIA LINK REGISTER 32000013 * 33000013 * TABLES/WORK AREA 34000013 * LWS LEVEL 0, LWE 35000013 * 36000013 * ATTRIBUTES READ ONLY AND REENTRANT 37000013 * 38000013 * PRIVATE MACROS 39000013 * IHELIB,IHEPRV,IHESDR 40000013 * 41000013 * ASSEMBLY REQUIREMENTS 42000013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 43000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 44000013 * 45000013 * NOTES 46000013 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF LIBRARY 47000013 * CONVENTIONS AND STANDARDS. 48000013 * CONVENTIONS AND STANDARDS. 49000013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 50000013 * UPON A PARTICULAR INTERNAL REPRESENTATION OF THE 51000013 * EXTERNAL CHARACTER SET. 52000013 EJECT 53000013 IHECFC CSECT 54000013 IHEZLWE DSECT 55000013 DS 19F 56000013 DS X 57000013 ESWTCH DS X 58000013 IHELIB 59000013 IHECFC CSECT 60000013 ENTRY IHECFCA 61000013 USING *,PWR-1 62000013 USING IHEZLCA,PWR 63000013 IHECFCA STM LR,PWR,OFLR(DR) SAVE REGISTERS 64000013 LR PWR-1,BR ESTABLISH ADDRESSABILITY 65000013 IHESDR LW0,RH DR AT LW0 66000013 OKONC IHEPRV LCA,PWR PWR AT LIB COMM AREA 67000013 SH PWR,EIGHT PWR AT ADDRESS OF PREVIOUS LCA 68000013 L PWR,0(PWR) PWR AT PREVIOUS LCA 69000013 SR RB,RB PREPARE FOR OUT OF CONTEXT 70000013 LTR PWR,PWR IS CHAIN BACK ZERO 71000013 BZ LRA YES 72000013 LRH L RH,OFDR(RH) GET CHAIN BACK 73000013 CLI 0(RH),X'25' IS IT LWS VDA 74000013 BC 7,LRH NO 75000013 L RH,20(RH) PICK UP ADDRESS OF LWE 76000013 USING IHEZLWE,RH 77000013 TM ESWTCH,X'40' MODEL91 IMPRECISE INTPT 78000013 BC 8,LRA NO 79000013 L RB,WONC+4 PICK UP ONCOUNT FROM LCA 80000013 LRA L RA,0(RA) RA AT ADDRESS OF TARGET 81000013 ST RB,0(RA) ONCOUNT TO TARGET 82000013 L DR,OFDR(DR) RESTORE DR 83000013 LM LR,PWR,OFLR(DR) RESTORE REGISTERS 84000013 BR LR RETURN 85000013 EIGHT DC H'8' 86000013 PWR EQU WR 87000013 END 88000013 ./ ADD SSI=21400048,NAME=IHECKPT,SOURCE=0 CKP TITLE ' IHECKP CHECKPOINT MODULE /00700015 OS/360 PL/1 LIBRARY ' 01400015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CKP000-TSS 01700001 * VERSION: FOURTH VERSION OF F-LEVEL PL/1 COMPILER 02100015 * 02200021 * CHANGE LEVEL 01. 02300021 * 02400021 * R21.6 A409000 D411000 CAS 45913 02500021 * 02600021 * 02800015 * FUNCTION IHECKP TAKES A CHECKPOINT 03500015 * 04200015 * 1. CREATES DCB FOR THE CHECKPOINT DATA SET 04900015 * 2. ISSUES THE 'CHKPT' MACRO 05600015 * 3. REMOVES THE DCB CREATED FOR CHECKPOINT DATA SET 06300015 * 07000015 * CONTROL SYSTEM: 07700015 * IHESA 08400015 * CHKPT 09100015 * 09800015 * ENTRY POINTS: 10500015 * IHECKPT 11200015 * 11900015 * LINKAGE: NONE 12600015 * 13300015 * INPUT NONE 14000015 * 14700015 * OUTPUT NONE 15400015 * 16100015 * EXTERNAL MODULES: 16800015 * NONE 17500015 * EXITS: 18200015 * NORMAL RETURN TO CALLER VIA LINK REGISTER 18900015 * 19600015 * ATTRIBUTES: 20300015 * READ ONLY AND REENTRANT 21000015 * 21700015 * PRIVATE MACROS: 22400015 * IHELIB 23100015 * 23800015 * ASSEMBLER REQUIREMENTS: 24500015 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSUEDO-REGISTER 25200015 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 25900015 * 26600015 * NOTES: 27300015 * SEE OS/360 PL/1 LIBRARY PLM FOR DESCRIPTION OF 28000015 * LIBRARY CONVENTIONS AND STANDARDS. 28700015 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 29400015 * A PARTICULER INTERNAL REPRESENTATION OF THE EXTERNAL 30100015 * CHARACTER SET 30800015 * 31500015 * ----------------------------------------------------CKP000-TSS 31800001 * 32200015 * 32900015 * 33600015 EJECT 34300015 IHECKP CSECT 35000015 IHELIB 35700015 SPACE 2 39200015 IHEZLW0 DSECT 39300001 CKSV DS 9D SAVE AREA 39400001 CKWK DS F WORK AREA 39500001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CKP004-TSS 39550019 CKLT DS A 39600001 CLEN DS 0AL1 LENGTH OF CHECK ID. IN PARM 39700001 CAID DS A A( CHECK ID. IN PARM ) 39800001 CKID DS CL16 CHECKPOINT ID IF ANY 39900001 CKDCB DS 0D START OF DCB 40000001 SPACE 3 40100001 PARM DSECT 40200001 DDNM DS A A(DDNAME SDV) 40300001 CHID DS A A(CHECKPOINT ID SDV) 40400001 DORG DS A A(ORGANISATION SDV) 40500001 CODE DS A A(RETURN CODE SLOT (HWB)) 40600001 SPACE 3 40700001 SDV DSECT 40800001 SADD DS A A(STRING) 40900001 SMXL DS H MAX LENGTH OF STRING CAS 45913 40950021 SCRL DS H CURRENT LENGTH OF THE STRING 41000001 EJECT 41200001 SPACE 2 42000015 SPACE 2 44100015 IHADCB DCBD DSORG=BS,DEVD=DA 44800015 * ----------------------------------------------------CKP004-TSS 45100019 EJECT 45500015 IHECKP CSECT 46200015 PWR EQU WR 46900015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CKP001-TSS 47200019 USING IHADCB,RE DCB BASE 47600015 USING IHEZLW0,DR SAVE AREA BASE 48300015 USING PARM,RF PARAMETER BASE 49000001 USING SDV,RG SDV BASE 49700001 * ----------------------------------------------------CKP001-TSS 50000019 SPACE 3 50400015 ENTRY IHECKPT,IHECKPS 51100001 EJECT 51800015 IHECKPT NOPR 0 52200001 IHECKPS EQU * 52600001 STM LR,PWR,OFLR(DR) STORE REGISTERS 53200015 SPACE 53900015 LR RF,RA SAVE PARAMETER 54300015 LR RH,DR SAVE LAST SAVE AREA ADDR. 54700015 SPACE 2 55300015 IHESDR LW0 UPDATE SAVE AREA POINTER 56000015 SPACE 56700015 BALR PWR,0 57200015 USING *,PWR ESTABLISH ADDRESSIBILITY 57700015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CKP002-TSS 57900001 L RJ,DCBLEN DCB LENGTH 58200015 LA R0,CKDCB-CKSV(RJ) TOTAL LENGTH OF WORK AREA 58800001 IHEPRV VDA,BR,OP=L A( GET VDA MODULE ) 59400015 BALR LR,BR $$ GET VDA 60200015 LA RJ,8(RA) ADDR. OF SAVE AREA 60800015 ST DR,OFDR(RJ) 61400015 LR DR,RJ 62000015 LA RE,CKDCB A( DCB IN VDA ) 62100001 ST RE,CKLT STORE INTO PARM LIST 62200001 MVC 0(DCBEND-CHKDCB,RE),CHKDCB MOVE DCB INTO AREA 62300001 MVI CKID,C' ' BLANK CHID SLOT 62400001 MVC CKID+1(15),CKID BLANK OUT THE REST OF FIELD 62500001 SR BR,BR ZERO ERROR REGISTER 62600001 ST BR,CKWK ZERO WORK AREA SLOT 62700001 TM OFBR+3(RH),X'02' IS IT ENTRY 'S'. 62800001 BNO CKPMC ENTRY ONE (CKPT) 62900001 CKPS1 EQU * 63000001 SPACE 2 63100001 * ANALISE PARAMETER LIST TO SEE IF DDNAME GIVEN 63200001 SPACE 2 63300001 L RG,DDNM LOAD A(DDNAME SDV) 63400001 LTR RG,RG + IS IT ZERO 63500001 BZ CKPCK * GO TO CHECK IF CHECK ID GIVEN 63600001 LH RD,SCRL NO, LOAD CURRENT LENGTH OF ST. 63700001 LTR RD,RD + IS IT ZERO 63800001 BZ CKPCK * YES, 63900001 CH RD,H008 + IS IT EQUAL TO 8 64000001 BNH CKPD1 * EQUAL TO OR LESS THAN 8 64100001 LH RD,H008 64200001 CKPD1 EQU * 64300001 MVI DCBDDNAM,X'40' BLANK DDNAME FIELD 64400001 MVC DCBDDNAM+1(7),DCBDDNAM BLANK OUT THE REST OF FIELD 64500001 BCTR RD,0 TAKE OFF ONE FOR EXECUTE 64600001 L RC,SADD A(STRING) 64700001 LA RH,DCBDDNAM A( STRING TO ) 64800001 EX RD,MOVES EXECUTE MVC TO MOVE DDNAME 64900001 CKPCK EQU * 65000001 TM DDNM,X'80' + IS THIS THE LAST PARAMETER 65100001 BO CKPMC * YES, 65200001 SPACE 2 65300001 * ANALYSE PARAMETER LIST TO SEE IF CHECK ID GIVEN 65400001 SPACE 2 65500001 L RG,CHID LOAD A(CHECKID) SDV 65600001 LTR RG,RG + IS IT ZERO 65700001 BZ CKPOG * YES,GO CHECK ORGANISATION. 65800001 LH RD,SCRL LOAD CURRENT LENGTH 65900001 LTR RD,RD + IS IT ZERO 66000001 BZ CKPOG * YES, 66100001 CH RD,H016 CHECK IF GREATER THAN 16 66200001 BNH CKPC1 66300001 LH RD,H016 MAXIMUM IS 16 66400001 CKPC1 EQU * 66500001 STH RD,CKWK+2 STORE LENGTH IN WORK AREA 66600001 BCTR RD,0 TAKE OFF ONE FOR EXECUTE 66700001 L RC,SADD A(STRING) 66800001 LA RH,CKID A( STRING TO ) 66900001 EX RD,MOVES EXECUTE MVC TO MOVE CHKID 67000001 CKPOG EQU * 67100001 TM CHID,X'80' + IS THIS THE LAST PARAMETER 67200001 BO CKPMC * YES, CHECKID MUST BE 8. 67300001 SPACE 2 67400001 * ANALYSE PARAMETER LIST TO SEE IF ORGANISATION GIVEN. 67500001 SPACE 2 67600001 L RG,DORG L A(ORGANISATION) SDV 67700001 LTR RG,RG + IS IT ZERO 67800001 BZ CKPCD * YES, GO TO CHECK RETURN CODE SLOT 67900001 LH RD,SCRL LOAD CURRENT LENGTH 68000001 LTR RD,RD + IS IT ZERO 68100001 BZ CKPCD * YES, 68200001 CH RD,H002 + CHECK IF EQUAL TO 2 68300001 BNE CKPE1 ** NO, THIS IS AN ERROR 68400001 L RC,SADD 68500001 CLC 0(2,RC),PS + IS IT PS 68600001 BE CKPCD * YES 68700001 CLC 0(2,RC),PO + IS IT PO 68800001 BNE CKPE1 ** NO, IT MUST BE AN ERROR 68900001 MVC DCBDSORG,CKPO MOVE ORGANISATION BITS INTO DCB 69000001 NC CKWK+2(2),CKWK+2 IS IT ZERO 69100001 BZ CKPCD 69200001 LA RD,8 69300001 STH RD,CKWK+2 MOVE LENGTH VALUE 69400001 B CKPCD 69500001 CKPE1 EQU * 69600001 LA BR,8 ERROR CODE 69700001 CKPCD EQU * 69800001 TM DORG,X'80' + IS THIS THE LAST PARAMETER 69900001 BO CKPMC * YES, 70000001 SPACE 2 70100001 * ANALYSE PARAMETER LIST TO SEE IF RETURN CODE VARIABLE GIVEN 70200001 SPACE 2 70300001 L RG,CODE LOAD ACCODE WORD) 70400001 LTR RG,RG + IS IT ZERO 70500001 BZ CKPMC * YES, NO RETURN CODE. 70600001 SR RD,RD ZERO VALUE 70700001 ST RD,0(RG) ZERO RETURN CODE 70800001 OI CKWK,X'80' PUT A FLAG FOR CODE SUPPLIED. 70900001 CKPMC EQU * 71000001 LTR BR,BR + ANY ERRORS SO FAR 71100001 BNZ CKPF1 * YES, GO SET UP ERROR SLOT 71200001 LA RA,CKLT 71300001 LA RD,CKID A(CHECKPOINT) IDENTIFICATION 71400001 ST RD,CAID STORE ADDR. OF CHKID 71500001 LH RD,CKWK+2 LENGTH OF CHECK ID 71600001 STC RD,CLEN STORE LENGTH VALUE IN PARM 71700001 LTR RD,RD + IS IT ZERO 71800001 BNZ CKPMS * NO, CHECK ID GIVEN 71900001 MVI CLEN,X'FF' FOR 'S' TYPE MACRO 72000001 CKPMS EQU * 72100001 SPACE 2 72200001 CHKPT MF=(E,(1)) $$ CHECKPOINT MACRO 72300001 SPACE 2 72400001 SPACE 74800015 CKPF1 EQU * 74900001 TM CKWK,X'80' + IS THERE ERROR SLOT 75000001 BNO CKPF2 * NO, 75100001 ST BR,0(RG) STORE IT INTO RET.WORD 75200001 CKPF2 EQU * 75300001 SPACE 3 75600015 L DR,OFDR(DR) RESTORE SAVE AREA POINTER 77600015 IHEPRV FVD,BR,OP=L A( FREE VDA MODULE ) 79600015 BALR LR,BR $$ FREE VDA 81900015 * ----------------------------------------------------CKP002-TSS 82200001 SPACE 2 82600015 L DR,OFDR(DR) RESTORE DSA REGISTER 83300015 LM LR,PWR,OFLR(DR) RESTORE REGISTERS 84000015 BR LR X RETURN 84700015 SPACE 3 85400015 SPACE 2 89600015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CKP003-TSS 89650001 H002 DC H'2' 89700001 H008 DC H'8' 89800001 H016 DC H'16' 89900001 PS DC CL2'PS' 90000001 PO DC CL2'PO' 90100001 CKPO DC B'0000001000000000' PARTITIONED ORGANISATION 90200001 MOVES MVC 0(0,RH),0(RC) MOVE FIELDS FROM RC TO RH 90300001 DCBLEN DC A(DCBEND-CHKDCB+8) 91000015 SPACE 2 91700015 EJECT 93800015 CHKDCB DCB DSORG=PS,MACRF=(W),DDNAME=SYSCHK,DEVD=DA 94500015 DCBEND EQU * 95200015 * ----------------------------------------------------CKP003-TSS 95500001 END IHECKP 95900015 ./ ADD SSI=07012410,SOURCE=1,NAME=IHECLSA CLS TITLE 'IHECLS CLOSE /00100013 OS/360 PL/I LIBRARY' 00200013 * VERSION THIRD VERSION OF F-LEVEL PL/1 COMPILER 00300013 * 00400013 * STATUS CHANGE LEVEL - 0 00500013 * 00600013 * SIZE 756 BYTES. 00700013 * 00800013 * FUNCTION CLOSE FILES. 00900013 * 1) CHECK STATUS OF FILE (IE.FILE REGISTER). 01000013 * 2) CLOSE FILES 01100013 * 3) ZERO FILE REGISTER (LAST THREE BYTES) 01200013 * 4) FREE THE BUFFER POOL OBTAINED FOR FILE. 01300013 * 5) FREE DYNAMIC CORE OBTAINED FOR FCB. 01400013 * 6) COMPLETE INITIALISATION OF SEQUENTIALLY CREATED 01500013 * REGIONAL DATA SETS BY CALLING IHEITC MODULE. 01600013 * 7) DELETE RECORD I/O MODULES LOADED AT OPEN TIME. 01700013 * 8) DE-CHAIN THE FILES FROM THE OPENED FILE CHAIN. 01800013 * 9) FREE IOCBS THAT WERE OBTAINED BY THE DIRECT ACCESS 01900013 * 02000013 * ENTRY POINTS 02100013 * IHECLSA -CLOSE 02200013 * RA= A(PLIST) 02300013 * PLIST = A(CLOSE PLIST) 02400013 * = A(ADCON) 02500013 * CLOSE PLIST = A(DCLCB) * THE NORMAL END 02600013 * A(IDENT SDV) * OF LIST BIT IS 02700013 * A(IDENT DED) * SET IN LAST WORD. 02800013 * 02900013 * INPUT 03000013 * FCB,DCLCB,ADCON LIST(SEE IHEOCL) 03100013 * 03200013 * OUTPUT 03300013 * FILE REGISTER SET TO ZERO. 03400013 * 03500013 * EXTERNAL MODULES 03600013 * LIBRARY0 03700013 * IHESAD - GET VDA. 03800013 * IHESAF - FREE VDA. 03900013 * IHEITC - FINISH INITIALISING REGIONAL DATA SET 04000013 * CONTROL SYSTEM0 04100013 * CLOSE - CLOSE FILES. 04200013 * FREEPOOL - FREEBUFFER POOLS. 04300013 * FREEMAIN - FREE CORE. 04400013 * DELETE - DELETE RECORD I/O MODULES 04500013 * 04600013 * EXITS 04700013 * RETURN VIA LINK REGISTER TO CALLER. 04800013 * 04900013 * TABLES/WORK AREA 05000013 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF 05100013 * FCB,DCLCB,AND FILE REGISTER. 05200013 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE(LWS). 05300013 * 05400013 * ATTRIBUTES READ ONLY AND REENTRANT 05500013 * 05600013 * PRIVATE MACROS 05700013 * IHELIB,IHEZAP 05800013 * 05900013 * ASSEMBLY REQUIREMENTS 06000013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 06100013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 06200013 * 06300013 * NOTES 06400013 * SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY MODULE 06500013 * CONVENTIONS AND STANDARDS. 06600013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 06700013 * UPON A PARTICULAR INTERNAL REPRESENTATION OF THE 06800013 * EXTERNAL CHARACTER SET. 06900013 EJECT 07000013 IHECLS CSECT 07100013 IHELIB 07200013 IHEZAP 07300013 DCBD DSORG=(QS) 07400013 EJECT 07500013 PARM DSECT 07600013 ODCL DS A A(FILE CONTROL BLOCK (DCLCB)). 07700013 OIDT DS A A(IDENT SDV). 07800013 OEOL DS 0BL1 END OF LIST FLAG. 07900013 ODED DS A A(DED FOR STRING). 08000013 SPACE 08100013 IHEZLW1 DSECT 08200013 DS 9D 08300013 PARMP DS A CLOSE PARM LIST ADDRESS. 08400013 VDAAD DS A VDA ADDRESS. 08500013 ITCPL DS 5A ITC PLIST SPACE. 08600013 SPACE 2 08700013 TCIT EQU TCBA EXTENDED DCB APE 08800013 RERD EQU X'10' REREAD DISPOSITION. 08900013 LEVE EQU X'30' LEAVE DISPOSITION. 09000013 LEAV EQU X'80' LEAVE OPTION. 09100013 MEOL EQU X'80' END OF LIST. 09200013 VALS EQU X'10' FIXED OR VARIABLE STRING. 09300013 EJECT 09400013 IHECLS CSECT 09500013 ENTRY IHECLSA 09550001 SPACE 2 09600013 USING *,RJ 09700013 USING IHEZADC,RI 09800013 USING IHADCB,RE 09900013 USING IHEZAPE,RC 10000013 USING IHEZLW1,DR 10100013 USING PARM,RG 10200013 USING IHEZIOB,RD 10300013 SPACE 10400013 IHECLSA STM LR,WR,OFLR(DR) . SAVE CALLERS REGISTERS. 10500013 LR RJ,BR SET UP BASE REGISTER. 10600013 L RI,4(RA) GET A(ADCON LIST). 10700013 LH WR,IQLW0 GET LWS 0 OFFSET. 10800013 L WR,0(WR,PR) A(LIBWS) IN PWR. 10900013 L RG,0(RA) 11000013 ST DR,OFDR(WR) SET UP SAVE AREA POINTER. 11100013 LR DR,WR * 11200013 LA R0,108 11300013 L BR,ISADF 11400013 BALR LR,BR $$ GET A DUMMY SSA. 11500013 L DR,OFDR(DR) GET A(CALLER'S SSA). 11600013 ST DR,OFDR+8(RA) SET UP DUMMY SSA. 11700013 LA DR,8(RA) * 11800013 OI 0(DR),X'61' / SET DUMMY LIB WORK SPACE FLAG. 11900013 ST RG,PARMP SAVE P.LIST POINTER. 12000013 SPACE 2 12100013 LA RA,1 12200013 CLTES EQU * 12300013 TM OEOL,MEOL + END OF P.LIST YET. 12400013 BO CLNFS YES,NO OF FILES TO CLOSE FOUND. 12500013 LA RG,12(RG) NO,BUMP PARM LIST POINTER. 12600013 LA RA,1(RA) BUMP NO OF FILES COUNT. 12700013 B CLTES 12800013 SPACE 12900013 CLNFS EQU * 13000013 SLL RA,2 4*N. 13100013 LR RB,RA SAVE NO OF FILES'N'. 13200013 LA R0,12(RA) 12+4*N BYTES FOR VDA. 13300013 L BR,ISADF 13400013 BALR LR,BR $$ GET VDA. 13500013 ST RB,8(RA) SAVE IN VDA. 13600013 LA RF,8(RA) 13700013 ST RF,VDAAD SAVE A(VDA). 13800013 L RG,PARMP GET A(P.LIST). 13900013 EJECT 14000013 CLLP1 EQU * 14100013 LA RF,4(RF) BUMP DAMT P.LIST POINTER. 14200013 CLLP2 EQU * 14300013 L RD,ODCL GET ADDRESS OF DCLCB 14400013 LH RE,0(RD) GET P.R.OFFSET OF FILE. 14500013 ALR RE,PR A(P.R.SLOT). 14600013 L RC,0(RE) A(FCB) 14700013 LA RC,0(RC) LOOSE TOP BYTE 14800013 LTR RC,RC + IS IT ZERO 14900013 BNZ CLGER * NO, 15000013 TM OEOL,MEOL + END OF LIST YET. 15100013 BO CLTAO YES. 15200013 LA RG,12(RG) NO,BUMP PARM.LIST POINTER. 15300013 B CLLP2 15400013 CLTAO EQU * 15500013 SH RF,X04X 15600013 CL RF,VDAAD + ANY FILES LEFT TO BE CLOSED. 15700013 BE CLEND NO. 15800013 B CLSEP YES. 15900013 CLGER EQU * 16000013 TM 0(RE),X'FF' + ERROR DETECTED ON OPEN 16100013 BZ CLGEM * NO, 16200013 OI TFHT,TMET / SET END OF EXTENT FLAG 16300013 CLGEM EQU * 16400013 OI TFHT,TMCL / SET CLOSE IN PROGRESS FLAG. 16500013 L RE,TDCB 16600013 LA RE,0(RE) GET A(DCB). 16700013 ST RE,0(RF) SET DCB INTO CLOSE P.LIST. 16800013 OI 0(RF),RERD / SET REREAD BITS FOR OPEN DISP. 16900013 TM 8(RD),LEAV + LEAVE SPECIFIED ON ENV. 17000013 BZ CLGEN NO. 17100013 OI 0(RF),LEVE / YES, SET LEAVE FOR OPEN DISP. 17200013 CLGEN EQU * 17300013 TM TFTY,TMRC + RECORD I/O. 17400013 BO CL004 YES. 17500013 TM TFRC,TMFX + F FORMAT RECORDS. 17600013 BZ CLJ00 BRANCH IF NOT F-FORMAT. 17700015 TM TFMD,TMOP + OUTPUT BUFFER TO BE FILLED. 17800013 BZ CL001 * NO. 17900013 LH RB,TREM YES,GET REM. BYTES IN RECORD. 18000013 LTR RB,RB + ANY REMAINING. 18100013 BZ CL001 NO. 18200013 L RA,TCBA GET A(CURRENT BYTE). 18300013 CL002 EQU * 18400013 MVI 0(RA),C' ' FILL UP WITH BLANKS. 18500013 LA RA,1(RA) BUMP A(CURRENT BYTE). 18600013 BCT RB,CL002 + LAST BYTE. 18700013 B CL001 18800013 EJECT 18900013 CLJ00 EQU * 18910015 L RA,TREC GET A(DUMMY BUFFER). 18920015 LTR RA,RA HAS IT BEEN ALLOCATED? 18930015 BZ CL001 NO. 18940015 LH R0,DCBBLKSI YES. GET LENGTH OF BLOCK. 18950015 A R0,SUBPL 18960015 FREEMAIN R,LV=(0),A=(1) FREE CORE GOT FOR DUMMY BUFFER. 18970015 B CL001 18980015 * COMPLETE INITIALISING OF REG DATA SET. 19000013 SPACE 19100013 CL004 EQU * 19200013 CLI TFAC,TMBL + BSAM LOAD NODE. 19300013 BNE CL001 NO. 19400013 TM TFHT,TMET + END OF EXTENT. 19500013 BO CL001 YES. 19600013 TM TFER,TMOE + TRANSMIT ERROR. 19700013 BO CL001 YES. 19800013 MVC ITCPL(20),CLITC MOVE ITC PLIST INTO WORKSPACE. 19900013 ST RD,ITCPL A(DCLCB) IN PLIST. 20000013 LA RB,ITCPL A(PLIST FOR ITC MOD. 20100013 LH RA,IQLCA GET PRV OFFSET OF LCA. 20200013 L RA,0(RA,PR) GET A(LCA). 20300013 ST RD,WFIL-WBR1(RA) SET WFIL IN CASE OF ONFILE. 20400013 LR RA,RC A(FCB). 20500013 L BR,TACM A(IHEITCA). 20600013 BALR LR,BR $$ GO AND INITIALISE REST OF D.S. 20700013 CL001 EQU * YES. 20800013 L RA,OIDT GET A(IDENT SDV). 20900013 CLNID EQU * 25000013 MVC DCBSYNAD+1(3),SYNADM+1 ZERO SYNAD ADDRESS IN DCB. 25100013 TM OEOL,MEOL + END OF LIST YET. 25200013 BO CLSEP YES. 25300013 LA RG,12(RG) NO,BUMP P.LIST. 25400013 B CLLP1 25500013 CLSEP EQU * 25600013 OI 0(RF),MEOL / SET END OF P.LIST FLAG. 25700013 L RA,VDAAD 25800013 LA RA,4(RA) A(DAMT CLOSE P.LIST). 25900013 LR RF,RA SAVE POINTER. 26000013 L RG,PARMP A(PL/I CLOSE P.LIST). 26100013 CLOSE MF=(E,(1)) $$ CLOSE FILES. 26200013 CLAG1 EQU * 26300013 L RG,PARMP A(CLOSE P.LIST). 26400013 LA RA,12(RG) SAVE A(NEXT ENTRY). 26500013 ST RA,PARMP * 26600013 L RD,0(RG) 26700013 LH RC,0(RD) PR OFFSET OF FILE. 26800013 L RC,0(RC,PR) A(DCBAPE). 26900013 CLC TDCB+1(3),1(RF) DCB'S CHECK OUT. 27000013 BE CLFND YES. 27100013 B CLAG1 NO. 27200013 CLFND EQU * 27300013 LH RE,0(RD) GET OFFSET OF P.R. 27400013 ALR RE,PR 27500013 XC 1(3,RE),1(RE) ZERO FILE REGISTER. 27600013 L LR,IFOPE 27700013 LTR LR,LR + 2ND RELEASE OCL. 27800013 BZ CLFNC NO. 27900013 LA RC,0(RC) A(FCB). 28000013 LH LR,IQFOP OFFSET OF FCB CHAIN ANCHOR. 28100013 L BR,0(LR,PR) A(1ST FCB). 28200013 LA BR,0(BR) A(FCB HIGHER IN CHAIN). 28300013 CLR BR,RC + FCB'S CHECK. 28400013 BNE CLFN2 NO. 28500013 ALR LR,PR YES, A(ANCHOR POINT). 28600013 MVC 1(3,LR),TFOP+1 RESET CHAIN. 28700013 B CLFNC * 28800013 CLFN2 EQU * 28900013 L LR,TFOP-TBEG(BR) GET A(NEXT FCB). 29000013 LA LR,0(LR) * 29100013 CLR LR,RC + FCB'S CHECK. 29200013 BE CLFN3 YES. 29300013 LR BR,LR 29400013 B CLFN2 29500013 CLFN3 EQU * 29600013 MVC TFOP-TBEG+1(3,BR),TFOP+1 RESET FCB CHAIN. 29700013 CLFNC EQU * 29800013 CLI TFAC,TMBS + BSAM ACCESS METHOD USED. 29900013 BL CLFNE NO. 30000013 L RD,TLAB GET A(LAST IOCB ALLOCATED). 30100013 LTR RD,RD + DOES IT EXIST. 30200013 BZ CLFNE NO. 30300013 CLFN4 EQU * 30400013 TM BERR,BMDB + DUMMY BUFFER LEFT UNFREED. 30500013 BZ CLFN5 NO. 30600013 L RA,BARE YES, FREE IT. 30700013 LH R0,DCBBLKSI * 30800013 A R0,SUBPL * 30900013 FREEMAIN R,LV=(0),A=(1) $$ FREE DUMMY BUFFER. 31000013 CLFN5 EQU * 31100013 BAL LR,CLEVT TEST EVENT VARIABLE 31200013 L RD,BPIO GET A(PRIOR IOCB). 31300013 LTR RD,RD + END OF CHAIN YET. 31400013 BNZ CLFN4 NO. 31500013 CLFNE EQU * 31600013 L RE,0(RF) A(DCB) 31700013 TM DCBBUFCB+3,X'01' + BUFFER POOL ALLOCATED. 31800013 BO CL099 NO. 31900013 LR RA,RE 32000013 FREEPOOL (1) $$ FREE BUFFER POOL 32100013 CL099 EQU * 32200013 TM TFDV,TMPA + PAPER TAPE DEVICE. 32300013 BZ CL09A NO. 32400013 CLI TFAC,TMQS + QSAM ACCESS METHOD. 32500013 BE CL09B YES. 32600013 CL09A EQU * 32700013 TM TFTY,TMRC + RECORD I/O. 32800013 BO CL100 YES. 32900013 CL09B EQU * 33000013 B CLNTU 33700013 EJECT 33800013 * DELETE MODULES LOADED AT OPEN TIME. 33900013 SPACE 34000013 CL100 EQU * 34100013 SR RA,RA 34200013 IC RA,TFAC GET ACCESS CODE. 34300013 B *+4(RA) 34400013 B CL120 QSAM. 34500013 B CL130 BDAM. 34600013 B CL150 QISAM. 34700013 B CL140 BISAM. 34800013 B CL110 BSAM. 34900013 SPACE 35000013 * BSAM LOAD . 35100013 SPACE 35200013 DELETE EP=IHEITCA ** DELETE LOAD MODULE. 35300013 B CLNTU 35400015 SPACE 35500013 * BSAM. 35600013 CL110 EQU * 35700013 DELETE EP=IHEITBA ** DELETE LOAD MODULE. 35800013 B CLNTU 36100013 SPACE 36200013 * QSAM. 36300013 SPACE 36400013 CL120 EQU * 36500013 DELETE EP=IHEITGA ** DELETE LOAD MODULE. 36600013 B CLNTU 36700013 SPACE 36800013 * BDAM. 36900013 SPACE 37000013 CL130 EQU * 37100013 DELETE EP=IHEITFA ** DELETE LOAD MODULE. 37200013 B CL142 37300013 * BISAM. 37400013 CL140 EQU * 37500013 DELETE EP=IHEITEA ** DELETE LOAD MODULE. 37600013 CL142 EQU * 37700013 L R0,TBBZ GET LENGTH OF BUBL. 37800013 LR RB,R0 SAVE IT. 37900013 L RD,TLAB A(1ST BUBL). 38000013 CL144 EQU * 38100013 CLI BPIO,X'FF' + IS IOCB ACTIVE 38200013 BNE CL145 * NO, 38300013 BAL LR,CLEVT TEST EVENT VARIABLE 38400013 CL145 EQU * 38500013 L RE,BNIO A(NEXT BUBL). 38600013 LR RA,RD A(BUBL TO BE FREED). 38700013 FREEMAIN R,LV=(0),A=(1) $$ FREE BUBL. 38800013 LTR RE,RE + FINISH FREEING BUBL'S. 38900013 BZ CLNTU YES. 39000013 LR RD,RE NO. 39100013 LR R0,RB 39200013 B CL144 39300013 * QISAM. 39400013 CL150 EQU * 39500013 DELETE EP=IHEITDA ** DELETE LOAD MODULE. 39600013 CLNTU EQU * 39700013 LH R0,TLEN 39800013 A R0,SUBPL LENGTH OF FCB AND SUBPOOL NO. 39900013 LR RA,RC A(FCB). 40000013 FREEMAIN R,LV=(0),A=(1) $$ FREE CORE USED FOR FCB. 40100013 TM 0(RF),MEOL + END OF LIST YET. 40200013 BO CLEND 40300013 LA RF,4(RF) BUMP POINTER. 40400013 B CLAG1 40500013 CLEND EQU * 40600013 L RB,OFDR(DR) GET CALLER'S SSA POINTER. 40700013 LR DR,WR USE LW0 FOR SSA. 40800013 LA RE,2 FREE TWO VDA'S. 40900013 CLEN1 EQU * 41000013 L BR,ISAFD A(FREE VDA MODULE). 41100013 BALR LR,BR $$ FREE VDA. 41200013 BCT RE,CLEN1 41300013 LR DR,RB RESTORE SSA POINTER. 41400013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS. 41500013 BR LR X RETURN. 41600013 EJECT 41700013 USING IHEZEVT,RA 41800013 CLEVT EQU * 41900013 L RA,BEVN A(EVENT VARIABLE) 42000013 LTR RA,RA + TEST IF ZERO 42100013 BCR 8,LR * YES, NO EVENT 42200013 TM EVF1,EMAC + IS IT ACTIVE 42300013 BCR 8,LR * NO 42400013 NI EVF1,255-EMAC YES, MAKE IT INACTIVE 42500013 TM EVF2,EMCP + IS IT COMPLETE 42600013 BCR 1,LR * YES 42700013 OI EVF2,EMCP NO, MAKE IT COMPLETE 42800013 LA BR,1 42900013 STH BR,EVST STATUS = 1 (ABNORMAL) 43000013 BR LR GO BACK 43100013 DROP RA 43200013 EJECT 43300013 CLITC DC A(0) ITC PLIST SKELETON. 51000013 DC A(CLRDV) * 51100013 DC A(0) * 51200013 DC A(CLKSV) 51300013 DC A(CLREQ) * 51400013 CLREQ DC X'04080000' REQUEST CODES. 51500013 CLKSV DC A(CLKWD) 51600013 DC H'8,8' 51700013 CLRDV DC A(CLKWD) 51800013 DC A(8) 51900013 CLKWD DC C'99999999' 52000013 SYNADM DC F'1' 52100013 SUBPL DC X'01000000' 52200013 X12X DC H'12' 52300013 X04X DC H'04' 52400013 X80X DC H'80' 52500013 END IHECLSA 52600013 ./ ADD SSI=21400049,NAME=IHECLTA,SOURCE=0 CLT TITLE 'IHECLT CLOSE /00100017 OS/360 PL/I LIBRARY' 00200017 * VERSION FOURTH VERSION OF F-LEVEL PL/1 COMPILER 00300017 * 00400017 * STATUS CHANGE LEVEL - 0 00500017 * 00600017 * SIZE 1984 BYTES 00700017 * 00800017 *A197440,387500,391500,392000 BPC 43435 00802056 *C198000,404000 BPC 43435 00804056 * 00806056 * CHANGE MADE ON RELEASE 20 FOR APAR 31647 00810020 * 111000 00820020 * 197300,* 00830020 * 376000,* 00840020 * 00850020 * APAR 41929 FIXED BY FOLLOWING UPDATE. 00860046 * 00870046 * 412100,412500 00880046 * 00890046 * FUNCTION 00900017 * 1) CHECK STATUS OF FILE (IE.FILE REGISTER). 01000017 * 2) CLOSE FILES 01100017 * 3) ZERO FILE REGISTER (LAST THREE BYTES) 01200017 * 4) FREE THE BUFFER POOL OBTAINED FOR FILE. 01300017 * 5) FREE DYNAMIC CORE OBTAINED FOR FCB. 01400017 * 6) COMPLETE INITIALISATION OF SEQUENTIALLY CREATED 01500017 * REGIONAL DATA SETS BY CALLING IHEITC MODULE. 01600017 * 7) DELETE RECORD I/O MODULES LOADED AT OPEN TIME. 01700017 * 8) DE-CHAIN THE FILES FROM THE OPENED FILE CHAIN. 01800017 * 9) FREE IOCBS THAT WERE OBTAINED BY THE DIRECT ACCESS 01900017 * 10) SET EVENTS COMPLETE AND DEQ EXCLUSIVE BLOCKS 02000017 * 02100017 * ENTRY POINTS 02200017 * IHECLTA - EXPLICIT CLOSE 02300017 * RA= A(PLIST) 02400017 * PLIST = A(CLOSE PLIST) 02500017 * = A(ADCON) 02600017 * CLOSE PLIST = A(DCLCB) * THE NORMAL END 02700017 * A(IDENT SDV) * OF LIST BIT IS 02800017 * A(IDENT DED) * SET IN LAST WORD. 02900017 * IHECLTB - IMPLICIT CLOSE 03000017 * RA = A(PLIST) 03100017 * PLIST = A(WORD CONTAINING NUMBER OF FILES * 4) 03200017 * = A(ADCON LIST) 03300017 * = A(1ST FCB) 03400017 * ... 03500017 * = A(LAST FCB) WITH TOP BIT OF WORD SET 03600017 * 03700017 * 03800017 * INPUT 03900017 * FCB,DCLCB,ADCON LIST(SEE IHEOCL) 04000017 * 04100017 * OUTPUT 04200017 * FILE REGISTER SET TO ZERO. 04300017 * 04400017 * EXTERNAL MODULES 04500017 * LIBRARY0 04600017 * IHESAD/IHETSA - GET VDA 04700017 * IHESAF/IHETSA - FREE VDA 04800017 * CONTROL SYSTEM0 04900017 * CLOSE - CLOSE FILES. 05000017 * FREEPOOL - FREEBUFFER POOLS. 05100017 * FREEMAIN - FREE CORE. 05200017 * DELETE - DELETE RECORD I/O MODULES 05300017 * DEQ - RELEASE EXCLUSIVE RECORD 05400017 * 05500017 * EXITS 05600017 * RETURN VIA LINK REGISTER TO CALLER. 05700017 * 05800017 * TABLES/WORK AREA 05900017 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF 06000017 * FCB,DCLCB,AND FILE REGISTER. 06100017 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE(LWS). 06200017 * 06300017 * ATTRIBUTES READ ONLY AND REENTRANT 06400017 * 06500017 * PRIVATE MACROS 06600017 * IHELIB,IHEZAP 06700017 * 06800017 * ASSEMBLY REQUIREMENTS 06900017 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 07000017 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 07100017 * 07200017 * NOTES 07300017 * SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY MODULE 07400017 * CONVENTIONS AND STANDARDS. 07500017 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 07600017 * UPON A PARTICULAR INTERNAL REPRESENTATION OF THE 07700017 * EXTERNAL CHARACTER SET. 07800017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT000-TSS 07830020 * ----------------------------------------------------CLT000-TSS 07860020 EJECT 07900017 IHECLT CSECT 08000017 IHELIB 08100017 IHEZAP 08200017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT002-TSS 08250001 DCBD DSORG=(QS,IS,MQ) 08300001 * ----------------------------------------------------CLT002-TSS 08350001 IHEXLV 08400017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT003-TSS 08450001 IHEQEVT DXD A 08500017 * ----------------------------------------------------CLT003-TSS 08550001 EJECT 08600017 PARM DSECT 08700017 ODCL DS A A(FILE CONTROL BLOCK (DCLCB)). 08800017 OIDT DS A A(IDENT SDV). 08900017 OEOL DS 0BL1 END OF LIST FLAG. 09000017 ODED DS A A(DED FOR STRING). 09100017 SPACE 09200017 IHEZLW0 DSECT 09300017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT004-TSS 09350001 DS 9D 09400017 * ----------------------------------------------------CLT004-TSS 09450001 PARMP DS A CLOSE PARM LIST ADDRESS. 09500017 VDAAD DS A VDA ADDRESS. 09600017 ITCPL DS 5A ITC PLIST SPACE. 09700017 BRBR DS A 09800017 DEQF DS A 09900017 DEQA DS 2A 10000017 DEQR DS A 10100017 DEQQ DS 2A 10200017 RFRF DS A 10300017 SPACE 2 10400017 TCIT EQU TCBA EXTENDED DCB APE 10500017 RERD EQU X'10' REREAD DISPOSITION. 10600017 LEVE EQU X'30' LEAVE DISPOSITION. 10700017 LEAV EQU X'80' LEAVE OPTION. 10800017 MEOL EQU X'80' END OF LIST. 10900017 VALS EQU X'10' FIXED OR VARIABLE STRING. 11000017 VR17 EQU 5 RELEASE 17 CODE 11100017 * ADDITIONAL EQUATE FOR TTYP IN FILE CONTROL BLOCK 11130020 TMSP EQU B'00001000' SPANNED RECORD I/O 31647 11160020 EJECT 11200017 IHECLT CSECT 11300017 ENTRY IHECLTA,IHECLTB 11400017 SPACE 2 11500017 USING IHEZADC,RI 11600017 USING IHADCB,RE 11700017 USING IHEZAPE,RC 11800017 USING IHEZLW0,DR 11900017 USING PARM,RG 12000017 USING IHEZIOB,RD 12100017 SPACE 12200017 IHECLTA NOPR 0 EXPLICIT CLOSE. 12300017 SPACE 12400017 IHECLTB STM LR,WR,OFLR(DR) IMPLICIT CLOSE 12500017 BALR RJ,0 SET UP BASE REGISTER. 12600017 USING *,RJ 12700017 L RI,4(RA) GET A(ADCON LIST). 12800017 LH WR,IQLW0 GET LWS 0 OFFSET. 12900017 L WR,0(WR,PR) A(LIBWS) IN PWR. 13000017 L RG,0(RA) 13100017 ST DR,OFDR(WR) SET UP SAVE AREA POINTER. 13200017 LR DR,WR * 13300017 STC BR,BRBR SAVE ENTRY POINT FLAG. 13400017 TM BRBR,X'02' TEST ENTRY POINT 13500017 BO CLIP1 BRANCH IF IMPLICIT. 13600017 ST RG,PARMP SAVE P.LIST POINTER. 13700017 SPACE 2 13800017 LA RA,1 13900017 CLTES EQU * 14000017 TM OEOL,MEOL + END OF P.LIST YET. 14100017 BO CLNFS YES,NO OF FILES TO CLOSE FOUND. 14200017 LA RG,12(RG) NO,BUMP PARM LIST POINTER. 14300017 LA RA,1(RA) BUMP NO OF FILES COUNT. 14400017 B CLTES 14500017 SPACE 14600017 CLNFS EQU * 14700017 SLL RA,2 4*N. 14800017 LR RB,RA SAVE NO OF FILES'N'. 14900017 CLP11 EQU * 15000017 LA R0,12(RA) 12+4*N BYTES FOR VDA. 15100017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT005-TSS 15130001 * ----------------------------------------------------CLT005-TSS 15160001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT026-TSS 15180020 L BR,ISADF 15200017 * ----------------------------------------------------CLT026-TSS 15250020 BALR LR,BR $$ GET VDA. 15300017 ST RB,8(RA) SAVE IN VDA. 15400017 LA RF,8(RA) 15500017 ST RF,VDAAD SAVE A(VDA). 15600017 TM BRBR,X'02' TEST ENTRY POINT. 15700017 BO CLIP2 * BRANCH IF IMPLICIT. 15800017 L RG,PARMP GET A(P.LIST). 15900017 EJECT 16000017 CLLP1 EQU * 16100017 LA RF,4(RF) BUMP DAMT P.LIST POINTER. 16200017 CLLP2 EQU * 16300017 L RD,ODCL GET ADDRESS OF DCLCB 16400017 LH RE,0(RD) GET P.R.OFFSET OF FILE. 16500017 ALR RE,PR A(P.R.SLOT). 16600017 L RC,0(RE) A(FCB) 16700017 LA RC,0(RC) LOOSE TOP BYTE 16800017 LTR RC,RC + IS IT ZERO 16900017 BNZ CLGER * NO, 17000017 CLLP3 EQU * 17100017 TM BRBR,X'02' + IMPLICIT CLOSE? 17200017 BO CLIP7 YES. 17300017 TM OEOL,MEOL + END OF LIST YET. 17400017 BO CLTAO YES. 17500017 LA RG,12(RG) NO,BUMP PARM.LIST POINTER. 17600017 B CLLP2 17700017 CLTAO EQU * 17800017 SH RF,X04X 17900017 CLTAI EQU * 18000017 CL RF,VDAAD + ANY FILES LEFT TO BE CLOSED. 18100017 BE CLEND NO. 18200017 B CLSEP YES. 18300017 CLGER EQU * 18400017 TM TFHT,TMCC PREVENT CLOSE FLAG ON? 18500017 BO CL004 18600017 CLGR1 EQU * 18700017 TM BRBR,X'02' + IMPLICIT CLOSE.. 18800017 BO CLIK1 YES. SKIP NEXT TEST. 18900017 TM 0(RE),X'FF' + ERROR DETECTED ON OPEN 19000017 BZ CLGEM * NO, 19100017 CLIK1 EQU * 19200017 OI TFHT,TMET / SET END OF EXTENT FLAG 19300017 CLGEM EQU * 19400017 L RE,TDCB 19500017 LA RE,0(RE) GET A(DCB). 19600017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT010-TSS 19630001 * ----------------------------------------------------CLT010-TSS 19660001 ST RE,0(RF) SET DCB INTO CLOSE P.LIST. 19700017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT006-TSS 19705021 TM DCBRECFM,X'48' + IS IT SPANNED RECORD 31647 19728020 BNO NSPAN * NO 31647 19736020 OI TTYP,TMSP SET BIT IN FCB 31647 19744042 TM TFHT,TMLT PRIOR LOCATE FLAG SET? 43435 19745056 BNO NSPAN NO 43435 19746056 MVC TLRL(2),DCBLRECL SAVE LENGTH OF WORK AREA 43435 19747056 * ----------------------------------------------------CLT006-TSS 19748021 NSPAN CLI TFAC,TMQT + IS IT QTAM ACCESS METHOD 31647 19752020 BE CL004 * YES, 19760001 MVC TFIO(1),DCBKEYLE ***SAVE KEYLE.IN 43535 19800056 * UNAUTHORISED FIELD*** 43435 19840056 TM TFFP,TMHQ + HIDDEN BUFFERS MAYBE REQUIRED? 19900017 BZ CL143 NO. 20000017 L RA,TREC GET ADDRESS OF HIDDEN BUFFER. 20100017 LA RA,0(RA) REMOVE TOP BYTE. 20200017 LTR RA,RA + IS IT ZERO. 20300017 BZ CL143 YES. 20400017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT025-TSS 20404020 L RY,TCBA GET A(D.M. BUFFER). 20408001 SR RZ,RZ 20416001 IC RZ,DCBKEYLE GET DCB KEYLENGTH. 20424001 AR RY,RZ RY = A(DATA IN DM BUFFER) 20432001 LH RZ,DCBBLKSI GET DCB BLOCKSIZE. 20440001 LA R0,256 SET UP COUNTER. 20448001 CLIS1 EQU * 20456001 CR RZ,R0 + MORE THAN 256 BYTES. 20464001 BNH CLIS2 * NO. 20472001 MVC 0(256,RY),0(RA) YES. MOVE 256 BYTES. 20480001 AR RA,R0 BUMP UP A(FROM). 20488001 AR RY,R0 BUMP UP A(TO). 20496001 SR RZ,R0 KNOCK DOWN LENGTH. 20504001 B CLIS1 * GO TO MOVE NEXT BLOCK. 20512001 CLIS2 EQU * 20520001 LTR RZ,RZ + ANY MORE TO MOVE. 20528001 BZ CLIS3 * NO. SKIP OVER. 20536001 BCTR RZ,0 YES. MVC QUIRK. 20544001 EX RZ,CLMOVE MOVE REMAINDER. 20552001 * ----------------------------------------------------CLT025-TSS 20556020 CLIS3 EQU * 20560001 L RA,TREC GET A(DUMMY BUFFER). 20568001 LH R0,DCBBLKSI GET L(DUMMY BUFFER). 20576001 FREEMAIN R,LV=(0),A=(1) FREE! 20600017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT011-TSS 20630001 * ----------------------------------------------------CLT011-TSS 20660001 CL143 EQU * 20700017 CLI TFOG,TMCN + CONSECUTIVE ? 20800017 BNE CLGEN NO. 20900017 L RD,TDCL LOAD A(DCLCB) 20755 20950017 TM 8(RD),NRRD NOREREAD SPECIFIED IN ENV. 21000017 BNZ CL147 YES. 21100017 OI 0(RF),RERD / SET REREAD BITS FOR OPEN DISP. 21200017 CL147 EQU * 21300017 TM 8(RD),LEAV + LEAVE SPECIFIED ON ENV. 21400017 BZ CLGEN NO. 21500017 OI 0(RF),LEVE / YES, SET LEAVE FOR OPEN DISP. 21600017 CLGEN EQU * 21700017 TM TFTY,TMRC + RECORD I/O. 21800017 BO CL004 YES. 21900017 TM TFRC,TMFX + F FORMAT RECORDS. 22000017 BZ CLJ00 BRANCH IF NOT F-FORMAT. 22100017 TM TFMD,TMOP + OUTPUT BUFFER TO BE FILLED. 22200017 BZ CL001 * NO. 22300017 LH RB,TREM YES,GET REM. BYTES IN RECORD. 22400017 LTR RB,RB + ANY REMAINING. 22500017 BZ CL001 NO. 22600017 L RA,TCBA GET A(CURRENT BYTE). 22700017 CL002 EQU * 22800017 MVI 0(RA),C' ' FILL UP WITH BLANKS. 22900017 LA RA,1(RA) BUMP A(CURRENT BYTE). 23000017 BCT RB,CL002 + LAST BYTE. 23100017 B CL001 23200017 EJECT 23300017 CLJ00 EQU * 23400017 L RA,TREC GET A(DUMMY BUFFER). 23500017 LTR RA,RA HAS IT BEEN ALLOCATED? 23600017 BZ CL001 NO. 23700017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT027-TSS 23750020 LH R0,DCBBLKSI YES. GET LENGTH OF BLOCK. 23800017 A R0,SUBPL 23900017 * ----------------------------------------------------CLT027-TSS 23950020 FREEMAIN R,LV=(0),A=(1) FREE CORE GOT FOR DUMMY BUFFER. 24000017 B CL001 24100017 SPACE 24200017 CL004 EQU * 24300017 CL001 EQU * YES. 24400017 TM TFHT,TMCC + PREVENT CLOSE? 24500017 BO CLLP3 YES. 24600017 L RA,TEVT GET EVENT CHAIN. 24700017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT028-TSS 24730020 * ----------------------------------------------------CLT028-TSS 24760020 CLX06 EQU * 24800017 BAL LR,CLEV2 PROCESS EVENT VARIABLE. 24900017 B CLX08 END OF CHAIN. 25000017 L RA,EVFF-EVBG(RA) 25100017 B CLX06 25200017 CLX08 EQU * 25300017 TM BRBR,X'02' IF IMPLICIT 25400017 BO CLNID IGNORE LABELS. 25500017 CLNID EQU * 25600017 MVC DCBSYNAD+1(3),SYNADM+1 ZERO SYNAD ADDRESS IN DCB. 25700017 TM BRBR,X'02' TEST ENTRY POINT. 25800017 BO CLIP3 BRANCH IF IMPLICIT. 25900017 TM OEOL,MEOL + END OF LIST YET. 26000017 BO CLSEP YES. 26100017 LA RG,12(RG) NO,BUMP P.LIST. 26200017 B CLLP1 26300017 CLSEP EQU * 26400017 OI 0(RF),MEOL / SET END OF P.LIST FLAG. 26500017 L RA,VDAAD 26600017 LA RA,4(RA) A(DAMT CLOSE P.LIST). 26700017 LR RF,RA SAVE POINTER. 26800017 L RG,PARMP A(PL/I CLOSE P.LIST). 26900017 CLOSE MF=(E,(1)) $$ CLOSE FILES. 27000017 CLAG1 EQU * 27100017 L RG,PARMP A(CLOSE P.LIST). 27200017 TM BRBR,X'02' IMPLICIT CLOSE? 27300017 BO CLIP4 YES. 27400017 LA RA,12(RG) SAVE A(NEXT ENTRY). 27500017 ST RA,PARMP * 27600017 L RD,0(RG) 27700017 LH RC,0(RD) PR OFFSET OF FILE. 27800017 L RC,0(RC,PR) A(DCBAPE). 27900017 CLC TDCB+1(3),1(RF) DCB'S CHECK OUT. 28000017 BE CLFND YES. 28100017 CLAG2 EQU * 28200017 TM 8(RG),MEOL + END OF PL/1 P.LIST? 28300017 BO CLEND YES. 28400017 B CLAG1 NO. 28500017 CLFND EQU * 28600017 TM TFHT,TMCC PREVENT CLOSE FLAG ON? 28700017 BNZ CLAG2 28800017 LH RE,0(RD) GET OFFSET OF P.R. 28900017 ALR RE,PR 29000017 XC 1(3,RE),1(RE) ZERO FILE REGISTER. 29100017 L LR,IFOPE 29200017 LTR LR,LR + 2ND RELEASE OCL. 29300017 BZ CLFNC NO. 29400017 LA RC,0(RC) A(FCB). 29500017 LH LR,IQFOP OFFSET OF FCB CHAIN ANCHOR. 29600017 L BR,0(LR,PR) A(1ST FCB). 29700017 LA BR,0(BR) A(FCB HIGHER IN CHAIN). 29800017 CLR BR,RC + FCB'S CHECK. 29900017 BNE CLFN2 NO. 30000017 ALR LR,PR YES, A(ANCHOR POINT). 30100017 MVC 1(3,LR),TFOP+1 RESET CHAIN. 30200017 B CLFNC * 30300017 CLFN2 EQU * 30400017 L LR,TFOP-TBEG(BR) GET A(NEXT FCB). 30500017 LA LR,0(LR) * 30600017 CLR LR,RC + FCB'S CHECK. 30700017 BE CLFN3 YES. 30800017 LR BR,LR 30900017 B CLFN2 31000017 CLFN3 EQU * 31100017 MVC TFOP-TBEG+1(3,BR),TFOP+1 RESET FCB CHAIN. 31200017 CLFNC EQU * 31300017 CLI TFAC,TMBS + BSAM ACCESS METHOD USED. 31400017 BL CLFNE NO. 31500017 L RE,0(RF) A( DCB ) 31507001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT024-TSS 31510020 CLI TFAC,TMQT + IS IT QTAM ACCESS METHOD 31514001 BNE CLNQT * NO, 31521001 LH RA,DCBSOWA LENGTH OF BUFFER 31528001 LA RA,12(RA) ADD TERMID LENGTH 31535001 LR R0,RA 31542001 A R0,SUBPL ADD SUBPOOL NUMBER 31549001 L RA,DCBTRMAD A( BUFFER AREA ) 31556001 * 31563001 FREEMAIN R,LV=(0),A=(1) $$ FREE THE AREA 31570001 * 31577001 B CL100 31584001 CLNQT EQU * 31591001 L RD,TLAB GET A(LAST IOCB ALLOCATED). 31600017 LTR RD,RD + DOES IT EXIST. 31700017 BZ CLFNE NO. 31800017 CLFN4 EQU * 31900017 TM BRBR,X'02' + IMPLICIT CLOSE.. 32000017 BO CLFN5 YES. 32100017 TM BERR,BMDB + DUMMY BUFFER LEFT UNFREED. 32200017 BZ CLFN5 NO. 32300017 L RA,BARE YES, FREE IT. 32400017 LH R0,DCBBLKSI * 32500017 A R0,SUBPL * 32600017 FREEMAIN R,LV=(0),A=(1) $$ FREE DUMMY BUFFER. 32700017 CLFN5 EQU * 32800017 BAL LR,CLEVT TEST EVENT VARIABLE 32900017 NOP 0 33000017 L RD,BPIO GET A(PRIOR IOCB). 33100017 LTR RD,RD + END OF CHAIN YET. 33200017 BNZ CLFN4 NO. 33300017 * ----------------------------------------------------CLT024-TSS 33350020 CLFNE EQU * 33400017 L RE,0(RF) A(DCB) 33500017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT009-TSS 33530001 * ----------------------------------------------------CLT009-TSS 33560001 TM DCBBUFCB+3,X'01' + BUFFER POOL ALLOCATED. 33600017 BO CL099 NO. 33700017 LR RA,RE 33800017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT999-TSS 33850020 FREEPOOL (1) $$ FREE BUFFER POOL 33900017 * ----------------------------------------------------CLT999-TSS 33950020 CL099 EQU * 34000017 TM TFDV,TMPA + PAPER TAPE DEVICE. 34100017 BZ CL09A NO. 34200017 CLI TFAC,TMQS + QSAM ACCESS METHOD. 34300017 BE CL09B YES. 34400017 CL09A EQU * 34500017 TM TFTY,TMRC + RECORD I/O. 34600017 BO CL100 YES. 34700017 CL09B EQU * 34800017 B CLNTU 34900017 EJECT 35000017 * DELETE MODULES LOADED AT OPEN TIME. 35100017 SPACE 35200017 CL100 EQU * 35300017 SR RA,RA 35400017 IC RA,TFAC GET ACCESS CODE. 35500017 B *+4(RA) 35600017 B CL120 QSAM. 35700017 B CL130 BDAM. 35800017 B CL140 QISAM 35900017 B CL140 BISAM. 36000017 B CL110 BSAM. 36100017 B CL105 BSAM LOAD 36110001 * B CL102 QTAM 36120001 SPACE 2 36130001 * QTAM 36140001 SPACE 2 36150001 CL102 EQU * 36160001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT021-TSS 36165020 DELETE EP=IHEITPA $$ DELETE QTAM TRANSMITTER 36170001 * ----------------------------------------------------CLT021-TSS 36175020 B CLNTU 36180001 SPACE 36200017 * BSAM LOAD . 36300017 SPACE 36400017 CL105 EQU * 36450001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT013-TSS 36470020 DELETE EP=IHEITCA ** DELETE LOAD MODULE. 36500017 * ----------------------------------------------------CLT013-TSS 36550020 B CLNTU 36600017 SPACE 36700017 * BSAM. 36800017 CL110 EQU * 36900017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT014-TSS 36950020 DELETE EP=IHEITBA ** DELETE LOAD MODULE. 37000017 * ----------------------------------------------------CLT014-TSS 37050020 B CLNTU 37100017 SPACE 37200017 * QSAM. 37300017 SPACE 37400017 CL120 EQU * 37500017 TM TTYP,TMSP + IS IT SPANNED RECORD 31647 37600020 BO CLSP1 37700017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT015-TSS 37750020 DELETE EP=IHEITGA ** DELETE LOAD MODULE. 37800017 * ----------------------------------------------------CLT015-TSS 37850020 B CLNTU 37900017 * 38000017 * SPANNED QSAM 38100017 * 38200017 CLSP1 EQU * 38300017 TM TFLA,TMOP + OUTPUT 38400017 BO CLSP3 * YES 38500017 * SPANNED QSAM INPUT 38600017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT016-TSS 38650020 DELETE EP=IHEITKA ** DELETE LOAD MODULE 38700017 * ----------------------------------------------------CLT016-TSS 38750020 TM TFLC,TMPS PRIOR READ SET FLAG SET? 43435 38760056 BO CL121 YES 43435 38770056 B CLNTU 38800017 * SPANNED QSAM OUTPUT 38900017 CLSP3 EQU * 39000017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT017-TSS 39050020 DELETE EP=IHEITLA ** DELETE LOAD MODULE 39100017 * ----------------------------------------------------CLT017-TSS 39150020 TM TFHT,TMLT PRIOR LOCATE FLAG SET? 43435 39160056 BO CL121 YES 43435 39170056 B CLNTU 39200017 CL121 EQU * 43435 39210056 L RA,TREC LOAD ADDRESS AND LENGTH OF 43435 39220056 LH R0,TLRL PRIOR READ SET/LOCATE AREA 43435 39230056 FREEMAIN R,LV=(0),A=(1) FREE IT 43435 39240056 B CLNTU 43435 39250056 SPACE 39300017 * BDAM. 39400017 SPACE 39500017 CL130 EQU * 39600017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT018-TSS 39650020 DELETE EP=IHEITFA ** DELETE LOAD MODULE. 39700017 * ----------------------------------------------------CLT018-TSS 39750020 B CL142 39800017 * BISAM. 39900017 CL140 EQU * 40000017 NC TPKA(4),TPKA PREVIOUS KEY.. 40100017 BZ CL141 NO. 40200017 SR R0,R0 40300017 IC R0,TFIO GET SAVED KEYLENGTH 43435 40400056 L RA,TPKA A(PREVIOUS KEY) 40500017 FREEMAIN R,LV=(0),A=(1) FREE IT 40600017 CL141 EQU * 40700017 CLI TFAC,TMQI 40800017 BE CL150 BRANCH IF QISAM. 40900017 TM TFRC,TMVB + V FORMAT INDEXED... 40910001 BZ CL148 * NO. 40920001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT022-TSS 40925020 DELETE EP=IHEITMA ›› YES. DELETE LOAD MODULE. 40930001 * ----------------------------------------------------CLT022-TSS 40935020 B CL142 * 40940001 CL148 EQU * 40950001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT019-TSS 40970020 DELETE EP=IHEITEA ** DELETE LOAD MODULE. 41000017 * ----------------------------------------------------CLT019-TSS 41100020 CL142 EQU * 41200017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT008-TSS 41205001 CL149 EQU * 41260001 LH R0,DCBSMSI LENGTH OF INDEXAREA. 41300017 LTR R0,R0 WAS INDEX AREA USED.. 41400017 BZ CL146 NO. 41500017 L RA,DCBMSHI AREA OF INDEXAREA. 41600017 FREEMAIN R,LV=(0),A=(1) FREE IT. 41700017 * ----------------------------------------------------CLT008-TSS 41750001 CL146 EQU * 41800017 L R0,TBBZ GET LENGTH OF BUBL. 41900017 LR RB,R0 SAVE IT. 42000017 L RD,TLAB A(1ST BUBL). 42100017 CL144 EQU * 42200017 CLI BPIO,X'FF' + IS IOCB ACTIVE 42300017 BNE CL145 * NO, 42400017 BAL LR,CLEVT TEST EVENT VARIABLE 42500017 NOP 0 42600017 CL145 EQU * 42700017 L RE,BNIO A(NEXT BUBL). 42800017 LR RA,RD A(BUBL TO BE FREED). 42900017 FREEMAIN R,LV=(0),A=(1) $$ FREE BUBL. 43000017 LTR RE,RE + FINISH FREEING BUBL'S. 43100017 BZ CLNTU YES. 43200017 LR RD,RE NO. 43300017 LR R0,RB 43400017 B CL144 43500017 * QISAM. 43600017 CL150 EQU * 43700017 TM TFRC,TMVB + V FORMAT INDEXED... 43710001 BZ CL151 * NO. 43720001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT023-TSS 43725020 DELETE EP=IHEITNA ›› YES. DELETE LOAD MODULE. 43730001 * ----------------------------------------------------CLT023-TSS 43735020 B CLNTU * 43740001 CL151 EQU * 43750001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT020-TSS 43770020 DELETE EP=IHEITDA ** DELETE LOAD MODULE. 43800017 * ----------------------------------------------------CLT020-TSS 43850020 CLNTU EQU * 43900017 LH R0,TLEN 44200017 A R0,SUBPL LENGTH OF FCB AND SUBPOOL NO. 44300017 LR RA,RC A(FCB). 44400017 CLI IFOPE,VR17 TEST IF RELEASE 17 OR LATER 44500017 BL CLNTV BRANCHIF NOT 44600017 SH RA,X08X BUMP RA BACK 8 BYTES FOR NEW 44700017 AH R0,X08X ADJUST THE LENGTH 44800017 * WORDS ON FRONT OF FCB 44900017 CLNTV EQU * 45000017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT012-TSS 45030020 * ----------------------------------------------------CLT012-TSS 45060020 FREEMAIN R,LV=(0),A=(1) $$ FREE CORE USED FOR FCB. 45100017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT007-TSS 45110001 * ----------------------------------------------------CLT007-TSS 45120001 TM BRBR,X'02' IMPLICIT CLOSE 20759 45130017 BO CLIP5 YES 20759 45160017 TM 0(RF),MEOL + END OF LIST YET. 45200017 BO CLEND 45300017 LA RF,4(RF) BUMP POINTER. 45400017 B CLAG1 45500017 CLEND EQU * 45600017 L BR,ISAFD 45700017 BALR LR,BR $$ FREE VDA. 45800017 L DR,OFDR(DR) RESTORE SSA POINTER. 45900017 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS. 46000017 BR LR X RETURN. 46100017 EJECT 46200017 CLIP1 EQU * 46300017 ST RA,PARMP SAVE A(P.LIST). 46400017 LA RG,8(RA) SAVE ADDRESS OF FIRST FCB. 46500017 L RB,0(RA) GET 4 * FILE COUNT. 46600017 LR RA,RB COPY IT. 46700017 B CLP11 46800017 SPACE 46900017 CLIP2 EQU * 47000017 LA RF,4(RF) BUMP DAMT P.LIST POINTER. 47100017 CLV05 EQU * 47200017 L RC,0(RG) 47300017 LA RC,0(RC) POINT AT AN FCB. 47400017 B CLGER * JOIN CLTA. 47500017 SPACE 47600017 CLIP3 EQU * 47700017 TM 0(RG),X'80' LAST ENTRY? 47800017 BO CLTAI 47900017 LA RG,4(RG) STEP DOWN CLTB CALL. SEQ. 48000017 B CLIP2 48100017 SPACE 48200017 CLIP4 EQU * 48300017 L RC,8(RG) GET A(FCB). 48400017 CLC TDCB+1(3),1(RF) TRY THIS DCB. 48500017 BNE CLIP6 NO. 48600017 TM TFHT,TMCC CLOSE THIS FILE? 48700017 BO CLIP5 NO. 48800017 B CLFNC 48900017 SPACE 49000017 CLIP5 EQU * 49100017 LA RF,4(RF) UPDATE DAMT P.LIST POINTER. 49200017 CLIP6 EQU * 49300017 L RG,PARMP GET POINTER. 49400017 TM 8(RG),X'80' LAST FILE? 49500017 BO CLEND YES. 49600017 LA RG,4(RG) UPDATE CLTB POINTER. 49700017 ST RG,PARMP SAVE IT. 49800017 B CLIP4 49900017 SPACE 50000017 CLIP7 EQU * 50100017 TM 0(RG),X'80' + END OF LIST YET? 50200017 BO CLTAO YES. 50300017 LA RG,4(RG) NEXT FILE. 50400017 B CLV05 50500017 EJECT 50600017 USING IHEZEVT,RA 50700017 CLEVT EQU * 50800017 L RA,BEVN A(EVENT VARIABLE) 50900017 CLEV2 EQU * 51000017 LTR RA,RA + TEST IF ZERO. 51100017 BZ 0(LR) * ZERO RETURN. 51200017 TM EVF1,EMAC + IS IT ACTIVE.. 51300017 BZ 4(LR) * NO. 51400017 TM EVF2,EMCP + IS IT COMPLETE.. 51500017 BO CLEV3 YES. 51600017 OI EVF2,EMCP NO. MAKE IT COMPLETE. 51700017 NC EVST(2),EVST + STATUS = 0.. 51800017 BNZ CLEV3 NO. 51900017 MVC EVST(2),HONE SET STATUS = 1. 52000017 CLEV3 EQU * 52100017 NI EVF1,255-EMAC SET EVENT INACTIVE. 52200017 B 4(LR) RETURN. 52300017 DROP RA 52400017 EJECT 52500017 SYNADM DC F'1' 52600017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*CLT001-TSS 52650001 SUBPL DC X'01000000' 52700017 * ----------------------------------------------------CLT001-TSS 52750001 X12X DC H'12' 52800017 X04X DC H'04' 52900017 X80X DC H'80' 53000017 CLCP1 CLC 0(0,BR),0(LR) 53100017 KEYY EQU X'A8' 53200017 X08X DC H'8' 53300017 HONE DC H'1' 53400017 OFEV DC AL2(BEVN-BBEG) HALF-WORD BOUNDARY. 53500017 BLRC EQU X'10' 53600017 SPAN EQU X'48' SPANNED BITS IN DCB. 53700017 XAL1 DC X'FF000000' 53800017 XALV DC X'FF000100' 53900017 NRRD EQU X'02' 54000017 CLMOVE MVC 0(*-*,RY),0(RA) 54050001 END 54100017 ./ ADD SSI=03011700,SOURCE=1,NAME=IHECNTA CNT TITLE 'IHECNT COUNT AND LINE NUMBER BUILT IN FUNCTIONS /00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0 00100000 * 00120000 * SIZE 72 BYTES. 00140000 * 00160000 * FUNCTION 00180000 * RETURNS THE COUNT OF THE NUMBER OF SCALAR ITEMS 00200000 * TRANSMITTED IN THE LAST I/O OPERATION. 00220000 * RETURNS THE CURRENT LINE NUMBER. 00240000 * IF THE FILE IS NOT OPEN THEN ZERO IS RETURNED 00260000 * IN THE ARGUMENT WORD. 00280000 * 00300000 * ENTRY POINTS 00320000 * IHECNTA- COUNT BUILT IN FUNCTION. 00340000 * RA=A(PARM) 00360000 * WHERE PARM= A(DCLCB) 00380000 * A(FULL WORD ARGUMENT) 00400000 * 00420000 * IHECNTB- LINE NUMBER B.I.F. 00440000 * CF IHECNTA 00460000 * 00480000 * INPUT 00500000 * FCB,DCLCB,FILE REGISTER. 00520000 * 00540000 * OUTPUT 00560000 * UPDATED ARGUMENT WORD. 00580000 * 00600000 * EXTERNAL MODULES 00620000 * N/A 00640000 * 00660000 * EXITS 00680000 * RETURN TO CALLER VIA LINK REGISTER. 00700000 * 00720000 * TABLES/WORK AREA 00740000 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF 00760000 * FCB,DCLCB,FILE REGISTER. 00780000 * 00800000 * ATTRIBUTES READ ONLY AND REENTRANT 00820000 * 00840000 * PRIVATE MACROS 00860000 * IHELIB,IHEZAP,IHESDR 00880000 * 00900000 * ASSEMBLY REQUIREMENTS 00920000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00940000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00960000 * 00980000 * NOTES 01000000 * SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY MODULE 01020000 * CONVENTIONS AND STANDARDS. 01040000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 01060000 * UPON A PARTICULAR INTERNAL REPRESENTATION OF THE 01080000 * EXTERNAL CHARACTER SET. 01100000 EJECT 01120000 IHECNT CSECT 01140000 IHELIB 01160000 IHEZAP 01180000 ENTRY IHECNTA,IHECNTB 01200000 SPACE 01220000 PWR EQU WR 01240000 SPACE 01260000 IHECNT CSECT 01280000 SPACE 01300000 USING IHEZAPE,RA 01320000 SPACE 01340000 IHECNTA EQU * . COUNT ENTRY POINT. 01360000 NOPR 0 01380000 SPACE 01400000 IHECNTB EQU * . LINE NUMBER ENTRY POINT. 01420000 SPACE 01440000 STM LR,PWR,OFLR(DR) SAVE CALLERS REGISTERS. 01460000 BALR PWR-1,0 01480000 SPACE 01500000 USING *,PWR-1 01520000 SPACE 01540000 LR RG,DR SAVE OLD SSA POINTER. 01560000 IHESDR LW0 ESTABLISH SSA. 01580000 SR R0,R0 ZERO COUNT LINE NUMBER FIELD. 01600000 L RB,4(RA) GET A(ARGUMENT SDV). 01620000 L RA,0(RA) GET A(DCLCB). 01640000 LH RA,0(RA) GET FILE REGISTER OFFSET. 01660000 L RA,0(RA,PR) GET ADDRESS OF FCB. 01680000 LTR RA,RA + FILE OPEN. 01700000 BC 12,CNTER NO. 01720000 LH R0,TLNN GET LINE NUMBER. 01740000 TM OFBR+3(RG),X'02' + COUNT OR LINE NUMBER. 01760000 BO CNTER LINE NUMBER. 01780000 L R0,TCNT GET COUNT OF ITEMS TRANSMITTED. 01800000 CNTER EQU * 01820000 ST R0,0(RB) PLACE IN ARGUMENT VARIABLE. 01840000 LR DR,RG 01860000 LM LR,PWR,OFLR(DR) RESTORE CALLERS REGISTERS. 01880000 BR LR X RETURN TO CALLER. 01900000 END 01920000 ./ ADD SSI=03011700,SOURCE=1,NAME=IHECSC0 CSC TITLE ' IHECSC CHARACTER STRING COMPARE *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 200 BYTES 00140000 * 00160000 * FUNCTION TO COMPARE TWO CHARACTER STRINGS AND RETURN THE 00180000 * RESULTING CONDITION CODE. IF THE STRINGS ARE OF UNEQUAL 00200000 * LENGTHS, THE SHORTER IS TREATED AS THOUGH EXTENDED WITH 00220000 * BLANKS TO THE LENGTH OF THE LONGER. 00240000 * THE TWO STRINGS ARE COMPARED USING THE CLC INSTRUCTION. 00260000 * IF THE STRINGS ARE OF DIFFERENT LENGTHS AND ARE 00280000 * IDENTICAL UP TO THE LENGTH OF THE SHORTER, THE 00300000 * REMAINDER OF THE LONGER IS COMPARED WITH BLANKS 00320000 * 00340000 * ENTRY POINTS 00360000 * IHECSC0 00380000 * RA = A(SDV OF FIRST OPERAND) 00400000 * RB = A(SDV OF SECOND OPERAND) 00420000 * RC = A(TARGET) 00440000 * 00460000 * INPUT N/A 00480000 * 00500000 * OUTPUT N/A 00520000 * 00540000 * EXTERNAL MODULES 00560000 * N/A 00580000 * 00600000 * EXITS NORMAL 00620000 * RETURN TO CALLER VIA LINK REGISTER. 00640000 * 00660000 * TABLES/WORK-AREA 00680000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00700000 * 00720000 * ATTRIBUTES READ-ONLY AND REENTRANT. 00740000 * 00760000 * PRIVATE MACROS 00780000 * IHELIB,IHESDR 00800000 * 00820000 * ASSEMBLY REQUIREMENTS 00840000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00860000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00880000 * 00900000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 00920000 * STANDARDS. 00940000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 00960000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 00980000 * EXTERNAL CHARACTER SET. 01000000 EJECT 01020000 IHECSC CSECT 01040000 SPACE 2 01060000 IHELIB 01080000 SPACE 01100000 * PRIVATE REGISTER ASSIGNMENTS. 01120000 SPACE 01140000 IND EQU R0 01160000 RS1 EQU RA 01180000 RS2 EQU RB 01200000 RT1 EQU RC 01220000 RE1 EQU RD MUST BE 01240000 RO1 EQU RE EVEN-ODD PAIR. 01260000 LNK EQU LR 01280000 BAS EQU BR 01300000 SPACE 01320000 * PRIVATE OFFSETS. 01340000 SPACE 01360000 LFLD EQU 6 01380000 EJECT 01400000 IHECSC CSECT 01420000 SPACE 01440000 ENTRY IHECSC0 01460000 SPACE 2 01480000 USING *,BAS 01500000 IHECSC0 STM LR,RX,OFLR(DR) 01520000 IHESDR LW0,RD 01540000 LH IND,LFLD(RS1) FIND WHICH STRING IS SHORTER. 01560000 LH RE1,LFLD(RS2) SET THE LENGTH OF THIS STRING 01580000 SR IND,RE1 IN RE1 FOR COMPARISON.SET IND 01600000 BC 10,CC010 MINUS,ZERO OR PLUS ACCORDING 01620000 AR RE1,IND AS FIRST STRING IS SHORTER 01640000 * THAN,THE SAME LENGTH AS OR 01660000 * LONGER THAN THE SECOND STRING 01680000 CC010 L RS1,0(RS1) 01700000 L RS2,0(RS2) 01720000 SH RE1,CCX01+2 SUBTRACT 1 FROM LENGTH. 01740000 BC 4,CC020 BRANCH IF LENGTH WAS ZERO 01760000 SRDL RE1,8 SET UP RE1 FOR NUMBER OF TIMES 01780000 SRL RO1,24 THROUGH COMPARE LOOP, RO1 FOR 01800000 CCX01 LA RE1,1(RE1,0) LENGTH OF FIRST COMPARE. 01820000 SPACE 01840000 * * COMPARE LOOP * 01860000 SPACE 01880000 CCCLL EX RO1,CCCLI COMPARE. 01900000 BC 6,CC070 RETURN RESULT IF UNEQUAL. 01920000 LA RS1,1(RO1,RS1) ADD LENGTH COMPARED TO SOURCE 01940000 LA RS2,1(RO1,RS2) ADDRESSES. 01960000 LA RO1,255 SET RO1 TO 255 AFTER 1ST COMP. 01980000 BCT RE1,CCCLL LOOP IF MORE TO BE COMPARED 02000000 SPACE 02020000 CC020 LTR IND,IND TEST IND. IF ZERO,STRINGS ARE SAME 02040000 BC 8,CC070 LENGTH AND C.C. 0 IS RETURNED. 02060000 BC 2,CC030 IF PLUS, STRING 1 IS LONGER, 02080000 LR RS1,RS2 OTHERWISE POINT RS1 AT 2ND STRING. 02100000 CC030 LPR RE1,IND LOAD RE1 WITH LENGTH TO COMPARE. 02120000 CLI 0(RS1),C' ' COMPARE FIRST BYTE WITH BLANK 02140000 BC 4,CCBLH IF NOT EQUAL, BRANCH 02160000 BC 2,CCBLL TO SET C.C. CORRECTLY. 02180000 BCT RE1,CC040 BRANCH IF MORE THAN A BYTE. 02200000 BC 15,CC070 OTHERWISE RETURN C.C. 0. 02220000 SPACE 02240000 CC040 BCTR RE1,0 SUBTRACT 1 FROM LENGTH FOR COMPARE. 02260000 SRDL RE1,8 SET UP RE1 FOR NUMBER OF TIMES 02280000 SRL RO1,24 THROUGH COMPARE LOOP, RO1 FOR 02300000 LA RE1,1(0,RE1) LENGTH OF FIRST COMPARE 02320000 SPACE 02340000 CC060 EX RO1,CCCLB COMPARE FIELD WITH BLANKS 02360000 BC 4,CCBLH IF NOT EQUAL, BRANCH 02380000 BC 2,CCBLL TO SET C.C. CORRECTLY. 02400000 LA RS1,1(RO1,RS1) ADD LENGTH COMPARED TO SOURCE ADDR. 02420000 LA RO1,255 SET RO1 TO 255 AFTER 1ST COMPARE. 02440000 BCT RE1,CC060 LOOP IF MORE TO BE COMPARED. 02460000 * OTHERWISE RETURN C.C. 0. 02480000 SPACE 02500000 CC070 BALR RA,0 OBTAIN CONDITION CODE AND PROGRAM 02520000 ST RA,0(RT1) MASK AND STORE IN BITS 2-7 OF 02540000 L DR,OFDR(DR) TARGET FIELD. 02560000 LM RB,RE,OFRB(DR) 02580000 MVI OFLR(DR),X'FF' 02600000 BCR 15,LNK 02620000 SPACE 02640000 CCBLH LCR IND,IND RETURN C.C. 1 IF 1ST STRING LONGER, 02660000 BC 15,CC070 C.C. 2 IF 2ND STRING LONGER. 02680000 SPACE 02700000 CCBLL LTR IND,IND RETURN C.C. 1 IF 2ND STRING LONGER, 02720000 BC 15,CC070 C.C. 2 IF 1ST STRING LONGER. 02740000 SPACE 2 02760000 * EXECUTED INSTRUCTIONS. 02780000 SPACE 02800000 CCCLB CLC 1(1,RS1),0(RS1) EXECUTED BLANK COMPARE INSTRUCTION 02820000 CCCLI CLC 0(1,RS1),0(RS2) EXECUTED COMPARE INSTRUCTION 02840000 SPACE 2 02860000 END 02880000 ./ ADD SSI=04012041,SOURCE=1,NAME=IHECSI0 CSI TITLE ' IHECSI CHARACTER STRING INDEX *00600013 OS/360 PL/I LIBRARY' 01200013 * VERSION THIRD VERSION OF F-LEVEL PL/1 COMPILER 01800013 * 02400013 * STATUS CHANGE LEVEL - 0. 03000013 * 03600013 * SIZE 168 BYTES 04200013 * 04800013 * FUNCTION TO COMPARE TWO CHARACTER STRINGS TO SEE IF THE SECOND IS 05400013 * IDENTICAL TO A SUBSTRING OF THE FIRST, AND IF SO, TO 06000013 * PRODUCE A BINARY INTEGER (THE INDEX) WHICH INDICATES THE 06600013 * FIRST CHARACTER IN THE FIRST STRING AT WHICH SUCH A 07200013 * SUBSTRING OCCURS. IF NO SUCH SUBSTRING IS FOUND, OR IF 07800013 * EITHER STRING IS NULL, THE FUNCTION VALUE RETURNED IS 08400013 * ZERO. 09000013 * USING THE CLC INSTRUCTION, THE FIRST CHARACTER OF THE 09600013 * SECOND STRING IS COMPARED WITH THE CHARACTERS OF THE 10200013 * FIRST AND IF EQUALITY IS FOUND THE WHOLE OF THE SECOND 10800013 * STRING IS COMPARED WITH THE PART OF THE FIRST STRING 11400013 * WHERE EQUALITY WAS FOUND. THIS IS CONTINUED UNTIL THE 12000013 * POINT REQUIRED IS LOCATED. THE INDEX IS STORED IN THE 12600013 * TARGET FIELD PROVIDED. 13200013 * 13800013 * ENTRY POINTS 14400013 * IHECSI0 15000013 * RA = A(PLIST) 15600013 * PLIST = A(SDV OF FIRST SOURCE STRING) 16200013 * A(SDV OF SECOND SOURCE STRING) 16800013 * A(TARGET FIELD) 17400013 * 18000013 * INPUT N/A 18600013 * 19200013 * OUTPUT N/A 19800013 * 20400013 * EXTERNAL MODULES 21000013 * N/A 21600013 * 22200013 * EXITS NORMAL 22800013 * RETURN TO CALLER VIA LINK REGISTER. 23400013 * 24000013 * TABLES/WORK-AREA 24600013 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 25200013 * 25800013 * ATTRIBUTES READ-ONLY AND REENTRANT. 26400013 * 27000013 * PRIVATE MACROS 27600013 * IHELIB,IHESDR 28200013 * 28800013 * ASSEMBLY REQUIREMENTS 29400013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 30000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 30600013 * 31200013 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 31800013 * STANDARDS. 32400013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 33000013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 33600013 * EXTERNAL CHARACTER SET. 34200013 EJECT 34800013 IHECSI CSECT 35400013 SPACE 2 36000013 IHELIB 36600013 SPACE 37200013 * PRIVATE REGISTER ASSIGNMENTS. 37800013 SPACE 38400013 WR3 EQU R0 39000013 RS1 EQU RA 39600013 RS2 EQU RB 40200013 RT1 EQU RC 40800013 RE1 EQU RD MUST BE 41400013 RO1 EQU RE EVEN-ODD PAIR. 42000013 WR1 EQU RF 42600013 WR2 EQU RG 43200013 RA1 EQU RH 43800013 RL1 EQU RI 44400013 ONE EQU RJ 45000013 AD1 EQU WR 45600013 AD2 EQU LR 46200013 LNK EQU LR 46800013 BAS EQU BR 47400013 SPACE 48000013 * PRIVATE OFFSET. 48600013 SPACE 49200013 LFLD EQU 6 49800013 EJECT 50400013 IHECSI CSECT 51000013 SPACE 51600013 ENTRY IHECSI0 52200013 SPACE 2 52800013 USING *,BAS 53400013 IHECSI0 STM LR,RX,OFLR(DR) 54000013 IHESDR LW0,RB 54600013 LA ONE,1 SET CONSTANT 1 IN REGISTER 55200013 LM RS1,RT1,0(RS1) LOAD RS1,RS2,RT1 FROM PARAMETER LIST 55800013 LH RL1,LFLD(0,RS1) SET RL1 TO DIFFERENCE BETWEEN 56400013 SH RL1,LFLD(0,RS2) INDEXED AND INDEXING STRING LENGTH 57000013 BC 4,CIZIN BRANCH IF INDEXING STRING IS LONGER. 57600013 L RA1,0(0,RS1) LOAD RA1 WITH ADDR OF INDEXED STRING 58200013 AR RL1,ONE ADD 1 TO RL1 FOR BCT INSTRUCTION 58800013 LH RE1,LFLD(0,RS2) LOAD RE1 WITH LENGTH OF INDEXING STR 59400013 L RS2,0(0,RS2) LOAD RS2 WITH ADDR OF INDEXINGSTRING 60000013 SR RE1,ONE SUBTRACT ONE FROM LENGTH. 60600013 BC 4,CIZIN BRANCH IF LENGTH WAS ZERO 61200013 SRDL RE1,8 SET UP RE1 FOR NUMBER OF SECTIONS 61800013 SRL RO1,24 FOR COMPARISON,RO1 FOR 62400013 AR RE1,ONE LENGTH OF FIRST COMPARE. 63000013 LA AD1,CILP1 POINT AD1 AT CILP1 FOR BCTR 63600013 LA AD2,CI010 POINT AD2 AT CI010 FOR BCR 64200013 SPACE 64800013 CILP1 CLC 0(1,RA1),0(RS2) COMPARE ONE CHARACTER OF INDEXED 65400013 * STRING WITH FIRST CHARACTER OF 66000013 * INDEXING STRING 66600013 BCR 7,AD2 BRANCH IF NOT EQUAL 67200013 EX RO1,CILP1 IF EQUAL, COMPARE MORE CHARACTERS 67800013 BCR 7,AD2 BRANCH IF NOT EQUAL. 68400013 BCT RE1,CI020 FIRST SECTION EQUAL.BRANCH TO TEST 69000013 * SUBSEQUENT SECTIONS. 69600013 BC 15,CIPIN 70200013 SPACE 70800013 CIX01 AR RE1,ONE 71400013 CI010 AR RA1,ONE ADD 1 TO INDEXED STRING ADDRESS 72000013 BCTR RL1,AD1 LOOP IF RL1 IS STILL NOT ZERO 72600013 * OTHERWISE INDEXING STRING HAS JUST 73200013 * BEEN UNSUCCESSFULLY TESTED AGAINST 73800013 * LAST AVAILABLE FIELD OF INDEXED 74400013 * AND ZERO MUST BE RETURNED. 75000013 CIZIN SR RA1,RA1 RETURN ZERO IN CALLERS 75600013 BC 15,CI030 TARGET AREA. 76200013 SPACE 76800013 CI020 LA WR1,1(RO1,RA1) LOAD TEMPORARY REGISTERS WITH ADDR. 77400013 LA WR2,1(RO1,RS2) OF NEXT SECTIONS OF FIELDS AND 78000013 LR WR3,RE1 NUMBER OF SECTIONS REMAINING. 78600013 CILP2 CLC 0(256,WR1),0(WR2) COMPARE. 79200013 BC 7,CIX01 BRANCH IF UNEQUAL TO CONTINUE INDEX. 79800013 LA WR1,256(0,WR1) SECTION EQUAL. LOAD ADDRESSES OF 80400013 LA WR2,256(0,WR2) NEXT 256-BYTE SECTION 81000013 BCT WR3,CILP2 LOOP IF MORE SECTIONS 81600013 SPACE 82200013 CIPIN AR RA1,ONE OTHERWISE CALCULATE INDEX VALUE 82800013 S RA1,0(0,RS1) AND RETURN IT 83400013 CI030 ST RA1,0(0,RT1) IN CALLER'S TARGET AREA. 84000013 L DR,OFDR(DR) 84600013 LM LR,RX,OFLR(DR) RESTORE USER'S REGISTERS. 85200013 MVI OFLR(DR),X'FF' 85800013 BCR 15,LNK RETURN TO CALLER 86400013 SPACE 4 87000013 END 87600013 ./ ADD SSI=04012041,SOURCE=1,NAME=IHECSKK CSK TITLE ' IHECSK CHARACTER STRING CONCATENATE, REPEAT *00400013 OS/360 PL/I LIBRARY' 00800013 * VERSION THIRD VERSION OF F-LEVEL PL/1 COMPILER 01200013 * 01600013 * STATUS CHANGE LEVEL - 0. 02000013 * 02400013 * SIZE 320 BYTES 02800013 * 03200013 * FUNCTION IHECSKK - TO CONCATENATE TWO CHARACTER STRINGS INTO A 03600013 * TARGET FIELD. 04000013 * IHECSKR - TO CONCATENATE N+1 INSTANCES OF A SINGLE 04400013 * SOURCE FIELD INTO A TARGET AREA. 04800013 * THE CURRENT LENGTH OF THE TARGET FIELD IS SET TO THE 05200013 * SMALLER OF TWO VALUES - THE SUM OF THE CURRENT LENGTHS 05600013 * OF THE SOURCE FIELDS, AND THE MAXIMUM LENGTH OF THE 06000013 * TARGET FIELD. THE SOURCE FIELDS ARE MOVED INTO THE 06400013 * TARGET FIELD BY MEANS OF MVC INSTRUCTIONS. CHARACTERS 06800013 * BEYOND THE RANGE OF THE TARGET CURRENT LENGTH REMAIN 07200013 * UNALTERED. 07600013 * 08000013 * ENTRY POINTS 08400013 * IHECSKK - CONCATENATE 08800013 * RA = A(SDV OF FIRST OPERAND) 09200013 * RB = A(SDV OF SECOND OPERAND) 09600013 * RC = A(SDV OF TARGET FIELD) 10000013 * IHECSKR - REPEAT 10400013 * RA = A(SDV OF STRING) 10800013 * RB = A(N) 11200013 * RC = A(SDV OF TARGET FIELD) 11600013 * 12000013 * INPUT N/A 12400013 * 12800013 * OUTPUT N/A 13200013 * 13600013 * EXTERNAL MODULES 14000013 * N/A 14400013 * 14800013 * EXITS NORMAL 15200013 * RETURN TO CALLER VIA LINK REGISTER. 15600013 * 16000013 * TABLES/WORK-AREA 16400013 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 16800013 * 17200013 * ATTRIBUTES READ-ONLY AND REENTRANT. 17600013 * 18000013 * PRIVATE MACROS 18400013 * IHELIB,IHESDR 18800013 * 19200013 * ASSEMBLY REQUIREMENTS 19600013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 20000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 20400013 * 20800013 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 21200013 * STANDARDS. 21600013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 22000013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 22400013 * EXTERNAL CHARACTER SET. 22800013 EJECT 23200013 IHECSK CSECT 23600013 SPACE 2 24000013 IHELIB 24400013 SPACE 24800013 * PRIVATE REGISTER ASSIGNMENTS. 25200013 SPACE 25600013 RP1 EQU R0 26000013 RS1 EQU RA 26400013 RS2 EQU RB 26800013 RT1 EQU RC 27200013 REP EQU RD MUST BE EVEN 27600013 RE1 EQU RF MUST BE 28000013 RO1 EQU RG EVEN-ODD PAIR 28400013 RT2 EQU RH 28800013 CON EQU RI 29200013 LNK EQU RJ 29600013 BAS EQU BR 30000013 SPACE 30400013 * PRIVATE OFFSETS. 30800013 SPACE 31200013 MFLD EQU 4 31600013 LFLD EQU 6 32000013 EJECT 32400013 IHECSK CSECT 32800013 SPACE 33200013 ENTRY IHECSKK,IHECSKR 33600013 SPACE 2 34000013 * *********************** 34400013 * * REPEAT ENTRY * 34800013 * *********************** 35200013 SPACE 35600013 USING *,BAS 36000013 IHECSKR STM LR,RX,OFLR(DR) 36400013 IHESDR LW0,RD 36800013 L REP,0(RS2) GET NUMBER OF REPETITIONS. 37200013 CH REP,X32K IF VERY LARGE, 37600013 BH CK000 DON'T ADD 1, OTHERWISE 38000013 AH REP,H001 INCR BY 1 FOR THE ALGORITHM. 38400013 BC 2,CK000 DON'T BRANCH IF REP WAS LT 0, 38800013 LA REP,1 AND SET REP TO 1. 39200013 CK000 LR RS2,RS1 RS1,RS2 POINT TO SOURCE SDV. 39600013 BAL BAS,CK010 MODIFY BASE REGISTER 40000013 SPACE 2 40400013 * *********************** 40800013 * * CONCATENATE ENTRY * 41200013 * *********************** 41600013 SPACE 42000013 USING *,BAS 42400013 IHECSKK STM LR,RX,OFLR(DR) 42800013 IHESDR LW0,RD 43200013 CKH02 LA REP,2 SET NUMBER OF REPETITIONS TO 2 43600013 CR RS1,RT1 TEST FOR FIRST SOURCE SDV = 44000013 BE CK025 TARGET SDV AND BRANCH IF SO 44400013 SPACE 44800013 * MAIN ROUTINE 45200013 SPACE 45600013 CK010 L RT2,0(RT1) LOAD TARGET ADDRESS 46000013 LH RE1,LFLD(RS1) CHECK IF FIRST STRING CURRENT 46400013 CH RE1,MFLD(RT1) LENGTH EXCEEDS TARGET MAXIMUM 46800013 BC 12,CK020 BRANCH IF NOT. 47200013 CKH01 LA REP,1 YES, SET REP TO 1, USE TARGET 47600013 CKH04 LH RE1,MFLD(RT1) MAX. AS SOURCE CURRENT LENGTH 48000013 CK020 STH RE1,LFLD(RT1) STORE LENGTH TO BE MOVED IN 48400013 * TARGET SDV. 48800013 LR CON,RS2 CON POINTS AT 2ND SOURCE SDV 49200013 L RS1,0(RS1) LOAD SOURCE STRING ADDRESS 49600013 BAL LNK,CKMVC MOVE FIRST SOURCE TO TARGET 50000013 CH REP,H002 TEST NUMBER OF REPETITIONS 50400013 BL FINIS TERMINATE IF REP = 1 50800013 BE ONEMR IF REP = 2, DO ONE MORE MOVE 51200013 CH REP,H004 IF REP GT 3, BRANCH TO USE 51600013 BNL USELP LOOP 52000013 BAL LNK,MOVIT PERFORM 1 OR 2 MORE SOURCE 52400013 ONEMR BAL LNK,MOVIT MOVES ACCORDING AS REP=2 OR 3 52800013 FINIS L DR,OFDR(DR) 53200013 LM RB,RJ,OFRB(DR) RESTORE REGISTERS 53600013 MVI OFLR(DR),X'FF' 54000013 BR LR RETURN TO CALLER 54400013 SPACE 54800013 USELP LR RP1,REP SET RP1 FOR COMPARISON 55200013 SLOOP SRDL REP,1 SHIFT ALL BITS FROM 55600013 LTR REP,REP REP SO THEY ARE LEFT ALIGNED 56000013 BNZ SLOOP IN REP+1 56400013 SLDL REP,1 56800013 POOLS LR CON,RT1 SET CON TO TARGET SDV 57200013 BAL LNK,MOVIT CONCATENATE TARGET WITH ITSELF 57600013 LTR REP+1,REP+1 TEST HIGH ORDER BIT OF REP+1 58000013 BNM CMPRE 58400013 LR CON,RS2 IF BIT WAS 1, THEN CONCATENATE 58800013 BAL LNK,MOVIT TARGET FIELD WITH SOURCE 59200013 CMPRE SLDL REP,1 59600013 CR REP,RP1 TEST WHETHER ALL BITS OF REP 60000013 BNE POOLS HAVE BEEN USED AND LOOP IF NOT 60400013 B FINIS ELSE BRANCH TO FINISH 60800013 SPACE 61200013 CK025 LA LNK,FINIS IF FIRST SOURCE = TARGET, SET 61600013 L RT2,0(RT1) LNK TO FINIS 62000013 AH RT2,LFLD(RS1) AND POINT RT2 62400013 * AT FIRST BYTE AFTER END OF 62800013 * FIRST SOURCE STRING 63200013 LR CON,RS2 63600013 SPACE 64000013 MOVIT LH RE1,LFLD(CON) CHECK IF SOURCE CURRENT 64400013 LH RO1,MFLD(RT1) LENGTH WILL FIT INTO 64800013 SH RO1,LFLD(RT1) REMAINING TARGET SPACE 65200013 CR RE1,RO1 65600013 BNH CK040 BRANCH IF ROOM 66000013 LA LNK,FINIS NO, SET LNK TO FINISH AND 66400013 * USE ROOM LEFT 66800013 LR RE1,RO1 AS SOURCE CURRENT LENGTH 67200013 CK040 LH RO1,LFLD(RT1) ADD THE CALCULATED SOURCE 67600013 AR RO1,RE1 CURRENT LENGTH INTO THE 68000013 STH RO1,LFLD(RT1) TARGET SDV CURR. LENGTH SLOT. 68400013 L RS1,0(CON) LOAD ADDR OF STRING FOR MOVE 68800013 SPACE 69200013 * MOVE ROUTINE 69600013 SPACE 70000013 CKMVC SH RE1,H001 SUBTRACT 1 FROM LENGTH. THIS 70400013 * CORRECTS FOR THE MVC IN THE 70800013 * FIRST TIME THROUGH THE LOOP. 71200013 BCR 4,LNK RETURN IF LENGTH WAS ZERO 71600013 CH RE1,H255 BRANCH IF STRING LENGTH 72000013 BH LARGE GREATER THAN 256 TO LOOP 72400013 EX RE1,CKMVI ELSE MOVE SOURCE TO TARGET 72800013 LA RT2,1(RE1,RT2) ADD LENGTH MOVED TO TAR ADDR. 73200013 BR LNK 73600013 SPACE 74000013 LARGE SRDL RE1,8 RE1 SET UP FOR THE NO. OF LOOPS 74400013 SRL RO1,24 RO1 FOR THE NO. OF CHARACTERS 74800013 LA RE1,1(RE1) MOVED IN FIRST LOOP MINUS 1 75200013 SPACE 2 75600013 * MOVE LOOP 76000013 SPACE 76400013 CKMVL EX RO1,CKMVI EXECUTE MOVE. RO1 GIVES LENGTH 76800013 LA RT2,1(RO1,RT2) ADD LENGTH MOVED TO SOURCE AND 77200013 LA RS1,1(RO1,RS1) TARGET ADDRESSES 77600013 CK255 LA RO1,255 SET RO1 TO 255 AFTER FIRST MOVE 78000013 BCT RE1,CKMVL LOOP IF MORE 256 BYTE SEGMENTS 78400013 SPACE 78800013 BR LNK 79200013 SPACE 79600013 * EXECUTED INSTRUCTIONS. 80000013 SPACE 80400013 CKMVI MVC 0(1,RT2),0(RS1) 80800013 SPACE 81200013 * CONSTANTS 81600013 SPACE 82000013 H001 EQU CKH01+2 82400013 H002 EQU CKH02+2 82800013 H004 EQU CKH04+2 83200013 H255 EQU CK255+2 83600013 X32K DC X'7FFF' 84000013 SPACE 2 84400013 END 84800013 ./ ADD SSI=03011700,SOURCE=1,NAME=IHECSMF CSM TITLE ' IHECSM CHARACTER STRING ASSIGN, FILL, HIGH, LOW *00020000 OS/360 PL/I LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0. 00100000 * 00120000 * SIZE 280 BYTES 00140000 * 00160000 * FUNCTION IHECSMF - TO ASSIGN A CHARACTER STRING TO A FIXED-LENGTH 00180000 * TARGET, FILLING OUT WITH BLANKS IF NECESSARY TO THE 00200000 * FULL TARGET LENGTH. 00220000 * THE MVC INSTRUCTION IS USED, IN A LOOP IF NECESSARY, 00240000 * AND PROPAGATES BLANKS BY MVI AND MVC INSTRUCTIONS AS 00260000 * REQUIRED. THE CURRENT LENGTH OF THE TARGET IS SET 00280000 * EQUAL TO ITS MAXIMUM LENGTH. 00300000 * IHECSMV - TO ASSIGN A CHARACTER STRING TO A VARIABLE 00320000 * LENGTH TARGET. 00340000 * THE STRING IS MOVED AS IN IHECSMF BUT WITHOUT BLANK 00360000 * FILLING. THE CURRENT LENGTH OF THE TARGET IS SET 00380000 * APPROPRIATELY. 00400000 * IHECSMB - TO FILL OUT THE TARGET FIELD FROM ITS CURRENT 00420000 * LENGTH TO ITS MAXIMUM LENGTH WITH BLANKS. 00440000 * BLANKS ARE PROPAGATED AND THE CURRENT LENGTH OF THE 00460000 * TARGET IS SET EQUAL TO ITS MAXIMUM LENGTH. 00480000 * IHECSMH - TO FILL A TARGET FIELD TO ITS CURRENT LENGTH 00500000 * WITH THE CHARACTER '11111111'B. 00520000 * IHECSML - TO FILL A TARGET FIELD TO ITS CURRENT LENGTH 00540000 * WITH THE CHARACTER '00000000'B. 00560000 * BOTH IHECSMH AND IHECSML USE PART OF THE BLANK FILL 00580000 * ROUTINE TO PROPAGATE THE HIGHEST OR LOWEST CHARACTER IN 00600000 * THE COLLATING SEQUENCE UP TO THE CURRENT LENGTH OF THE 00620000 * TARGET. THE TARGET SDV IS LEFT UNCHANGED. 00640000 * 00660000 * ENTRY POINTS 00680000 * IHECSMF - FIXED LENGTH ASSIGN 00700000 * RA = A(SDV OF SOURCE STRING) 00720000 * RB = A(SDV OF TARGET FIELD) 00740000 * IHECSMV - VARIABLE LENGTH ASSIGN 00760000 * LINKAGE AS FOR IHECSMF 00780000 * IHECSMB - BLANK FILL 00800000 * RA = A(SDV OF STRING) 00820000 * IHECSMH - HIGH 00840000 * RA = A(SDV OF STRING) 00860000 * IHECSML - LOW 00880000 * RA = A(SDV OF STRING) 00900000 * 00920000 * INPUT N/A 00940000 * 00960000 * OUTPUT N/A 00980000 * 01000000 * EXTERNAL MODULES 01020000 * N/A 01040000 * 01060000 * EXITS NORMAL 01080000 * RETURN TO CALLER VIA LINK REGISTER. 01100000 * 01120000 * TABLES/WORK-AREA 01140000 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 01160000 * 01180000 * ATTRIBUTES READ-ONLY AND REENTRANT. 01200000 * 01220000 * PRIVATE MACROS 01240000 * IHELIB,IHESDR 01260000 * 01280000 * ASSEMBLY REQUIREMENTS 01300000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 01320000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 01340000 * 01360000 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 01380000 * STANDARDS. 01400000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01420000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01440000 * EXTERNAL CHARACTER SET. 01460000 EJECT 01480000 IHECSM CSECT 01500000 SPACE 2 01520000 IHELIB 01540000 SPACE 01560000 * PRIVATE REGISTER ASSIGNMENTS. 01580000 SPACE 01600000 CHR EQU R0 01620000 RS1 EQU RA 01640000 RT1 EQU RB 01660000 RT2 EQU RC 01680000 RE1 EQU RD MUST BE 01700000 RO1 EQU RE EVEN-ODD PAIR 01720000 LNK EQU LR 01740000 BAS EQU BR 01760000 SPACE 01780000 * PRIVATE OFFSETS. 01800000 SPACE 01820000 MFLD EQU 4 01840000 LFLD EQU 6 01860000 EJECT 01880000 IHECSM CSECT 01900000 SPACE 01920000 ENTRY IHECSMH 01940000 ENTRY IHECSML 01960000 ENTRY IHECSMF 01980000 ENTRY IHECSMV 02000000 ENTRY IHECSMB 02020000 SPACE 2 02040000 * *********************** 02060000 * * HIGH ENTRY * 02080000 * *********************** 02100000 SPACE 02120000 USING *,BAS 02140000 IHECSMH STM LR,RX,OFLR(DR) 02160000 LA CHR,X'FF' 02180000 BAL BAS,CM010 SET UP USING REGISTER 02200000 SPACE 2 02220000 * *********************** 02240000 * * LOW ENTRY * 02260000 * *********************** 02280000 SPACE 02300000 USING *,BAS 02320000 IHECSML STM LR,RX,OFLR(DR) 02340000 SR CHR,CHR 02360000 CM010 IHESDR LW0,RC 02380000 LR RT1,RS1 02400000 LH RE1,LFLD(RT1) SET RE1 TO LENGTH OF FIELD 02420000 L RT2,0(RT1) LOAD ADDRESS OF STRING 02440000 BC 15,CMCHM BRANCH TO FILL ROUTINE 02460000 SPACE 2 02480000 * *********************** 02500000 * *FIXED ASSIGN ENTRY * 02520000 * *********************** 02540000 SPACE 02560000 USING *,BAS 02580000 IHECSMF STM LR,RX,OFLR(DR) 02600000 LA BAS,IHECSMV 02620000 USING IHECSMV,BAS 02640000 BAL LNK,CM015 BRANCH TO VAR ASSIGN ROUTINE 02660000 SPACE 02680000 L LNK,OFLR(DR) RESTORE LINK REGISTER 02700000 BC 15,CM020 BRANCH TO FILL ROUTINE 02720000 SPACE 2 02740000 * *********************** 02760000 * * VAR. ASSIGN ENTRY. * 02780000 * *********************** 02800000 SPACE 02820000 USING *,BAS 02840000 IHECSMV STM LR,RX,OFLR(DR) 02860000 CM015 IHESDR LW0,RC 02880000 LH RE1,LFLD(RS1) 02900000 CH RE1,MFLD(RT1) EXCEEDS TARGET MAXIMUM. 02920000 BC 12,CM030 IF NOT, BRANCH. 02940000 LH RE1,MFLD(RT1) YES, USE TARGET MAXIMUM FOR. 02960000 * SOURCE CURRENT LENGTH 02980000 CM030 STH RE1,LFLD(RT1) STORE CALCULATED SOURCE CURRENT 03000000 * LENGTH IN TARGET SDV. 03020000 L RS1,0(RS1) LOAD ADDRESSES OF SOURCE AND 03040000 L RT2,0(RT1) TARGET STRINGS. 03060000 SH RE1,CMX01+2 SUBTRACT 1 FROM LENGTH FOR MOVE 03080000 BC 4,CM035 BRANCH IF LENGTH WAS ZERO 03100000 SRDL RE1,8 SET UP RE1 FOR NUMBER OF TIMES 03120000 SRL RO1,24 THROUGH MOVE LOOP, RO1 FOR 03140000 LA RE1,1(0,RE1) LENGTH OF FIRST MOVE 03160000 SPACE 03180000 * MOVE LOOP. 03200000 SPACE 03220000 CMMVL EX RO1,CMMVI EXECUTE MOVE USING LENGTH RO1. 03240000 LA RT2,1(RO1,RT2) ADD LENGTH MOVED TO ADDRESSES 03260000 LA RS1,1(RO1,RS1) OF SOURCE AND TARGET FIELDS. 03280000 LA RO1,255 SET RO1 TO 255 AFTER FIRST MOVE 03300000 BCT RE1,CMMVL LOOP IF MORE SOURCE DATA. 03320000 CM035 L DR,OFDR(DR) 03340000 LM RB,RE,OFRB(DR) 03360000 MVI OFLR(DR),X'FF' 03380000 BCR 15,LNK 03400000 SPACE 2 03420000 * *********************** 03440000 * * BLANK FILL ENTRY * 03460000 * *********************** 03480000 SPACE 03500000 USING *,BAS 03520000 IHECSMB STM LR,RX,OFLR(DR) 03540000 LR RT1,RS1 03560000 CM020 IHESDR LW0,RC 03580000 L RT2,0(RT1) 03600000 AH RT2,LFLD(RT1) 03620000 DROP BAS 03640000 LH RO1,LFLD(RT1) SET UP LENGTH FOR BLANK FILL 03660000 LH RE1,MFLD(RT1) AND MAKE CURRENT LENGTH SLOT 03680000 STH RE1,LFLD(RT1) IN TARGET SDV EQUAL TO 03700000 SR RE1,RO1 MAXIMUM SLOT. 03720000 LA CHR,C' ' LOAD REGISTER CHR WITH BLANK 03740000 CMCHM BALR BAS,0 03760000 USING *,BAS 03780000 SH RE1,CMX01+2 SUBTRACT 1 FROM LENGTH FOR MOVE 03800000 BC 4,CM040 BRANCH IF LENGTH WAS ZERO 03820000 STC CHR,0(RT2) STORE CHARACTER IN FIRST BYTE 03840000 * OF TARGET TO BE FILLED 03860000 SH RE1,CMX01+2 SUBTRACT 1 FROM LENGTH 03880000 BC 4,CM040 BRANCH IF ONLY 1 BYTE LONG 03900000 SRDL RE1,8 SET UP RE1 FOR NUMBER OF TIMES 03920000 SRL RO1,24 THROUGH FILL LOOP, RO1 FOR 03940000 CMX01 LA RE1,1(RE1,0) LENGTH OF FIRST MOVE. 03960000 SPACE 03980000 * FILL LOOP. 04000000 SPACE 04020000 CMCHL EX RO1,CMCHI PROPAGATE CHARACTER THROUGH 04040000 * FIELD USING LENGTH IN RO1 04060000 LA RT2,1(RO1,RT2) ADD LENGTH TO TARGET ADDRESS 04080000 CMXFF LA RO1,255 SET RO1 TO 255 AFTER FIRST MOVE 04100000 BCT RE1,CMCHL LOOP IF MORE TO BE FILLED 04120000 SPACE 04140000 CM040 L DR,OFDR(DR) 04160000 LM RB,RE,OFRB(DR) 04180000 MVI OFLR(DR),X'FF' 04200000 BCR 15,LNK RETURN 04220000 SPACE 04240000 * EXECUTED INSTRUCTIONS. 04260000 SPACE 04280000 CMMVI MVC 0(1,RT2),0(RS1) SOURCE TO TARGET MOVE INSTR. 04300000 CMCHI MVC 1(1,RT2),0(RT2) PROPAGATE CHARACTER INSTRUCTION 04320000 SPACE 2 04340000 END 04360000 ./ ADD SSI=04012041,SOURCE=1,NAME=IHECSS2 CSS TITLE ' IHECSS CHARACTER STRING SUBSTR *00600013 OS/360 PL/I LIBRARY' 01200013 * VERSION FOURTH VERSION OF F-LEVEL PL/1 COMPILER 01800015 * 02400013 * STATUS CHANGE LEVEL - 0. 03000013 * 03600013 * SIZE 224 BYTES 04200015 * 04800013 * FUNCTION TO PRODUCE A STRING DOPE VECTOR DESCRIBING THE SUBSTR 05400013 * PSEUDO-VARIABLE AND FUNCTION OF A CHARACTER STRING. 06000013 * SEE OS/360 PL/I LIBRARY - COMPUTATIONAL SUBROUTINES, 06600013 * FORM C28-6590, FOR DESCRIPTION OF METHOD. 07200013 * 07800013 * ENTRY POINTS 08400013 * IHECSS2 - SUBSTR(S,I) 09000013 * RA = A(PLIST) 09600013 * PLIST = A(SDV OF SOURCE STRING) 10200013 * A(I) 10800013 * DUMMY ARGUMENT 11400013 * A(FIELD FOR TARGET SDV) 12000013 * IHECSS3 - SUBSTR(S,I,J) 12600013 * RA = A(PLIST) 13200013 * PLIST = A(SDV OF SOURCE STRING) 13800013 * A(I) 14400013 * A(J) 15000013 * A(FIELD FOR TARGET SDV) 15600013 * 16200013 * INPUT N/A 16800013 * 17400013 * OUTPUT N/A 18000013 * 18600013 * EXTERNAL MODULES 19200013 * N/A 19800013 * 20400013 * EXITS NORMAL 21000013 * RETURN TO CALLER VIA LINK REGISTER. 21600013 * 22200013 * TABLES/WORK-AREA 22800013 * WORK-AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 23400013 * 24000013 * ATTRIBUTES READ-ONLY AND REENTRANT. 24600013 * 25200013 * PRIVATE MACROS 25800013 * IHELIB,IHESDR 26400013 * 27000013 * ASSEMBLY REQUIREMENTS 27600013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 28200013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 28800013 * 29400013 * NOTES SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY CONVENTIONS AND 30000013 * STANDARDS. 30600013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 31200013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 31800013 * EXTERNAL CHARACTER SET. 32400013 EJECT 33000013 IHECSS CSECT 33600013 SPACE 2 34200013 IHELIB 34800013 * PRIVATE REGISTER ASSIGNMENTS. 35400013 SPACE 36000013 RW1 EQU R0 36600013 SCR EQU BR 37000015 LTH EQU RA 37400015 RS1 EQU RB SOURCE. 37800015 RII EQU RC I. 38200015 RJJ EQU RD J. 38600015 RT1 EQU RE TARGET. 39000015 SWJ EQU RF 39400015 BAS EQU RG 39800015 SPACE 40800013 * PRIVATE OFFSETS. 41400013 SPACE 42000013 LFLD EQU 4 LENGTH FIELD IN SDV. 42600013 SPACE 43200013 * BRANCH CONDITION MNEMONICS. 43800013 SPACE 44400013 NM EQU 11 45000013 NP EQU 13 45600013 A EQU 15 46200013 EJECT 46800013 IHECSS CSECT 47400013 SPACE 48000013 ENTRY IHECSS2,IHECSS3 48600013 SPACE 2 49200013 * ************************************* 49800013 * * 2 ARGUMENTS, (J NOT SPECIFIED). * 50400013 * ************************************* 51000013 SPACE 51600013 IHECSS2 NOPR 0 53600015 SPACE 2 56400013 * ************************************* 57000013 * * 3 ARGUMENTS, (J SPECIFIED). * 57600013 * ************************************* 58200013 SPACE 58800013 IHECSS3 STM LR,WR,OFLR(DR) 59000015 BALR BAS,0 59200015 USING *,BAS 59400015 SR SWJ,SWJ INITIALISE SWJ 59600015 TM OFBR+3(DR),2 TEST ENTRY 59800015 IHESDR LW0,RB 60000015 BO CS005 BRANCH IF CSS3 ENTRY 60200015 LA SWJ,CS060-CS030 SET SWJ FOR J NOT SPECIFIED 60400015 CS005 LM RS1,RT1,0(RA) LOAD ARGUMENT LIST 60600015 L RII,0(RII) 60800015 LTR SWJ,SWJ 61000015 BNZ CS007 BRANCH IF J NOT SPECIFIED 61200015 L RJJ,0(RJJ) 61400015 LTR SCR,RJJ 61600015 BM CSTRG RAISE STRG IF J<0 61800015 CH RJJ,LFLD+2(RS1) 62000015 BH CSTRG RAISE STRG IF J>LTH 62200015 AR SCR,RII 62400015 BCTR SCR,0 62600015 CH SCR,LFLD+2(RS1) 62800015 BH CSTRG RAISE STRG IF I+J-1 >LTH 63000015 CS007 LTR RII,RII 63200015 BNP CSTRG RAISE STRG IF I<1 63400015 CH RII,LFLD+2(RS1) 63600015 BH CSTRG RAISE STRG IF I>LTH 63800015 CS009 LTR SWJ,SWJ 64000015 BNZ CS010 64200015 LTR RJJ,RJJ 64400015 BNP CSNUL NULL STRING IF J LE 0 64600015 CS010 C RII,XMIN IF I IS MAX NEG NO., 64800015 BE CS012 DON'T SUBTRACT 1. 66000013 SH RII,H001 RII = I-1. 66600013 BC NM,CS020 67200013 CS012 LTR SWJ,SWJ 67800013 BNZ CS015 68400013 AR RJJ,RII IF RII LT 0, SET RJJ = J+I-1 69000013 BC NP,CSNUL 69600013 CS015 SR RII,RII SET RII = 0. 70200013 CS020 LH LTH,LFLD+2(RS1) LOAD LENGTH OF SOURCE STRING. 70800013 SR LTH,RII SET LTH = LTH - RII. 71400013 BC NP,CSNUL 72000013 L RW1,0(RS1) 72600013 AR RW1,RII ADD RII TO SOURCE ADDRESS AND 73200013 ST RW1,0(RT1) STORE RESULT IN TARGET SDV. 73800013 BC A,CS030(SWJ) IF J NOT SPECIFIED SUBSTR LENGTH=LTH 74400013 CS030 CR LTH,RJJ IF AVAILABLE LTH NOT GT J, THIS LTH 75000013 BC NP,CS060 MUST SERVE FOR THE SUBSTRING. 75600013 LR LTH,RJJ OTHERWISE SET LTH = J. 76200013 CS060 STH LTH,LFLD(RT1) SET LENGTH FIELDS OF SDV. 76800013 STH LTH,LFLD+2(RT1) 77400013 CS070 L DR,OFDR(DR) 78000013 LM LR,RG,OFLR(DR) 78900015 BCR A,LR AND RETURN. 79800013 SPACE 80400013 CSTRG IHEPRV ERR,SCR,OP=LA 80600015 MVI 0(SCR),X'10' 80800015 L BR,VXEP 81000015 BALR LR,BR 81200015 B CS009 81400015 CSNUL SR RW1,RW1 IF SUBSTRING IS NULL, SET 81600013 ST RW1,LFLD(RT1) LENGTH FIELDS TO ZERO. 82200013 ST PR,0(RT1) SET ADDR TO DUMMY VALUE. 82800013 BC A,CS070 83400013 SPACE 84000013 * CONSTANTS 84600013 SPACE 85200013 H001 DC H'1' 85800013 DS 0F 86400013 XMIN DC X'80000000' 87000013 VXEP DC V(IHEERRB) 87300015 SPACE 2 87600013 END 88200013 ./ ADD SSI=00010801,SOURCE=1,NAME=IHECSTA CST TITLE ' IHECST CHARACTER STRING TRANSLATE X00500001 OS/360 PL/1 LIBRARY' 01000001 * VERSION FIFTH VERSION OF F-LEVEL PL/1 COMPILER 01500001 * 02000001 * STATUS CHANGE LEVEL - 0 02500001 * 03000001 * SIZE 304 BYTES 03500001 * 04000001 * FUNCTION THIS MODULE PERFORMS THE PL/1 TRANSLATE FUNCTION ON A 04500001 * TARGET CHARACTER STRING GIVEN THE POSITIONAL AND 05000001 * REPLACEMENT CHARACTER STRINGS. 05500001 * CHARACTERS IN THE TARGET STRING ARE COMPARED AGAINST 06000001 * CHARACTERS IN THE POSITIONAL STRING AND WHEN A MATCH IS 06500001 * FOUND THAT CHARACTER IN THE TARGET STRING IS REPLACED 07000001 * BY THE CHARACTER FROM THE REPLACEMENT STRING CORRESPOND- 07500001 * ING TO THE MATCHING CHARACTER IN THE POSITIONAL STRING. 08000001 * THIS IS ACHEIVED BY GENERATING A TRANSLATE TABLE FROM 08500001 * THE POSITIONAL AND REPLACEMENT CHARACTER STRINGS AND 09000001 * TRANSLATING THE TARGET STRING AGAINST THIS TABLE. 09500001 * 10000001 * ENTRY POINTS 10500001 * RA = A(PLIST) 11000001 * PLIST = A(SDV OF TARGET CHAR STRING) 11500001 * A(SDV OF REPLACEMENT CHAR STRING) 12000001 * A(SDV OF POSITIONAL CHAR STRING) 12500001 * A(TRANSLATE TABLE) 13000001 * 13500001 * INPUT N/A 14000001 * 14500001 * OUTPUT N/A 15000001 * 15500001 * EXTERNAL MODULES 16000001 * NONE 16500001 * 17000001 * EXITS NORMAL 17500001 * RETURN TO CALLER VIA LINK REGISTER 18000001 * 18500001 * TABLES/WORK AREA 19000001 * TRANSLATE TABLE IS PASSED FROM COMPILED CODE 19500001 * 20000001 * ATTRIBUTES 20500001 * READ ONLY AND RE-ENTRANT 21000001 * 21500001 * PRIVATE MACROS 22000001 * IHELIB AND IHESDR 22500001 * 23000001 * ASSEMBLY REQUIREMENTS 23500001 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 24000001 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 24500001 * 25000001 * NOTES SEE OS/360 PL/1 LIBRARY PLM FOR LIBRARY CONVENTIONS AND 25500001 * STANDARDS. 26000001 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON A 26500001 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL 27000001 * CHARACTER SET 27500001 EJECT 28000001 IHECST CSECT 28500001 SPACE 2 29000001 IHELIB 29500001 IHECST CSECT 30000001 SPACE 30500001 ENTRY IHECSTA 31000001 SPACE 2 31500001 IHECSTA EQU * 32000001 STM LR,WR,OFLR(DR) SAVE REGISTERS. 32500001 IHESDR LW0,RD 33000001 BALR WR,0 ESTABLISH ADDRESSABILITY. 33500001 USING *,WR 34000001 SPACE 34500001 * ANALYSE POSITIONAL AND REPLACEMENT STRINGS. 35000001 SPACE 35500001 L RB,4(RA) A(REPL SDV). 36000001 LTR RB,RB + IS THERE A REPL STR. 36500001 BZ CST18 * NO. TRANS TABLE ALREADY BUILT. 37000001 LH RE,6(RB) YES. L(REPL STR). 37500001 L RB,0(RB) A(REPL STR). 38000001 L RH,8(RA) A(POSN SDV). 38500001 LTR RH,RH + IS THERE A POSN STR. 39000001 BZ CST15 * NO. BUILD CODE TABLE ONLY. 39500001 LH RC,6(RH) YES. L(POSN STR). 40000001 L RH,0(RH) A(POSN STR). 40500001 LTR RC,RC + IS POSN STR A NULL STR. 41000001 BZ CST23 * YES. DO NOT TRANSLATE. 41500001 SPACE 42000001 * INITIALIZE TRANSLATE TABLE 42500001 SPACE 43000001 CST10 EQU * 43500001 L RD,12(RA) A(TABLE). 44000001 MVC 0(256,RD),FILLER FILL TABLE WITH VALUES 00 - FF 46000001 EJECT 49000001 SPACE 49500001 * FILL TRANSLATE TABLE FROM REPLACEMENT STRING. 50000001 SPACE 50500001 SR RF,RF CLEAR TABLE OFFSET. 51000001 LA R0,X'40' SET UP BLANK FILL CHAR. 51500001 BCTR RH,0 52000001 BCTR RB,0 52500001 CST12 EQU * 53000001 CR RC,RE + L(POSN STR) GT L(REPL STR) 53500001 BH CST14 * YES. USE BLANKS IN TABLE. 54000001 CST13 EQU * NO. INSERT REPL CHAR IN TABLE. 54500001 IC RF,0(RC,RH) GET LAST CHAR IN POSN STR. 55000001 IC RG,0(RC,RB) GET EQUIV CHAR IN REPL STR. 55500001 STC RG,0(RF,RD) SET IN TABLE AT OFFSET POSN STR 56000001 BCT RC,CST13 * REPEAT FOR NEXT CHAR POSN STR. 56500001 B CST20 * POSN STR EXHAUSTED. 57000001 CST14 EQU * 57500001 IC RF,0(RC,RH) GET LAST CHAR IN POSN STR. 58000001 STC R0,0(RF,RD) BLANK TABLE AT THIS OFFSET. 58500001 BCT RC,CST12 * CHECK NEXT CHAR IN REPL STR. 59000001 B CST20 * REPL STR EXHAUSTED. 59500001 SPACE 60000001 * BUILT CODE TABLE USING REPLACEMENT STRING ONLY (POSN STR = 0). 60500001 SPACE 61000001 CST15 EQU * 61500001 L RD,12(RA) A(TRANS TABLE). 62000001 LTR RE,RE + IS REPL STR A NULL STR 62500001 BZ CST17 * YES. FILL TRANS TABLE WITH BLKS 63000001 CH RE,H256 + NO. L(REPL STR) GT 256. 63500001 BNH CST16 * NO. 64000001 LH RE,H256 YES. MOVE 256 CHARS REPL STR. 64500001 CST16 EQU * 65000001 BCTR RE,0 65500001 EX RE,FILL MOVE REPL STR INTO TRANS TABLE. 66000001 LA RE,1(RE) 66500001 CH RE,H256 + L(REPL STR) IS 256. 67000001 BE CST20 * YES. TRANS TABLE COMPLETE. 67500001 CST17 EQU * 68000001 LA RC,0(RE,RD) NO. PAD TABLE WITH BLANKS. 68500001 MVI 0(RC),X'40' 69000001 LA RF,254 69500001 SR RF,RE 70000001 BM CST20 * TRANSLATE TABLE COMPLETE. 70500001 EX RF,MOVE FILL TABLE WITH BLANKS 71000001 B CST20 * TRANSLATE TABLE COMPLETE. 71500001 EJECT 72000001 SPACE 72500001 * TRANSLATE TARGET STRING AGAINST TRANSLATE TABLE. 73000001 SPACE 73500001 CST18 EQU * 74000001 L RD,12(RA) A(TRANS TABLE). 74500001 CST20 EQU * 75000001 L RB,0(RA) A(TARG SDV). 75500001 LH RC,6(RB) L(TARG STR). 76000001 L RB,0(RB) A(TARG STR). 76500001 CST21 EQU * 77000001 CH RC,H256 + IS L(TARG STR) GT 256. 77500001 BNH CST22 * NO. 78000001 TR 0(256,RB),0(RD) YES. TRANS 256 BYTE CHUNK. 78500001 AH RB,H256 BUMP A(TARG STR) BY 256. 79000001 SH RC,H256 REDUCE L(TARG STR) BY 256. 79500001 B CST21 * TRANS NEXT 256 BYTE CHUNK. 80000001 CST22 EQU * 80500001 LTR RC,RC + L(TARG STR) IS ZERO. 81000001 BZ CST23 * YES. RETURN. 81500001 BCTR RC,0 NO. TRANS LAST CHUNK OF 82000001 EX RC,TRAN TARG STR. 82500001 CST23 EQU * 83000001 L DR,OFDR(DR) 83500001 LM R0,WR,OFR0(DR) RESTORE CALLERS REGISTERS. 84000001 BR LR X RETURN. 84500001 SPACE 2 85000001 * PROGRAM CONSTANTS 85500001 SPACE 86000001 FILL MVC 0(*-*,RD),0(RB) 86500001 MOVE MVC 1(*-*,RC),0(RC) 87000001 TRAN TR 0(*-*,RB),0(RD) 87500001 H256 DC H'256' 88000001 FILLER DC X'000102030405060708090A0B0C0D0E0F' 88100001 DC X'101112131415161718191A1B1C1D1E1F' 88200001 DC X'202122232425262728292A2B2C2D2E2F' 88300001 DC X'303132333435363738393A3B3C3D3E3F' 88400001 DC X'404142434445464748494A4B4C4D4E4F' 88500001 DC X'505152535455565758595A5B5C5D5E5F' 88600001 DC X'606162636465666768696A6B6C6D6E6F' 88700001 DC X'707172737475767778797A7B7C7D7E7F' 88800001 DC X'808182838485868788898A8B8C8D8E8F' 88900001 DC X'909192939495969798999A9B9C9D9E9F' 89000001 DC X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF' 89100001 DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF' 89200001 DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF' 89300001 DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF' 89400001 DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF' 89500001 DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' 89600001 SPACE 2 91000001 END 91500001 ./ ADD SSI=00011293,SOURCE=1,NAME=IHECSVA CSV TITLE ' IHECSV CHARACTER STRING VERIFY X00600001 OS/360 PL/1 LIBRARY' 01200001 * VERSION FIFTH VERSION OF F-LEVEL PL/1 COMPILER 01800001 * 02400001 * STATUS CHANGE LEVEL - 0 03000001 * 03600001 * SIZE 198 BYTES 04200001 * 04800001 * FUNCTION THIS MODULE PERFORMS THE PL/1 VERIFY FUNCTION GIVEN THE 05400001 * STRINGS E1 AND E2. THE RESULT OF VERIFYING E1 AGAINST 06000001 * E2 IS PLACED IN THE RESULT FIELD. 06600001 * THE FUNCTION IS IMPLEMENTED IN THE FOLLOWING MANNER: 07200001 * 1 BUILD A TRANSLATE TABLE FROM E2 STRING. 07800001 * THE TABLE WILL CONTAIN A ZERO ENTRY IN EACH POSITION 08400001 * CORRESPONDING TO A CHARACTER OF E2. ALL OTHER ENTRIES 09000001 * WILL CONTAIN FF. 09600001 * IF THERE IS NO E2 STRING THEN THE TABLE WAS COMPILED 10200001 * BY THE COMPILER 10800001 * 2 TRANSLATE AND TEST E1 STRING AGAINST THIS TABLE. 11400001 * FIRST NON ZERO RESULT WILL RETURNED IN RESULT FIELD. 12000001 * 12600001 * ENTRY POINTS 13200001 * RA = A(PLIST) 13800001 * PLIST = A(E1 SDV) 14400001 * A(E2 SDV) 15000001 * A(TRANSLATE TABLE) 15600001 * A(RESULT FIELD) 16200001 * 16800001 * INPUT N/A 17400001 * 18000001 * OUTPUT N/A 18600001 * 19200001 * EXTERNAL MODULES 19800001 * NONE 20400001 * 21000001 * EXITS NORMAL 21600001 * RETURN TO CALLER VIA LINK REGISTER 22200001 * 22800001 * TABLES/WORK AREA 23400001 * TRANSLATE TABLE IS PASSED FROM COMPILED CODE 24000001 * 24600001 * ATTRIBUTES 25200001 * READ ONLY AND RE-ENTRANT 25800001 * 26400001 * PRIVATE MACROS 27000001 * IHELIB AND IHESDR 27600001 * 28200001 * ASSEMBLY REQUIREMENTS 28800001 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 29400001 * SUPPORT E.G. O/S 360 F-ASSEMBLER 30000001 * 30600001 * NOTES SEE O/S 360 PL/1 LIBRARY PLM FOR LIBRARY CONVENTIONS 31200001 * AND STANDARDS. 31800001 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON ANY 32400001 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL 33000001 * CHARACTER SET 33600001 EJECT 34200001 IHECSV CSECT 34800001 SPACE 2 35400001 IHELIB 36000001 IHECSV CSECT 36600001 SPACE 37200001 ENTRY IHECSVA 37800001 SPACE 2 38400001 IHECSVA EQU * 39000001 STM LR,WR,OFLR(DR) SAVE REGISTERS. 39600001 IHESDR LW0,RD SAVE AREA CHAIN. 40200001 BALR WR,0 ESTABLISH ADDRESSABILITY. 40800001 USING *,WR 41400001 SPACE 42000001 * EXAMINE E2 STRING AND BUILD TRANSLATE TABLE IF REQUIRED. 42600001 SPACE 43200001 LR RB,RA SAVE PARAMETER LIST POINTER. 43800001 LM RH,RJ,0(RB) GET ADDR E1SDV-E2SDV-TRANS TAB 44400001 LH RC,6(RH) GET LENGTH E1 STR. 45000001 LTR RC,RC + IS E1 A NULL STR. 45600001 BZ CSV23 * YES. RESULT IS ZERO. 46200001 LTR RI,RI + IS ADDR E2 SDV ZERO. 46800001 BZ CSV20 * YES. TRANSLATE TABLE BUILT. 47400001 LH RC,6(RI) NO. GET LENGTH E2 STR. 48000001 LTR RC,RC + IS E2 A NULL STR. 48600001 BZ CSV26 * YES. RESULT IS ONE. 49200001 SPACE 49800001 MVI 0(RJ),X'FF' FILL TRANSLATE TABLE WITH 50800001 MVC 1(255,RJ),0(RJ) HEX 'FF' FROM 0 TO 255. 51800001 L RE,0(RI) GET ADDR E2 STR. 54600001 SR RF,RF 55200001 SR RG,RG 55800001 BCTR RE,0 56400001 CSV11 EQU * 57000001 IC RF,0(RC,RE) INSERT ZERO IN TRANS TABLE 57600001 STC RG,0(RF,RJ) AT OFFSET OF E2 CHAR. 58200001 BCT RC,CSV11 +* LOOP UNTIL E2 STR EXHAUSTED. 58800001 SPACE 59400001 * VERIFY E1 STRING IN BLOCKS OF 256 BYTES USING TRANS TABLE. 60000001 SPACE 60600001 CSV20 EQU * 61200001 LR RD,RB SAVE RB (DESTROYED BY TRT). 61800001 LH RC,6(RH) GET LENGTH E1 STR. 62400001 L RE,0(RH) GET ADDR E1 STR. 63000001 LR RF,RE SAVE IT. 63600001 CSV21 EQU * 64200001 CH RC,H256 + LENGTH E1 GT 256. 64800001 BNH CSV22 * NO 65400001 TRT 0(256,RE),0(RJ) YES. TRT 256 BYTE CHUNK. 66000001 BC 6,CSV24 * VERIFY CHECK. 66600001 AH RE,H256 67200001 SH RC,H256 67800001 B CSV21 68400001 CSV22 EQU * 69000001 BCTR RC,0 69600001 EX RC,TRAN 70200001 BC 6,CSV24 * VERIFY CHECK. 70800001 SPACE 71400001 CSV23 EQU * 72000001 LR RD,RB 72600001 SR RA,RA RESULT OF VERIFY IS ZERO. 73200001 B CSV25 73800001 CSV26 EQU * 74400001 LR RD,RB 75000001 LA RA,1 RESULT OF VERIFY IS ONE. 75600001 B CSV25 76200001 CSV24 EQU * 76800001 BCTR RF,0 77400001 SR RA,RF POSITION OF BAD CHARACTER. 78000001 CSV25 EQU * 78600001 L RB,12(RD) GET ADDRESS OF RESULT FIELD. 79200001 ST RA,0(RB) STORE RESULT OF VERIFY. 79800001 L DR,OFDR(DR) 80400001 LM R0,WR,OFR0(DR) RESTORE CALLERS REGISTERS. 81000001 BR LR X RETURN. 81600001 SPACE 4 82200001 * PROGRAM CONSTANTS 82800001 SPACE 83400001 H256 DC H'256' 85800001 TRAN TRT 0(*-*,RE),0(RJ) 86400001 SPACE 3 87000001 END 87600001 ./ ADD SSI=21400050,NAME=IHECTTA,SOURCE=0 CTT TITLE 'IHECTT CLOSE - TASKING /00100017 OS/360 PL/I LIBRARY' 00200017 * VERSION FOURTH VERSION OF F-LEVEL PL/1 COMPILER 00300017 * 00400017 * STATUS CHANGE LEVEL - 5 00500001 * 00600017 * SIZE 1984 BYTES 00700017 * 00800017 *A195300,504000,508000,509000 BPC 43435 00802056 *C196000,521000 BPC 43435 00804056 * 00806056 * CHANGE MADE ON RELEASE 20 FOR APAR 31647 00810020 * 109000 00820020 * 195300,* 00830020 * 493000,* 00840020 * 00850020 * APAR 41929 FIXED BY FOLLOWING UPDATE. 00860046 * 00870046 * 528100,528500 00880046 * 00890046 * FUNCTION 00900017 * 1) CHECK STATUS OF FILE (IE.FILE REGISTER). 01000017 * 2) CLOSE FILES 01100017 * 3) ZERO FILE REGISTER (LAST THREE BYTES) 01200017 * 4) FREE THE BUFFER POOL OBTAINED FOR FILE. 01300017 * 5) FREE DYNAMIC CORE OBTAINED FOR FCB. 01400017 * 6) COMPLETE INITIALISATION OF SEQUENTIALLY CREATED 01500017 * REGIONAL DATA SETS BY CALLING IHEITC MODULE. 01600017 * 7) DELETE RECORD I/O MODULES LOADED AT OPEN TIME. 01700017 * 8) DE-CHAIN THE FILES FROM THE OPENED FILE CHAIN. 01800017 * 9) FREE IOCBS THAT WERE OBTAINED BY THE DIRECT ACCESS 01900017 * 10) SET EVENTS COMPLETE AND DEQ EXCLUSIVE BLOCKS 02000017 * 02100017 * ENTRY POINTS 02200017 * IHECTTA - EXPLICIT CLOSE 02300017 * RA= A(PLIST) 02400017 * PLIST = A(CLOSE PLIST) 02500017 * = A(ADCON) 02600017 * CLOSE PLIST = A(DCLCB) * THE NORMAL END 02700017 * A(IDENT SDV) * OF LIST BIT IS 02800017 * A(IDENT DED) * SET IN LAST WORD. 02900017 * IHECTTB - IMPLICIT CLOSE 03000017 * RA = A(PLIST) 03100017 * PLIST = A(WORD CONTAINING NUMBER OF FILES * 4) 03200017 * = A(ADCON LIST) 03300017 * = A(1ST FCB) 03400017 * ... 03500017 * = A(LAST FCB) WITH TOP BIT OF WORD SET 03600017 * 03610001 * IHECTTC IMPLICIT CLOSE : ABNORMAL ENTRY 03620001 * 03630001 * PARAMETER LIST AS IHECTTB 03640001 * 03650001 * NO CLOSE MACRO TO ISSUED FOR FILES 03660001 * NO FREEMAIN FOR SUBPOOL 1 CORE 03670001 * 03700017 * 03800017 * INPUT 03900017 * FCB,DCLCB,ADCON LIST(SEE IHEOCL) 04000017 * 04100017 * OUTPUT 04200017 * FILE REGISTER SET TO ZERO. 04300017 * 04400017 * EXTERNAL MODULES 04500017 * LIBRARY0 04600017 * IHETSA - GET/FREE VDA. 04700017 * CONTROL SYSTEM0 04800017 * CLOSE - CLOSE FILES. 04900017 * FREEPOOL - FREEBUFFER POOLS. 05000017 * FREEMAIN - FREE CORE. 05100017 * DELETE - DELETE RECORD I/O MODULES 05200017 * DEQ - RELEASE EXCLUSIVE RECORD. 05300017 * 05400017 * EXITS 05500017 * RETURN VIA LINK REGISTER TO CALLER. 05600017 * 05700017 * TABLES/WORK AREA 05800017 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF 05900017 * FCB,DCLCB,AND FILE REGISTER. 06000017 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE(LWS). 06100017 * 06200017 * ATTRIBUTES READ ONLY AND REENTRANT 06300017 * 06400017 * PRIVATE MACROS 06500017 * IHELIB,IHEZAP 06600017 * 06700017 * ASSEMBLY REQUIREMENTS 06800017 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 06900017 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 07000017 * 07100017 * NOTES 07200017 * SEE OS/360 PL/I LIBRARY PLM FOR LIBRARY MODULE 07300017 * CONVENTIONS AND STANDARDS. 07400017 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 07500017 * UPON A PARTICULAR INTERNAL REPRESENTATION OF THE 07600017 * EXTERNAL CHARACTER SET. 07700017 EJECT 07800017 IHECTT CSECT 07900017 IHELIB 08000017 IHEZAP 08100017 DCBD DSORG=(QS,IS,MQ) 08200001 IHEXLV 08300017 EJECT 08400017 PARM DSECT 08500017 ODCL DS A A(FILE CONTROL BLOCK (DCLCB)). 08600017 OIDT DS A A(IDENT SDV). 08700017 OEOL DS 0BL1 END OF LIST FLAG. 08800017 ODED DS A A(DED FOR STRING). 08900017 SPACE 09000017 IHEZLW0 DSECT 09100017 DS 9D 09200017 PARMP DS A CLOSE PARM LIST ADDRESS. 09300017 VDAAD DS A VDA ADDRESS. 09400017 ITCPL DS 5A ITC PLIST SPACE. 09500017 BRBR DS A 09600017 * X'00' ENTRY POINT CTTA 09620001 * X'02' ENTRY POINT CTTB 09640001 * X'06' ENTRY POINT CTTC 09660001 DEQF DS A 09700017 DEQA DS 2A 09800017 DEQR DS A 09900017 DEQQ DS 2A 10000017 RFRF DS A 10100017 SPACE 2 10200017 TCIT EQU TCBA EXTENDED DCB APE 10300017 RERD EQU X'10' REREAD DISPOSITION. 10400017 LEVE EQU X'30' LEAVE DISPOSITION. 10500017 LEAV EQU X'80' LEAVE OPTION. 10600017 MEOL EQU X'80' END OF LIST. 10700017 VALS EQU X'10' FIXED OR VARIABLE STRING. 10800017 VR17 EQU 5 10900017 * ADDITIONAL EQUATE FOR TTYP IN FILE CONTROL BLOCK 10930020 TMSP EQU B'00001000' SPANNED RECORD I/O 31647 10960020 EJECT 11000017 IHECTT CSECT 11100017 ENTRY IHECTTA,IHECTTB 11200017 ENTRY IHECTTC 11250001 SPACE 2 11300017 USING IHEZADC,RI 11400017 USING IHADCB,RE 11500017 USING IHEZAPE,RC 11600017 USING IHEZLW0,DR 11700017 USING PARM,RG 11800017 USING IHEZIOB,RD 11900017 SPACE 12000017 IHECTTA NOPR 0 EXPLICIT CLOSE. 12100017 SPACE 12200017 IHECTTB EQU * IMPLICIT CLOSE NORMAL 12240001 NOP 00 12280001 IHECTTC EQU * IMPLICIT CLOSE ABNORMAL 12320001 STM LR,WR,OFLR(DR) STORE REGS 12360001 BALR RJ,0 SET UP BASE REGISTER. 12400017 USING *,RJ 12500017 L RI,4(RA) GET A(ADCON LIST). 12600017 LH WR,IQLW0 GET LWS 0 OFFSET. 12700017 L WR,0(WR,PR) A(LIBWS) IN PWR. 12800017 L RG,0(RA) 12900017 ST DR,OFDR(WR) SET UP SAVE AREA POINTER. 13000017 LR DR,WR * 13100017 STC BR,BRBR SAVE ENTRY POINT FLAG. 13200017 TM BRBR,X'02' TEST ENTRY POINT 13300017 BO CLIP1 BRANCH IF IMPLICIT. 13400017 ST RG,PARMP SAVE P.LIST POINTER. 13500017 SPACE 2 13600017 LA RA,1 13700017 CLTES EQU * 13800017 TM OEOL,MEOL + END OF P.LIST YET. 13900017 BO CLNFS YES,NO OF FILES TO CLOSE FOUND. 14000017 LA RG,12(RG) NO,BUMP PARM LIST POINTER. 14100017 LA RA,1(RA) BUMP NO OF FILES COUNT. 14200017 B CLTES 14300017 SPACE 14400017 CLNFS EQU * 14500017 SLL RA,2 4*N. 14600017 LR RB,RA SAVE NO OF FILES'N'. 14700017 CLP11 EQU * 14800017 LA R0,12(RA) 12+4*N BYTES FOR VDA. 14900017 L BR,ISADF 15000017 BALR LR,BR $$ GET VDA. 15100017 ST RB,8(RA) SAVE IN VDA. 15200017 LA RF,8(RA) 15300017 ST RF,VDAAD SAVE A(VDA). 15400017 TM BRBR,X'02' TEST ENTRY POINT. 15500017 BO CLIP2 * BRANCH IF IMPLICIT. 15600017 L RG,PARMP GET A(P.LIST). 15700017 EJECT 15800017 CLLP1 EQU * 15900017 LA RF,4(RF) BUMP DAMT P.LIST POINTER. 16000017 CLLP2 EQU * 16100017 L RD,ODCL GET ADDRESS OF DCLCB 16200017 LH RE,0(RD) GET P.R.OFFSET OF FILE. 16300017 ALR RE,PR A(P.R.SLOT). 16400017 L RC,0(RE) A(FCB) 16500017 LA RC,0(RC) LOOSE TOP BYTE 16600017 LTR RC,RC + IS IT ZERO 16700017 BNZ CLGER * NO, 16800017 CLLP3 EQU * 16900017 TM BRBR,X'02' + IMPLICIT CLOSE? 17000017 BO CLIP7 YES. 17100017 TM OEOL,MEOL + END OF LIST YET. 17200017 BO CLTAO YES. 17300017 LA RG,12(RG) NO,BUMP PARM.LIST POINTER. 17400017 B CLLP2 17500017 CLTAO EQU * 17600017 SH RF,X04X 17700017 CLTAI EQU * 17800017 CL RF,VDAAD + ANY FILES LEFT TO BE CLOSED. 17900017 BE CLEND NO. 18000017 B CLSEP YES. 18100017 CLGER EQU * 18200017 TM TFHT,TMCC PREVENT CLOSE FLAG ON? 18300017 BO CL004 18400017 CLGR1 EQU * 18500017 TM BRBR,X'02' + IMPLICIT CLOSE.. 18600017 BO CLIK1 YES. SKIP NEXT TEST. 18700017 TM 0(RE),X'FF' + ERROR DETECTED ON OPEN 18800017 BZ CLGEM * NO, 18900017 CLIK1 EQU * 19000017 OI TFHT,TMET / SET END OF EXTENT FLAG 19100017 CLGEM EQU * 19200017 L RE,TDCB 19300017 LA RE,0(RE) GET A(DCB). 19400017 ST RE,0(RF) SET DCB INTO CLOSE P.LIST. 19500017 TM DCBRECFM,X'48' + IS IT SPANNED RECORD 31647 19510020 BNO NSPAN * NO 31647 19520020 OI TTYP,TMSP SET BIT IN FCB 31647 19530042 TM TFHT,TMLT PRIOR LOCATE FLAG SET? 43435 19532056 BNO NSPAN NO 43435 19534056 MVC TLRL(2),DCBLRECL SAVE LENGTH OF WORK AREA 43435 19536056 NSPAN CLI TFAC,TMQT + IS IT QTAM ACCESS METHOD 31647 19540020 BE CL004 * YES, 19560001 MVC TFIO(1),DCBKEYLE ***SAVE KEYLE.IN 43535 19600056 * UNAUTHORISED FIELD*** 43435 19640056 TM TFFP,TMHQ + HIDDEN BUFFERS MAYBE REQUIRED? 19700017 BZ CL143 NO. 19800017 L RA,TREC GET ADDRESS OF HIDDEN BUFFER. 19900017 LA RA,0(RA) REMOVE TOP BYTE. 20000017 LTR RA,RA + IS IT ZERO. 20100017 BZ CL143 YES. 20200017 L RY,TCBA GET A(D.M. BUFFER). 20208001 SR RZ,RZ 20216001 IC RZ,DCBKEYLE GET DCB KEYLENGTH. 20224001 AR RY,RZ RY = A(DATA IN DM BUFFER) 20232001 LH RZ,DCBBLKSI GET DCB BLOCKSIZE. 20240001 LA R0,256 SET UP COUNTER. 20248001 CLIS1 EQU * 20256001 CR RZ,R0 + MORE THAN 256 BYTES. 20264001 BNH CLIS2 * NO. 20272001 MVC 0(256,RY),0(RA) YES. MOVE 256 BYTES. 20280001 AR RA,R0 BUMP UP A(FROM). 20288001 AR RY,R0 BUMP UP A(TO). 20296001 SR RZ,R0 KNOCK DOWN LENGTH. 20304001 B CLIS1 * GO TO MOVE NEXT BLOCK. 20312001 CLIS2 EQU * 20320001 LTR RZ,RZ + ANY MORE TO MOVE. 20328001 BZ CLIS3 * NO. SKIP OVER. 20336001 BCTR RZ,0 YES. MVC QUIRK. 20344001 EX RZ,CLMOVE MOVE REMAINDER. 20352001 CLIS3 EQU * 20360001 L RA,TREC GET A(DUMMY BUFFER). 20368001 LH R0,DCBBLKSI GET L(DUMMY BUFFER). 20376001 FREEMAIN R,LV=(0),A=(1) FREE! 20400017 CL143 EQU * 20500017 CLI TFOG,TMCN + CONSECUTIVE ? 20600017 BNE CLGEN NO. 20700017 L RD,TDCL LOAD A(DCLCB) 20755 20750017 * I10 20800017 TM 8(RD),NRRD NOREREAD SPECIFIED IN ENV. 20900017 BNZ CL147 YES. 21000017 OI 0(RF),RERD / SET REREAD BITS FOR OPEN DISP. 21100017 CL147 EQU * 21200017 TM 8(RD),LEAV + LEAVE SPECIFIED ON ENV. 21300017 BZ CLGEN NO. 21400017 OI 0(RF),LEVE / YES, SET LEAVE FOR OPEN DISP. 21500017 CLGEN EQU * 21600017 TM TFTY,TMRC + RECORD I/O. 21700017 BO CL004 YES. 21800017 TM TFRC,TMFX + F FORMAT RECORDS. 21900017 BZ CLJ00 BRANCH IF NOT F-FORMAT. 22000017 TM TFMD,TMOP + OUTPUT BUFFER TO BE FILLED. 22100017 BZ CL001 * NO. 22200017 LH RB,TREM YES,GET REM. BYTES IN RECORD. 22300017 LTR RB,RB + ANY REMAINING. 22400017 BZ CL001 NO. 22500017 L RA,TCBA GET A(CURRENT BYTE). 22600017 CL002 EQU * 22700017 MVI 0(RA),C' ' FILL UP WITH BLANKS. 22800017 LA RA,1(RA) BUMP A(CURRENT BYTE). 22900017 BCT RB,CL002 + LAST BYTE. 23000017 B CL001 23100017 EJECT 23200017 CLJ00 EQU * 23300017 L RA,TREC GET A(DUMMY BUFFER). 23400017 LTR RA,RA HAS IT BEEN ALLOCATED? 23500017 BZ CL001 NO. 23600017 TM BRBR,X'04' TEST IF C ENTRY= NO CLOSE ISSUED 23630001 BO CL001 23660001 LH R0,DCBBLKSI YES. GET LENGTH OF BLOCK. 23700017 A R0,SUBPL 23800017 FREEMAIN R,LV=(0),A=(1) FREE CORE GOT FOR DUMMY BUFFER. 23900017 B CL001 24000017 SPACE 24100017 CL004 EQU * 24200017 CLI IFOPE,5 RELEASE 17+.. 24300017 BNL CLIK2 NO 24400017 TM BRBR,X'02' 24500017 BNZ CLIK2 24600017 LA R0,255 24700017 CHAP (0) CHAP TO LIMIT. 24800017 CLIK2 EQU * 24900017 ST RF,RFRF SAVE RF. 25000017 TM TFHT,TMCC + PREVENT CLOSE? 25100017 BO CLX04 YES. UNLOCK ONLY. 25200017 TM BRBR,X'02' IMPLICIT CLOSE.. 25300017 BO CLX01 YES. 25400017 LH RF,IQFOP GET QFOP OFFSET. 25500017 AR RF,PR GET A(IHEQFOP). 25600017 L RB,0(RF) GET A(FIRST OPEN FILE FCB). 25700017 CLX00 EQU * 25800017 LA RB,0(RB) REMOVE TOP BITS. 25900017 CR RB,RC IS THIS FILE IN CHAIN 26000017 BE CLX01 YES. 26100017 L RB,TFOP-TBEG(RB) STEP DOWN QFOP CHAIN. 26200017 LTR RB,RB IS ENTRY ZERO. 26300017 BNZ CLX00 NO 26400017 B CLX13 26500017 CLX01 EQU * 26600017 CLI TFAC,TMQS + QSAM. 26700017 BE CLX13 YES. 26800017 CLI TFAC,TMQI + QISAM. 26900017 BE CLX13 YES. 27000017 CLI TFAC,TMQT + IS IT QTAM ACCESS 27030001 BE CLX13 * YES, BYPASS EXCLUSIVE STUFF 27060001 L R0,TBBZ GET LENGTH OF IOCB 27100017 CLX03 EQU * 27200017 L RD,TLAB 27300017 CLX31 EQU * 27400017 LTR RD,RD 27500017 BZ CLX04 SKIP. 27600017 CLI BACT,X'FF' IOCB ACTIVE.. 27700017 BNE CLX02 27800017 L RA,BEVN GET ADDRESS OF EVENT VARIABLE. 27900017 USING IHEZEVT,RA 28000017 BAL LR,CLEV2 $ PROCESS EVENT VARIABLE. 28100017 B CLX02 * END OF CHAIN. 28200017 LM LR,BR,EVCF GET FILE CHAINS. 28300017 LTR LR,LR 28400017 BZ CLX09 28500017 ST BR,EVCB-EVBG(LR) CROSS FORWARD CHAIN. 28600017 CLX09 EQU * 28700017 ST LR,EVCF-EVBG(BR) CROSS FORWARD CHAIN. 28800017 LH RA,IQCTS CTS PSEUDO REGISTER 28900017 L RA,0(RA,PR) A(PLF) 29000017 MVI 0(RA),0 RELEASE CONTROL 29100017 CLX02 EQU * 29200017 LR RA,RD A(IOCB) FOR FREEMAIN. 29300017 L RD,BNIO GET A(NEXT IOCB). 29400017 B CLX31 LOOP. 29500017 SPACE 29600017 CLX04 EQU * 29700017 CLX07 EQU * 29800017 TM TFFP,TMEX + FILE EXCLUSIVE.. 29900017 BZ CLX13 NO. 30000017 L RA,TXLV FILE EXCLUSIVE CHAIN. 30100017 USING IHEZXLV,RA 30200017 CLX10 LTR RA,RA IF ZERO 30300017 BZ CLX13 QUIT. 30400017 L R0,TXLZ 30500017 C PR,XPRV CURRENT TASK? 30600017 BNE CLX14 NO. SKIP. 30700017 TM XFLA,XLOK 30800017 BZ CLX15 30900017 LR WR,RA 31000017 MVC DEQF(4),XAL1 MOVE DEQ FLAGS. 31100017 LA RB,XRNM A(R-NAME). 31200017 LA RA,XQNM A(Q-NAME). 31300017 STM RA,RB,DEQA STORE IN DEQ P.LIST. 31400017 LA RA,DEQF POINT AT DEQ P.LIST. 31500017 DEQ ,MF=(E,(1)) $$ DEQ (Q,R,E,0,STEP). 31600017 LR RA,WR 31700017 CLX15 EQU * 31800017 L RF,XCFT GET TASK CHAIN. 31900017 L RH,XCBT 32000017 LTR RF,RF 32100017 BZ CLX11 32200017 ST RH,XCBT-XBEG(RF) CROSS BACKWARD CHAIN. 32300017 CLX11 EQU * 32400017 ST RF,XCFT-XBEG(RH) CROSS FORWARD CHAIN. 32500017 L WR,XCFF GET AND SAVE CHAIN. 32600017 FREEMAIN R,LV=(0),A=(1) FREE THE BLOCK. 32700017 LR RA,WR 32800017 B CLX10 NEXT BLOCK. 32900017 CLX14 EQU * 33000017 L RA,XCFF GET NEXT BLOCK. 33100017 B CLX10 33200017 SPACE 33300017 CLX13 EQU * 33400017 L RF,RFRF RESTORE RF. 33500017 CL001 EQU * YES. 33600017 TM TFHT,TMCC + PREVENT CLOSE? 33700017 BO CLLP3 YES. 33800017 L RA,TEVT GET EVENT CHAIN. 33900017 CLX06 EQU * 34000017 BAL LR,CLEV2 PROCESS EVENT VARIABLE. 34100017 B CLX08 END OF CHAIN. 34200017 * DECHAIN ALONG FILE 34300017 LM LR,BR,EVFF-EVBG(RA) 34400017 LTR LR,LR 34500017 BZ CLE01 34600017 ST BR,EVFB-EVBG(LR) 34700017 CLE01 ST LR,EVFF-EVBG(BR) 34800017 LR R0,LR 34900017 * DECHAIN ALONG TASK 35000017 LM LR,BR,EVCF-EVBG(RA) 35100017 LTR LR,LR IS IT THE LAST.. 35200017 BZ CLE00 YES 35300017 ST BR,EVCB-EVBG(LR) 35400017 CLE00 ST LR,EVCF-EVBG(BR) AND BACK 35500017 LH RA,IQCTS CTS PSEUDO REGISTER 35600017 L RA,0(RA,PR) A(PLF) 35700017 MVI 0(RA),0 RELEASE CONTROL 35800017 LR RA,R0 35900017 B CLX06 36000017 CLX08 EQU * 36100017 CLNID EQU * 36200017 MVC DCBSYNAD+1(3),SYNADM+1 ZERO SYNAD ADDRESS IN DCB. 36300017 TM BRBR,X'02' TEST ENTRY POINT. 36400017 BO CLIP3 BRANCH IF IMPLICIT. 36500017 TM OEOL,MEOL + END OF LIST YET. 36600017 BO CLSEP YES. 36700017 LA RG,12(RG) NO,BUMP P.LIST. 36800017 B CLLP1 36900017 CLSEP EQU * 37000017 OI 0(RF),MEOL / SET END OF P.LIST FLAG. 37100017 L RA,VDAAD 37200017 LA RA,4(RA) A(DAMT CLOSE P.LIST). 37300017 LR RF,RA SAVE POINTER. 37400017 TM BRBR,X'04' TEST IF C ENTRY= NO CLOSE ISSUED 37460001 BO CLAG1 37520001 CLOSE MF=(E,(1)) $$ CLOSE FILES. 37600017 CLAG1 EQU * 37700017 L RG,PARMP A(CLOSE P.LIST). 37800017 TM BRBR,X'02' IMPLICIT CLOSE? 37900017 BO CLIP4 YES. 38000017 LA RA,12(RG) SAVE A(NEXT ENTRY). 38100017 ST RA,PARMP * 38200017 L RD,0(RG) 38300017 LH RC,0(RD) PR OFFSET OF FILE. 38400017 L RC,0(RC,PR) A(DCBAPE). 38500017 CLC TDCB+1(3),1(RF) DCB'S CHECK OUT. 38600017 BE CLFND YES. 38700017 CLAG2 EQU * 38800017 TM 8(RG),MEOL + END OF PL/1 P.LIST? 38900017 BO CLEND YES. 39000017 B CLAG1 NO. 39100017 CLFND EQU * 39200017 TM TFHT,TMCC PREVENT CLOSE FLAG ON? 39300017 BNZ CLAG2 39400017 LH RE,0(RD) GET OFFSET OF P.R. 39500017 ALR RE,PR 39600017 TM TFFP,TMPT SYSPRINT .. 39700017 BZ CLEZO NO 39800017 CLI IFOPE,5 39900017 BL CLEZO 40000017 TS 0(RE) INDICATE CLOSED 40100017 B CLENZ 40200017 CLEZO XC 1(3,RE),1(RE) ZEEO PSEUOREG 40300017 CLENZ EQU * 40400017 L LR,IFOPE 40500017 LTR LR,LR + 2ND RELEASE OCL. 40600017 BZ CLFNC NO. 40700017 LA RC,0(RC) A(FCB). 40800017 LH LR,IQFOP OFFSET OF FCB CHAIN ANCHOR. 40900017 L BR,0(LR,PR) A(1ST FCB). 41000017 LA BR,0(BR) A(FCB HIGHER IN CHAIN). 41100017 CLR BR,RC + FCB'S CHECK. 41200017 BNE CLFN2 NO. 41300017 ALR LR,PR YES, A(ANCHOR POINT). 41400017 MVC 1(3,LR),TFOP+1 RESET CHAIN. 41500017 B CLFNC * 41600017 CLFN2 EQU * 41700017 L LR,TFOP-TBEG(BR) GET A(NEXT FCB). 41800017 LA LR,0(LR) * 41900017 CLR LR,RC + FCB'S CHECK. 42000017 BE CLFN3 YES. 42100017 LR BR,LR 42200017 B CLFN2 42300017 CLFN3 EQU * 42400017 MVC TFOP-TBEG+1(3,BR),TFOP+1 RESET FCB CHAIN. 42500017 CLFNC EQU * 42600017 CLI TFAC,TMBS + BSAM ACCESS METHOD USED. 42700017 BL CLFNE NO. 42800017 L RE,0(RF) 42807001 CLI TFAC,TMQT + IS IT QTAM ACCESS METHOD 42814001 BNE CLNQT * NO, 42821001 TM BRBR,X'02' IS IT IMPLICIT CLOSE 42823001 BO CL100 YES NO FREEMAIN ISSUED 42825001 LH RA,DCBSOWA LENGTH OF BUFFER 42828001 LA RA,12(RA) ADD TERMID LENGTH 42835001 LR R0,RA 42842001 A R0,SUBPL ADD SUBPOOL NUMBER 42849001 L RA,DCBTRMAD A( BUFFER AREA ) 42856001 * 42863001 FREEMAIN R,LV=(0),A=(1) $$ FREE THE AREA 42870001 * 42877001 B CL100 42884001 CLNQT EQU * 42891001 L RD,TLAB GET A(LAST IOCB ALLOCATED). 42900017 LTR RD,RD + DOES IT EXIST. 43000017 BZ CLFNE NO. 43100017 CLFN4 EQU * 43200017 TM BRBR,X'02' + IMPLICIT CLOSE.. 43300017 BO CLFN5 YES. 43400017 TM BERR,BMDB + DUMMY BUFFER LEFT UNFREED. 43500017 BZ CLFN5 NO. 43600017 L RA,BARE YES, FREE IT. 43700017 LH R0,DCBBLKSI * 43800017 A R0,SUBPL * 43900017 FREEMAIN R,LV=(0),A=(1) $$ FREE DUMMY BUFFER. 44000017 CLFN5 EQU * 44100017 BAL LR,CLEVT TEST EVENT VARIABLE 44200017 B CLFN6 44300017 LH RA,IQCTS CTS PSEUDO REGISTER 44400017 L RA,0(RA,PR) A(PLF) 44500017 MVI 0(RA),0 RELEASE CONTROL 44600017 CLFN6 EQU * 44700017 L RD,BPIO GET A(PRIOR IOCB). 44800017 LTR RD,RD + END OF CHAIN YET. 44900017 BNZ CLFN4 NO. 45000017 CLFNE EQU * 45100017 L RE,0(RF) A(DCB) 45200017 TM DCBBUFCB+3,X'01' + BUFFER POOL ALLOCATED. 45300017 BO CL099 NO. 45400017 LR RA,RE 45500017 FREEPOOL (1) $$ FREE BUFFER POOL 45600017 CL099 EQU * 45700017 TM TFDV,TMPA + PAPER TAPE DEVICE. 45800017 BZ CL09A NO. 45900017 CLI TFAC,TMQS + QSAM ACCESS METHOD. 46000017 BE CL09B YES. 46100017 CL09A EQU * 46200017 TM TFTY,TMRC + RECORD I/O. 46300017 BO CL100 YES. 46400017 CL09B EQU * 46500017 B CLNTU 46600017 EJECT 46700017 * DELETE MODULES LOADED AT OPEN TIME. 46800017 SPACE 46900017 CL100 EQU * 47000017 SR RA,RA 47100017 IC RA,TFAC GET ACCESS CODE. 47200017 B *+4(RA) 47300017 B CL120 QSAM. 47400017 B CL130 BDAM. 47500017 B CL140 QISAM 47600017 B CL140 BISAM. 47700017 B CL110 BSAM. 47800017 B CL105 BSAM LOAD 47810001 * B CL102 QTAM 47820001 SPACE 2 47830001 * QTAM 47840001 SPACE 2 47850001 CL102 EQU * 47860001 DELETE EP=IHEITPA $$ DELETE QTAM TRANSMITTER 47870001 B CLNTU 47880001 SPACE 47900017 * BSAM LOAD . 48000017 SPACE 48100017 CL105 EQU * 48150001 DELETE EP=IHEITCA ** DELETE LOAD MODULE. 48200017 B CLNTU 48300017 SPACE 48400017 * BSAM. 48500017 CL110 EQU * 48600017 DELETE EP=IHEITBA ** DELETE LOAD MODULE. 48700017 B CLNTU 48800017 SPACE 48900017 * QSAM. 49000017 SPACE 49100017 CL120 EQU * 49200017 TM TTYP,TMSP + IS IT SPANNED RECORD 31647 49300020 BO CLSP1 49400017 DELETE EP=IHEITGA ** DELETE LOAD MODULE. 49500017 B CLNTU 49600017 * 49700017 * SPANNED QSAM 49800017 * 49900017 CLSP1 EQU * 50000017 TM TFLA,TMOP + OUTPUT 50100017 BO CLSP3 * YES 50200017 * SPANNED QSAM INPUT 50300017 DELETE EP=IHEITKA ** DELETE LOAD MODULE 50400017 TM TFLC,TMPS PRIOR READ SET FLAG SET? 43435 50430056 BO CL121 YES 43435 50460056 B CLNTU 50500017 * SPANNED QSAM OUTPUT 50600017 CLSP3 EQU * 50700017 DELETE EP=IHEITLA ** DELETE LOAD MODULE 50800017 TM TFHT,TMLT PRIOR LOCATE FLAG SET? 43435 50830056 BO CL121 YES 43435 50860056 B CLNTU 50900017 CL121 EQU * 43435 50910056 L RA,TREC LOAD ADDRESS AND LENGTH OF 43435 50920056 LH R0,TLRL PRIOR READ SET/LOCATE AREA 43435 50930056 FREEMAIN R,LV=(0),A=(1) FREE IT 43435 50940056 B CLNTU 43435 50950056 SPACE 51000017 * BDAM. 51100017 SPACE 51200017 CL130 EQU * 51300017 DELETE EP=IHEITJA ** DELETE LOAD MODULE. 51400017 B CL142 51500017 * BISAM. 51600017 CL140 EQU * 51700017 NC TPKA(4),TPKA PREVIOUS KEY.. 51800017 BZ CL141 NO. 51900017 SR R0,R0 52000017 IC R0,TFIO GET SAVED KEYLENGTH 43435 52100056 L RA,TPKA A(PREVIOUS KEY) 52200017 FREEMAIN R,LV=(0),A=(1) FREE IT 52300017 CL141 EQU * 52400017 CLI TFAC,TMQI 52500017 BE CL150 BRANCH IF QISAM. 52600017 TM TFRC,TMVB + V FORMAT INDEXED 52610001 BZ CL148 * NO 52620001 DELETE EP=IHEITOA ** DELETE LOAD MODULE 52630001 B CL142 52640001 CL148 EQU * 52650001 DELETE EP=IHEITHA ** DELETE LOAD MODULE. 52700017 CL142 EQU * 52800017 CL149 EQU * 52860001 LH R0,DCBSMSI LENGTH OF INDEXAREA. 52900017 LTR R0,R0 WAS INDEX AREA USED.. 53000017 BZ CL146 NO. 53100017 L RA,DCBMSHI AREA OF INDEXAREA. 53200017 FREEMAIN R,LV=(0),A=(1) FREE IT. 53300017 CL146 EQU * 53400017 L R0,TBBZ GET LENGTH OF BUBL. 53500017 LR RB,R0 SAVE IT. 53600017 L RD,TLAB A(1ST BUBL). 53700017 CL144 EQU * 53800017 CLI BPIO,X'FF' + IS IOCB ACTIVE 53900017 BNE CL145 * NO, 54000017 BAL LR,CLEVT TEST EVENT VARIABLE 54100017 B CL145 54200017 LH RA,IQCTS CTS PSEUDO REGISTER 54300017 L RA,0(RA,PR) A(PLF) 54400017 MVI 0(RA),0 RELEASE CONTROL 54500017 CL145 EQU * 54600017 L RE,BNIO A(NEXT BUBL). 54700017 LR RA,RD A(BUBL TO BE FREED). 54800017 LR R0,RB AND ITS LENGTH 54900017 FREEMAIN R,LV=(0),A=(1) $$ FREE BUBL. 55000017 LTR RE,RE + FINISH FREEING BUBL'S. 55100017 BZ CLNTU YES. 55200017 LR RD,RE NO. 55300017 B CL144 55400017 * QISAM. 55500017 CL150 EQU * 55600017 TM TFRC,TMVB + V FORMAT INDEXED 55610001 BZ CL151 * NO 55620001 DELETE EP=IHEITNA ** DELETE LOAD MODULE 55630001 B CLNTU 55640001 CL151 EQU * 55650001 DELETE EP=IHEITDA ** DELETE LOAD MODULE. 55700017 CLNTU EQU * 55800017 TM BRBR,X'02' IMPLICIT CLOSE? 55900017 BO CLIP5 YES. 56000017 LH R0,TLEN 56100017 A R0,SUBPL LENGTH OF FCB AND SUBPOOL NO. 56200017 LR RA,RC A(FCB). 56300017 CLI IFOPE,VR17 RELEASE 17+.. 56400017 BL CLNTV NO 56500017 SH RA,X08X ADDRESS FCB APPENDAGE 56600017 AH R0,X08X ADJUST THE LENGTH 56700017 CLNTV EQU * 56800017 FREEMAIN R,LV=(0),A=(1) $$ FREE CORE USED FOR FCB. 56900017 TM 0(RF),MEOL + END OF LIST YET. 57000017 BO CLEND 57100017 LA RF,4(RF) BUMP POINTER. 57200017 B CLAG1 57300017 CLEND EQU * 57400017 L BR,ISAFD 57500017 BALR LR,BR $$ FREE VDA. 57600017 CLI IFOPE,5 RELEASE 17+.. 57700017 BNL CLIK3 NO 57800017 TM BRBR,X'02' IMPLICIT.. 57900017 BNZ CLIK3 YES 58000017 LH RA,IQATV ADDRESS T.V. 58100017 L RA,0(RA,PR) 58200017 LH R0,TVDP(RA) 58300017 SH R0,TVLP(RA) CALCULATE OLD PRIORITY 58400017 CHAP (0) 58500017 CLIK3 EQU * 58600017 L DR,OFDR(DR) RESTORE SSA POINTER. 58700017 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS. 58800017 BR LR X RETURN. 58900017 EJECT 59000017 CLIP1 EQU * 59100017 ST RA,PARMP SAVE A(P.LIST). 59200017 LA RG,8(RA) SAVE ADDRESS OF FIRST FCB. 59300017 L RB,0(RA) GET 4 * FILE COUNT. 59400017 LR RA,RB COPY IT. 59500017 B CLP11 59600017 SPACE 59700017 CLIP2 EQU * 59800017 LA RF,4(RF) BUMP DAMT P.LIST POINTER. 59900017 CLV05 EQU * 60000017 L RC,0(RG) 60100017 LA RC,0(RC) POINT AT AN FCB. 60200017 B CLGER * JOIN CLTA. 60300017 SPACE 60400017 CLIP3 EQU * 60500017 TM 0(RG),X'80' LAST ENTRY? 60600017 BO CLTAI 60700017 LA RG,4(RG) STEP DOWN CLTB CALL. SEQ. 60800017 B CLIP2 60900017 SPACE 61000017 CLIP4 EQU * 61100017 L RC,8(RG) GET A(FCB). 61200017 CLC TDCB+1(3),1(RF) TRY THIS DCB. 61300017 BNE CLIP6 NO. 61400017 TM TFHT,TMCC CLOSE THIS FILE? 61500017 BO CLIP5 NO. 61600017 B CLFNC 61700017 SPACE 61800017 CLIP5 EQU * 61900017 LA RF,4(RF) UPDATE DAMT P.LIST POINTER. 62000017 CLIP6 EQU * 62100017 L RG,PARMP GET POINTER. 62200017 TM 8(RG),X'80' LAST FILE? 62300017 BO CLEND YES. 62400017 LA RG,4(RG) UPDATE CLTB POINTER. 62500017 ST RG,PARMP SAVE IT. 62600017 B CLIP4 62700017 SPACE 62800017 CLIP7 EQU * 62900017 TM 0(RG),X'80' + END OF LIST YET? 63000017 BO CLTAO YES. 63100017 LA RG,4(RG) NEXT FILE. 63200017 B CLV05 63300017 EJECT 63400017 USING IHEZEVT,RA 63500017 CLEVT EQU * 63600017 L RA,BEVN A(EVENT VARIABLE) 63700017 CLEV2 EQU * 63800017 LTR RA,RA + TEST IF ZERO. 63900017 BZ 0(LR) * ZERO RETURN. 64000017 LR R0,RA SAVE RA 64100017 LH RA,IQCTS CTS PSEUDO REGISTER 64200017 L RA,0(RA,PR) A(PLF) 64300017 CLEV1 TS 0(RA) OBTAIN CONTROL 64400017 BM CLEV1 BUT IS BUSY 64500017 LR RA,R0 RESTORE RA 64600017 TM EVF1,EMAC + IS IT ACTIVE.. 64700017 BZ 4(LR) * NO. 64800017 TM EVF2,EMCP + IS IT COMPLETE.. 64900017 BO CLEV3 YES. 65000017 OI EVF2,EMCP NO. MAKE IT COMPLETE. 65100017 NC EVST(2),EVST + STATUS = 0.. 65200017 BNZ CLEV3 NO. 65300017 MVC EVST(2),HONE SET STATUS = 1. 65400017 CLEV3 EQU * 65500017 NI EVF1,255-EMAC SET EVENT INACTIVE. 65600017 B 4(LR) RETURN. 65700017 DROP RA 65800017 EJECT 65900017 SYNADM DC F'1' 66000017 SUBPL DC X'01000000' 66100017 X12X DC H'12' 66200017 X04X DC H'04' 66300017 X80X DC H'80' 66400017 CLCP1 CLC 0(0,BR),0(LR) 66500017 KEYY EQU X'A8' 66600017 X08X DC H'8' 66700017 HONE DC H'1' 66800017 OFEV DC AL2(BEVN-BBEG) HALF-WORD BOUNDARY. 66900017 BLRC EQU X'10' 67000017 SPAN EQU X'48' SPANNED BITS IN DCB. 67100017 XAL1 DC X'FF000000' 67200017 XALV DC X'FF000100' 67300017 TVDP EQU 18 67400017 TVLP EQU 16 67500017 NRRD EQU X'02' 67600017 CLMOVE MVC 0(*-*,RY),0(RA) 67650001 END 67700017 ./ ADD SSI=04011979,SOURCE=1,NAME=IHEDBNA DBN TITLE ' IHEDBN BIT STRING TO ARITHMETIC DIRECTOR *00500013 OS/360 PL/1 LIBRARY' 01000013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 01500013 * 02000013 * STATUS CHANGE LEVEL - 0 02500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DBN000-TSS 02600001 * ----------------------------------------------------DBN000-TSS 02700001 * 03000013 * SIZE 296 BYTES 03500013 * 04000013 * FUNCTION CONVERTS A FIXED OR VARYING LENGTH BIT STRING 04500013 * TO ANY ARITHMETIC DATA TYPE,REAL OR COMPLEX. 05000013 * 05500013 * ENTRY POINT 06000013 * IHEDBNA - 06500013 * RA = A(BIT SDV) 07000013 * RB = A(BIT DED) 07500013 * RC = A(TARGET) 08000013 * RD = A(TARGET DED) 08500013 * 09000013 * INPUT N/A 09500013 * 10000013 * OUTPUT N/A 10500013 * 11000013 * EXTERNAL MODULES 11500013 * IHEDMA - ARITHMETIC CONVERSION DIRECTOR 12000013 * IHEUPA/IHEUPB - ZERO IMAGINARY PART OF COMPLEX 12500013 * TARGET FOR CODED OR NUMERIC TARGETS. 13000013 * 13500013 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 14000013 * ERROR - CALL IHEERRB TO RAISE SIZE ERROR IF 14500013 * STRING CONTAINS MORE THAN THIRTY ONE 15000013 * SIGNIFICANT BITS 15500013 * 16000013 * TABLES/WORK AREA 16500013 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 17000013 * 17500013 * ATTRIBUTES READ ONLY AND REENTRANT 18000013 * 18500013 * PRIVATE MACROS 19000013 * IHELIB,IHEPRV,IHESDR 19500013 * 20000013 * ASSEMBLY REQUIREMENTS 20500013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 21000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 21500013 * 22000013 * NOTES SEE OS/360 PL/1 LIBRARY PLM FOR LIBRARY MODULE 22500013 * CONVENTIONS AND STANDARDS. 23000013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND 23500013 * UPON A PARTICULAR INTERNAL REPRESENTATION OF 24000013 * THE EXTERNAL CHARACTER SET. 24500013 EJECT 25000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DBN001-TSS 25200001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 25500013 PUNCH ' LIBRARY *(IHEDMAA,IHEUPBB,IHEUPAB) /26000013 DBN0000A' 26500013 * ----------------------------------------------------DBN001-TSS 26700001 SPACE 27000013 IHEDBN CSECT 27500013 IHELIB 28000013 IHEZLW2 DSECT 28500013 DS 15D 29000013 WORK EQU IHEZLW2 29500013 IHEDBN CSECT 30000013 ENTRY IHEDBNA 30500013 USING *,RJ 31000013 USING IHEZLCA,WR 31500013 USING IHEZLW2,DR 32000013 IHEDBNA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 32500013 IHESDR LW2,WR UPDATE SAVE AREA POINTER 33000013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 33500013 LR RJ,BR TRANSFER BASE REGISTER 34000013 MVI SWCH,X'00' INITIALISE SWITCH 34500013 SR RH,RH ZERO RESULT 35000013 LR RI,RH REGISTERS 35500013 L RF,0(RA) GET STRING ADDRESS 36000013 LR RG,RF GET BIT 36500013 SLDL RF,3 ADDRESS 37000013 LH R0,6(RA) GET CURRENT LENGTH 37500013 LTR R0,R0 TEST CURRENT LENGTH 38000013 BZ MKFLT BRANCH IF ZERO 38500013 AR RF,R0 CALC END OF STRING ADDRESS 39000013 COMPR CH R0,K056 TEST CURRENT LENGTH 39500013 BH GET56 BRANCH IF GREATER THAN 56 40000013 BAL RE,GETNB GO GET N BITS 40500013 TM SWCH,ZERO TEST SWITCH 41000013 BZ MKFLT BRANCH NOT SET 41500013 SLDA RH,0 TEST N BITS 42000013 BZ RESTR BRANCH IF ALL ZERO 42500013 ERROR IHEPRV ERR,RA,OP=LA 43000013 OI 0(RA),SIZE SET FOR SIZE ERROR 43500013 L BR,ERRB CALL EXECUTION 44000013 BALR LR,BR ERROR PACKAGE 44500013 SR RH,RH ZERO RESULT 45000013 SR RI,RI OF SIZE ERROR 45500013 MKFLT CLI 0(RD),X'8C' TEST FOR FIXED BINARY TARGET. 46000013 BE FIXED 46500013 SRHRI STM RH,RI,STORE STORE COLLECTED BITS 47000013 RESTR MVI STORE,X'4E' SET CHARACTERISTIC 47500013 SWR FA,FA NORMALISE 48000013 AD FA,STORE FLOATING POINT 48500013 STD FA,STORE NUMBER 49000013 LA RA,STORE SET TO CALL 49500013 LA RB,FLTD ARITH CONVERSION 50000013 L BR,DMAA LOAD BRANCH ADDRESS 50500013 BALR LR,BR CALL ARITH.CONVERSION DIRECTOR 51000013 TM 0(RD),X'81' TEST MODE OF TARGET 51500013 BC 12,RSTDR BRANCH NOT COMPLEX INTERNAL 52000013 LR RA,RC SET TARGET 52500013 LR RB,RD PARAMETERS 53000013 L BR,UPAB LOAD BRANCH ADDRESS FOR CODED 53500013 TM 0(RD),CODE TARGET CODED ARITHMETIC 54000013 BO SETLK YES,BRANCH 54500013 L BR,UPBB LOAD BRANCH ADDRESS FOR NUMERIC 55000013 SETLK BALR LR,BR CALL IHEUPA/B TO ZERO IMAG.PART 55500013 RSTDR L DR,OFDR(DR) RESET SAVE AREA POINTER 56000013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 56500013 BR LR RETURN 57000013 GET56 LR RB,R0 SAVE CURRENT LENGTH 57500013 LA R0,56 SET TO GET 56 BITS 58000013 BAL RE,GETNB 58500013 LR R0,RB RESTORE CURRENT LENGTH 59000013 TM SWCH,ZERO TEST SWITCH 59500013 BZ STORF BRANCH NOT SET 60000013 SLDA RH,0 TEST BITS 60500013 BZ DECMT BRANCH IF ALL ZERO 61000013 B ERROR GO TO ERROR 61500013 STORF STM RH,RI,STORE SAVE FIRST 56 BITS 62000013 DECMT SH R0,K056 DECREMENT CURRENT LENGTH 62500013 OI SWCH,ZERO SET SWITCH 63000013 B COMPR LOOP 63500013 GETNB LR RG,RF CONVERT BIT ADDRESS 64000013 SRDL RF,3 TO BYTE ADDDRESS AND OFFSET 64500013 LA RA,0(RG) GET BYTE ADDRESS 65000013 SH RA,K008 MINUS EIGHT 65500013 MVC ALIGN(8),0(RA) ALIGN EIGHT BYTES 66000013 LM RH,RI,ALIGN LOAD EIGHT BYTES 66500013 LR RA,RG CALCULATE 67000013 SRL RA,29 OFFSET 67500013 LCR R0,R0 GET -N 68000013 AR RA,R0 GET -N+OFFSET 68500013 SLDL RH,56(RA) SHIFT 64-(N+(8-OFFSET)) 69000013 LR RA,R0 GET -N THEN SHIFT 69500013 SRDL RH,0(RA) (64-N) TO REMOVE RUBBISH 70000013 LR RF,RG RESTORE BIT ADDRESS 70500013 SLDL RF,3 AND DECREMENT 71000013 AR RF,RA BY N 71500013 BR RE RETURN 72000013 FIXED CLI 2(RD),X'80' TEST FOR FIXED BINARY INTEGER. 72500013 BNE SRHRI 73000013 LR RF,RH MOVE BITS TO OTHER 73500013 LR RG,RI REGISTER PAIR 74000013 SR RE,RE GET PRECISION. 74500013 IC RE,1(RD) 75000013 LCR RE,RE 75500013 SLDL RF,32(RE) SHIFT LEFT 32 - P BITS. 76000013 LTR RF,RF TEST FOR SIZE ERROR 76500013 BNZ SRHRI LET DMA DO THE WORK. 77000013 SRL RG,32(RE) 77500013 TM 0(RD),HWRD TEST DED FOR HALF WORD 77700001 BO FIXH 77900001 ST RG,0(RC) STPRE FULL WORD 78100001 B FIX 78300001 FIXH STH RG,0(RC) STORE HALF WORD 78500001 FIX B RSTDR 78700001 DMAA DC V(IHEDMAA) 79000013 UPBB DC V(IHEUPBB) 79500013 UPAB DC V(IHEUPAB) 80000013 ERRB DC V(IHEERRB) 80500013 K056 DC H'56' 81000013 K008 DC H'7' 81500013 FLTD DC X'9E3500' 82000013 CODE EQU X'08' 82500013 SIZE EQU X'20' 83000013 ZERO EQU X'01' 83500013 ALIGN EQU WORK+72 84000013 STORE EQU ALIGN+8 84500013 SWCH EQU STORE+8 85000013 HWRD EQU X'10' 85200001 END 85500013 ./ ADD SSI=20010251,NAME=IHEDCNA,SOURCE=0 DCN TITLE ' IHEDCN CHARACTER STRING TO ARITHMETIC *00400013 O/S 360 PL/1 LIBRARY' 00800013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 01200013 * 01600013 * STATUS CHANGE LEVEL - 0 02000013 * 02050072 * 5.5 A 890000 KT 62583 02100072 * 5.5 C 780000-800000,916000-920000 KT 62583 02150072 *1412 492000 772000 18357 02200017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN000-TSS 02260001 * ----------------------------------------------------DCN000-TSS 02320001 * 02400013 * SIZE 704 BYTES 02800013 * 03200013 * FUNCTION CONVERTS A FIXED OR VARYING LENGTH CHARACTER 03600013 * STRING TO ANY ARITHMETIC DATA TYPE,REAL OR COMLEX 04000013 * 04400013 * ENTRY POINTS 04800013 * IHEDCNA - INITIALISE ON SOURCE INFORMATION 05200013 * AND THEN CONVERT 05600013 * RA = A(CHARACTER SDV) 06000013 * RB = A(CHARACTER DED) 06400013 * RC = A(TARGET) 06800013 * RD = A(TARGET DED) 07200013 * IHEDCNB - CONVERSION ONLY,ARGUMENTS AS FOR IHEDCNA 07600013 * 08000013 * INPUT N/A 08400013 * 08800013 * OUTPUT N/A 09200013 * 09600013 * EXTERNAL MODULES 10000013 * IHEDMA - ARITHMETIC CONVERSION DIRECTOR 10400013 * IHEUPA/IHEUPB - ZERO REAL OR IMAGINARY PART OF 10800013 * CODED OR NUMERIC TARGET RESPECTIVELY. 11200013 * 11600013 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 12000013 * ERROR - CALL IHEERRB TO RAISE CONVERSION ERROR 12400013 * STRING DOES NOT CONTAIN VALID ARITHMETIC 12800013 * CONSTANT OR COMPLEX EXPRESSION 13200013 * 13600013 * TABLES/WORK AREA 14000013 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 14400013 * 14800013 * ATTRIBUTES READ ONLY AND REENTRANT 15200013 * 15600013 * PRIVATE MACROS 16000013 * IHELIB,IHEPRV,IHESDR 16400013 * 16800013 * ASSEMBLY REQUIREMENTS 17200013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 17600013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 18000013 * 18400013 * NOTES SEE OS/360 PL/1 LIBRARY PLM FOR DESCRIPTION OF LIBRARY 18800013 * CONVENTIONS AND STANDARDS 19200013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 19600013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 20000013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 20400013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 20800013 * CONSTANTS,BY REASSEMBLY,WILL RESULT IN A CORRECT MODULE 21200013 * FOR THE NEW DEFINITIONS. 21600013 EJECT 22000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN001-TSS 22200001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 22400013 PUNCH ' LIBRARY *(IHEDMAA,IHEUPAA,IHEUPBA,IHEUPBB,IHEUPAB,IHEV/22800013 QBA) DCN0000A' 23200013 * ----------------------------------------------------DCN001-TSS 23400001 SPACE 23600013 IHEDCN CSECT 24000013 IHELIB 24400013 IHEZLW2 DSECT 24800013 DS 15D 25200013 WORK EQU IHEZLW2 25600013 IHEDCN CSECT 26000013 ENTRY IHEDCNA 26400013 ENTRY IHEDCNB 26800013 USING IHEZLCA,WR 27200013 USING IHEZLW2,DR 27600013 IHEDCNA NOPR 0 28000013 IHEDCNB STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 28400013 BALR RJ,0 TRANSFER BASE REGISTER 28800013 USING *,RJ 29200013 TM OFBR+3(DR),X'02' TEST ENTRY POINT 29600013 IHESDR LW2,WR GET WORKSPACE ADDRESS 30000013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS. 30400013 BO GETSA BRANCH IF SECOND ENTRY POINT 30800013 MVC WOFD(8),0(RA) SAVE ON SOURCE INFORMATION 31200013 LA LR,RETRY STORE RETRY ENTRY POINT AND 31600013 STM DR,LR,WCNV SAVE AREA POINTER IN LCA 32000013 GETSA L RB,0(RA) GET STRING ADDRESS. 32400013 LA RB,0(RB) ZERO TOP BYTE. 32800013 LH RE,6(RA) GET CURRENT LENGTH 33200013 NI WSWB,255-3 25917 33400019 LTR RE,RE TEST FOR NULL STRING. 33600013 BZ NULLS 34000013 AR RE,RB FIND END OF 34400013 BCTR RE,0 STRING 34800013 ST RB,WOCH SET ERROR ADDRESS 35200013 IHEPRV ERR,RI,OP=LA GET ADDRESS OF IHEQERR. 36000013 MVI 1(RI),CFOR 36400013 LOOP1 CLI 0(RB),C' ' TEST FOR LEADING BLANK. 36800013 BNE TRAIL 37200013 CR RB,RE ALL BLANK FIELD? 37600013 BE ERROR 38000013 LA RB,1(RB) SCAN FROM LEFT. 38400013 B LOOP1 38800013 SPACE 39200013 TRAIL CLI 0(RE),C' ' TEST FOR TRAILING BLANK. 39600013 BNE SQEZD 40000013 BCT RE,TRAIL 40400013 SPACE 40800013 SQEZD CLI 0(RE),C'I' COMPLEX SOURCE? 41200013 BE CMPLX 41600013 LA RH,CTEST SET FOR REAL SOURCE. 42000013 PARTY CLI 0(RE),C'B' BINARY SOURCE? 42400013 BE BINRY 42800013 SPACE 43200013 TM 0(RD),X'88' TEST FOR C.A.D. TARGET 43600013 BO QPOSS 44000013 QGONE LR RA,RB SOURCE ADDRESS. 44400013 LA RB,EDED SOURCE DED. 44800013 SR RE,RA 45200013 LA RE,1(RE) 45600013 STH RE,PWRK W IN FED 46000013 MVI PWRK+2,0 D IN FED 46400013 LA RE,PWRK ADDRESS OF FED 46800013 ST RE,WFED 47200013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN999-TSS 47400056 DMACL L BR,DMAA CALL IHEDMAA 47600013 * ----------------------------------------------------DCN999-TSS 47800056 BALR LR,BR 48000013 BR RH 48400013 SPACE 48800013 CTEST TM 0(RD),CPLX COMPLEX TARGET? 18357 49200017 BO CTARG 49600013 ENDRT L DR,OFDR(DR) RESET SAVE AREA POINTER 50000013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 50400013 BR LR RETURN TO CALLER. 50800013 SPACE 51200013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN998-TSS 51400056 QPOSS L BR,VQBA IS VQB PRESENT? 51600013 * ----------------------------------------------------DCN998-TSS 51800056 LTR BR,BR 52000013 BZ QGONE NO. USE DMA 52400013 LH BR,0(BR) GET TOP TWO BYTES OF VCON. 52420001 CH BR,XFER + IS IT A TRANSFER VECTOR. 52440001 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN989-TSS 52450056 L BR,VQBA GET VCON ONCE AGAIN. 52460001 * ----------------------------------------------------DCN989-TSS 52470056 BNE SHRLIB * NO. MUST BE A(CONV MODULE). 52480001 LR R0,RA SAVE REGISTER ONE. 52500001 LH LR,2(BR) STEP DOWN TRANSFER 52520001 LH RA,6(BR) VECTOR UNTILL THE 52540001 L BR,0(LR,PR) REAL VCON IS 52560001 L BR,0(RA,BR) LOADED INTO BR. 52580001 LR RA,R0 RESTORE REGISTER ONE. 52600001 LTR BR,BR + IS THE MODULE PRESENT. 52620001 BZ QGONE * NO. USE IHEDMA. 52640001 SHRLIB EQU * 52660001 LR RA,RB FIRST CHARACTER. 52800013 LR RB,RE LAST CHARACTER. 53200013 BALR LR,BR CALL CHARACTER TO CAD CONV. 53600013 BR RH 54000013 SPACE 54400013 RETRY L RA,OFDR(DR) RESTORE ORIGINAL 54800013 LM RA,RD,OFRA(RA) PARAMETER REGISTERS 55200013 B GETSA AND GO TRY AGAIN 55600013 SPACE 56000013 NULLS LA RB,NULL 56400013 LR RE,RB POINT AT DUMMY SOURCE OF ZERO. 56800013 B SQEZD 57200013 SPACE 57600013 BINRY BCTR RE,0 58000013 ST RB,PWRK+16 STORE ENDS OF CONSTANT. 58400013 ST RE,PWRK+20 58800013 LA RB,PWRK+16 59200013 ST RB,WCNP SET POINTER TO ADDRESS PAIR. 59600013 LA RB,BDED DED OF CONSTANT. 60000013 B DMACL 60400013 SPACE 60800013 CTARG LR RA,RC 61200013 LR RB,RD MOVE TARGET PARAMETERS. 61600013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN991-TSS 61800056 L BR,UPAB 62000013 * ----------------------------------------------------DCN991-TSS 62200056 TM 0(RD),X'88' TEST FOR C.A.D. TARGET. 62400013 BO UPCAL 62800013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN997-TSS 63000056 L BR,UPBB ZERO IMAGINARY PART. 63200013 * ----------------------------------------------------DCN997-TSS 63400056 UPCAL BALR LR,BR 63600013 B ENDRT 64000013 SPACE 64400013 ERROR OI 0(RI),CONV SET CONVERSION ERROR. 64800013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN996-TSS 65000056 L BR,VERB CALL ERROR PACKAGE. 65200013 * ----------------------------------------------------DCN996-TSS 65400056 BALR LR,BR 65600013 B NULLS 66000013 SPACE 66400013 CMPLX ST RB,WOCH 66800013 CR RB,RE TEST FOR SINGLE 'I' 67200013 BE ERROR 67600013 BCTR RE,0 SCAN BACK FROM 'I'. 68000013 LR RF,RE SAVE END OF IMAG PART. 68400013 CLOOP CR RE,RB IS SOURCE ALL IMAG? 68800013 BE PIMAG 69200013 CLI 0(RE),C'+' LOOK 69600013 BE SIGN1 FOR 70000013 CLI 0(RE),C'-' SIGN. 70400013 BE SIGN1 70800013 BCT RE,CLOOP 71200013 SPACE 71600013 PIMAG LR RG,RB SAVE BEGINNING OF IMAG PART. 72000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN995-TSS 72200056 L BR,UPAA SET UP CALL TO 72400013 * ----------------------------------------------------DCN995-TSS 72600056 TM 0(RD),X'88' ZERO THE REAL PART 72800013 BO CALUP OF THE TARGET. 73200013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN994-TSS 73400056 L BR,UPBA 73600013 * ----------------------------------------------------DCN994-TSS 73800056 CALUP LR RA,RC MOVE 74000013 LR RB,RD PARAMETERS. 74400013 BALR LR,BR CALL UPXX. 74800013 L RC,WRCD RETRIEVE ADDRESS OF IMAG PART. 75200013 LR RE,RF GET ENDS OF IMAG PART. 75600013 LR RB,RG 76000013 LA RH,ENDRT 76400013 MVI 1(RI),CFOR SET CONVERSION CODE 76800013 TM 0(RD),CPLX COMPLEX TARGET? 18357 77200017 BO PARTY YES. 77600013 *********************************************************************** 78000072 * IF THE TARGET IS NOT COMPLEX WE MUST STILL CARRY ON 62583 78100072 * WITH THE ASSIGNMENT AS WE MAY WISH TO RAISE CONVERSION 62583 78200072 * THOUGH WE MUST BE CAREFUL NOT TO RAISE SIZE DURING 62583 78300072 * THE ASSIGNMENT. WE DO THIS BY POINTING AT A DUMMY 62583 78400072 * TARGET AREA AND SUPPLYING A SUITABLE DUMMY DED TO THE 62583 78500072 * CONVERSION ROUTINES. 62583 78600072 LA LR,7 * INITIALIZE LOOP COUNT 62583 78700072 LA RC,FXDDED * POINT AT 1ST DUMMY DED 62583 78800072 IC RD,0(RD) * PICK UP TARGET DED FLAG 62583 78900072 N RD,FULL9E * TURN OFF UNNECESSARY BITS 2583 79000072 SR BR,BR * INITIALIZE COMPERAND 62583 79100072 LOOP2 IC BR,0(RC) * SEARCH FOR MATCHING 62583 79200072 CR BR,RD * DED FLAG BYTE, ON MATCH 62583 79300072 BE LOOP2END * POINT RD AT EQUIVALENT 62583 79400072 LA RC,3(RC) * MAX PRECISION DED 62583 79500072 BCT LR,LOOP2 * NO MATCH , TRY NEXT DED 62583 79600072 * IF WE REACH THIS POINT WEVE FAILED TO DETERMINE 62583 79610072 * A VALID TARGET TYPE SO WE DEFAULT TO FIXED DEC 62583 79620072 * IF THE SOURCE IS NOT BINARY, ELSE DEFAULT TO FLOAT BIN 62583 79630072 LA RC,FXDDED * POINT AT FIXED DEC DED 62583 79640072 CLI 0(RE),C'B' * TEST FOR BINARY SOURCE 62583 79650072 BNE LOOP2END 62583 79660072 LA RC,FLBDEDL * POINT AT FLOAT BIN DED 62583 79670072 LOOP2END LR RD,RC * 62583 79700072 LA RC,PWRK+8 * POINT RC AT DUMMY TARGET 62583 79800072 B PARTY * GO TRY CONVERSION 62583 79900072 *********************************************************************** 80000072 SPACE 80400013 SIGN1 LR RG,RE SAVE ADDRESS 80800013 BCTR RE,0 SCAN BACK 81200013 CLI 0(RE),C'E' TEST FOR 'E' 81600013 BE CLOOP GO TO SCAN SOME MORE. 82000013 LA RH,REALP SET REAL PART OF COMPLEX. 82400013 B PARTY GO TO CONVERT. 82800013 SPACE 83200013 REALP OI WSWA,UPDO SET UPDATE ONLY SWITCH. 83600013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN993-TSS 83800056 L BR,UPAB 84000013 * ----------------------------------------------------DCN993-TSS 84200056 TM 0(RD),X'88' 84400013 BO CALUP 84800013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN990-TSS 85000056 L BR,UPBB 85200013 * ----------------------------------------------------DCN990-TSS 85400056 B CALUP 85600013 SPACE 86000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DCN992-TSS 86200056 DMAA DC V(IHEDMAA) 86400013 VQBA DC V(IHEVQBA) 86800013 VERB DC V(IHEERRB) 87200013 UPAB DC V(IHEUPAB) 87600013 UPBB DC V(IHEUPBB) 88000013 UPAA DC V(IHEUPAA) 88400013 UPBA DC V(IHEUPBA) 88800013 * ----------------------------------------------------DCN992-TSS 89000056 FULL9E DC F'158' * X'0000009E' USED AS MASK 62583 89100072 PWRK EQU WORK+72 89200013 UPDO EQU 4 89600013 CONV EQU X'40' 90000013 CFOR EQU 4 90400013 CPLX EQU X'81' 18357 90600017 BDED DC X'CC' 90800013 EDED DC X'CA' 91200013 *********************************************************************** 91600072 * THE FOLLOWING FOUR DECLARATIONS MUST NOT BE MOVED 91670072 * THEY ARE MAXIMUM PRESICION DEDS FOR THE VARIOS DATA TYPES 2583 91740072 FXDDED DC X'880F80' * FIXED DECIMAL 62583 91810072 FLDDEDS DC X'8A0680' * SHORT FLOAT DECIMAL 62583 91880072 FXBDED DC X'8C1F80' * FIXED BINARY 62583 91950072 FLBDEDS DC X'8E1580' * SHORT FLOAT BINARY 62583 92020072 FLDDEDL DC X'9A1080' * LONG FLOAT DECIMAL 62583 92090072 FXBDEDS DC X'9C0F80' * HALFWORD FIX BIN 62583 92120072 FLBDEDL DC X'9E3580' * LONG FLOAT BINARY 62583 92160072 * 92230072 *********************************************************************** 92300072 NULL DC C'0' 92400013 DS 0H 92500001 XFER DC X'58FC' 92600001 END 92800013 ./ ADD SSI=21400051,NAME=IHEDDIA,SOURCE=0 DDI TITLE ' IHEDDI DATA DIRECTED INPUT /00100013 OS/360 PL/I LIBRARY' 00200013 * VERSION FOURTH VERSION OF F-LEVEL COMPILER 00300015 * 00400013 * STATUS CHANGE LEVEL - 0 00500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI000-TSS 00510001 * ----------------------------------------------------DDI000-TSS 00520001 *3219 208000,210000 16776 00550017 *3219 18041 00570017 * 00574001 *APARS FIXED 00578001 * 00582001 * 21183 00586001 * 22459 00590001 * R21.6 45929 A136500,A146500,A196000 CAS 45929 00590856 * 45929 A291000,A494000,A494600 CAS 45929 00591656 *A285600 SRC 45925 00592456 *D288000 SRC 45925 00593256 * 00594001 * 00600013 * SIZE 1096 BYTES. 00700013 * 00800013 * FUNCTION 00900013 * 1)READ AN ITEM FROM THE SPECIFIED INPUT STREAM ACCORDING 01000013 * TO THE RULES SPECIFIED FOR DATA DIRECTED INPUT. IF THE 01100013 * ITEM SPANS MORE THAN ONE RECORD, THEN THE INFORMATION IN 01200013 * EACH RECORD IS STACKED BY THE AQUISITION OF VDA'S UNTIL 01300013 * THE ITEM DELIMITER/TRANSMISSION TERMINATOR IS FOUND. THE 01400013 * ITEM IS THEN CONCATENATED INTO A SINGLE VDA FOR ANALYSIS 01500013 * THE ITEM IS SCANNED AS FOLLOWS - 01600013 * A) ANY LEADING BLANKS ARE IGNORED. 01700013 * B) A SEARCH IS MADE FOR AN EQUATE SIGN OR A LEFT 01800013 * PARENTHESIS. 01900013 * C) IF AN EQUATE SIGN IS FOUND THE INPUT CONTAINS A 02000013 * SCALAR ITEM AND CONTROL PASSES TO D). 02100013 * IF A LEFT PARENTHESIS IS FOUND THE INPUT CONTAINS 02200013 * AN ARRAY ITEM AND SCANNING IS CONTINUED UNTIL AN 02300013 * EQUATE SIGN IS FOUND. 02400013 * D) LIST DIRECTED INPUT MODULE IS CALLED TO SCAN THE 02500013 * VALUE PART, ENTERING AT IHELDIC. 02600013 * 02700013 * 2)SEARCH SYMBOL TABLE FOR A NAME THE SAME AS THAT JUST 02800013 * SCANNED. IF THERE IS NO SUCH NAME THIS IS AN ERROR. 02900013 * THE SEARCH IS PERFORMED EITHER BY - 03000013 * A) SEARCHING THE SPECIFIED ENTRIES IN THE SYMBOL TABLE 03100013 * (ENTRY POINT IHEDDIA). 03200013 * B) SEARCHING THE WHOLE OF THE SYMBOL TABLE KNOWN AT 03300013 * THIS POINT (ENTRY POINT IHEDDIB). 03400013 * 03500013 * 3)CHECK THAT THE DIMENSIONALITY IS CORRECT - 03600013 * A) IF THE ENTRY IS FOR A SCALAR THEN IF SUBSCRIPTS 03700013 * APPEARED ON THE INPUT STREAM THIS IS AN ERROR. 03800013 * B) IF THE ENTRY IS FOR AN ARRAY THEN IF NO SUBSCRIPTS 03900013 * APPEARED ON THE INPUT STREAM THIS IS AN ERROR. 04000013 * OTHERWISE IHEDDJ IS CALLED TO CHECK THE SUBSCRIPTS OF 04100013 * THE INPUT ITEM, AND ADDRESS THE SPECIFIED ELEMENT OF THE 04200013 * ARRAY. 04300013 * 04400013 * 4) ALL THINGS BEING EQUAL ASSIGN THE VALUE TO THE 04500013 * INTERNAL VARIABLE USING LIST DIRECTED INPUT (ENTRY 04600013 * POINT IHELDID). 04700013 * 04800013 * 5) IF THE TRANSMISSION TERMINATOR IS FOUND RETURN TO 04900013 * CALLER. OTHERWISE REPEAT PROCESSING FROM 1). 05000013 EJECT 05100013 * ENTRY POINTS 05200013 * IHEDDIA 05300013 * RA = A(PLIST) 05400013 * PLIST = A(SYMBOL TABLE ENTRY FOR SPECIFIED VARIABLE) 05500013 * ........ 05600013 * IHEDDIB 05700013 * PLIST = A(SYMTAB CHAIN) THAT IS THE SYMBOL TABLE 05800013 * OF VARIABLES KNOWN AT THIS POINT. 05900013 * 06000013 * INPUT 06100013 * CURRENT FILE PSEUDO-REGISTER (IHEQCFL). 06200013 * 06300013 * OUTPUT 06400013 * ASSIGNMENT OF ITEM(S) TO INTERNAL VARIABLE(S). 06500013 * 06600013 * EXTERNAL MODULES 06700013 * IHELDI - 1)SCAN VALUE PART OF INPUT ITEM AND 06800013 * 2)ASSIGN VALUE TO INTERNAL VARIABLE. 06900013 * IHEDDJ - CHECK SUBSCRIPTS AND COMPUTE ELEMENT ADDRESS. 07000013 * IHEIOF - ADDRESS INPUT STREAM. 07100013 * IHESAD - GET VDA'S AS NECESSARY. 07200013 * IHESAF - FREE THOSE VDA'S GOTTEN IN THIS PASS. 07300013 * IHEERR - EXECUTION ERROR PACKAGE 07400013 * 07500013 * EXITS NORMAL 07600013 * RETURN VIA LINK REGISTER 07700013 * ERROR 07800013 * 1. 'NAME' 07900013 * UNRECOGNISED NAME ON INPUT STREAM. 08000013 * IF CONTROL IS RETURNED TO THIS MODULE 08100013 * THE ITEM IS IGNORED. 08200013 * 2. 'GET/PUT STRING SIZE EXCEEDED' 08300013 * AN ATTEMPT 08400013 * WAS MADE TO GO PAST THE END OF THE SOURCE 08500013 * STRING. 08600013 * 3. 'INVALID ARRAY DATUM' 08700013 * THE DIMENSIONALITY OF THE 08800013 * INPUT ITEM IS NOT THE SAME AS THE INTERNAL 08900013 * VARIABLE. 09000013 * NOTE - IF CONTROL IS RETURNED TO THIS MODULE AFTER 09100013 * END OF FILE CONDITION HAS BEEN RAISED RETURN IS 09200013 * VIA ADDRESS IN SECOND WORD OF IHEQCFL. 09300013 * 09400013 * TABLES/WORK AREA 09500013 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF THE 09600013 * SYMBOL TABLE AND FILE CONTROL BLOCK. 09700013 * 09800013 * ATTRIBUTES READ ONLY AND REENTRANT 09900013 EJECT 10000013 * PRIVATE MACROS 10100013 * IHELIB,IHEPRV,IHESDR,IHEZAP 10200013 * 10300013 * ASSEMBLY REQUIREMENTS 10400013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 10500013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 10600013 * 10700013 * NOTES 10800013 * SEE OS/360 PL/I LIBRARY PLM FOR DESCRIPTION OF LIBRARY 10900013 * CONVENTIONS AND STANDARDS. 11000013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 11100013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 11200013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 11300013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 11400013 * CONSTANTS, BY REASSEMBLY, WILL RESULT IN A CORRECT 11500013 * MODULE FOR THE NEW DEFINITIONS. 11600013 EJECT 11700013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI001-TSS 11750001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 11800013 PUNCH ' LIBRARY *(IHEDDJA) /11900013 DDI0000A' 12000013 * ----------------------------------------------------DDI001-TSS 12050001 SPACE 12100013 IHEDDI CSECT 12200013 IHELIB 12300013 IHEZAP 12400013 DDISAVE DSECT 12500013 DS 18F 12600001 WPFL DS 0B 12700013 WPRA DS A 12800013 TEMP DS 2D 12850015 WSSS DS 2A 12900013 WNAM DS 0A TWO WORDS. 13000013 DS A 13100013 WADD DS A SECOND WORD OF WNAM. 13200013 IVDA DS H 13300013 DS B 13400013 WSDS DS 2A 13500013 WPDV DS 2A 13600013 WADF DS 2F 19644 13650017 WNGW DS B FLAG BYTE NAME VDA CAS 45929 13660056 DS 3B SPARE CAS 45929 13670056 LSAV EQU *-DDISAVE 13700013 SPACE 2 13800013 PWR EQU WR 13900013 STRN EQU X'80' 14000013 PERD EQU B'01000000' 14100013 BLNK EQU B'10000000' 14200013 NTRY EQU B'00000010' 14300013 LBLK EQU B'00000001' 14400013 NTRF EQU B'00000110' 14500013 EOFF EQU B'00001000' 14600013 INVL EQU B'00010000' 14650001 * WNGW CAS 45929 14660056 FNGT EQU X'80' NAME VDA OBTAINED CAS 45929 14670056 CURL EQU 6 14700013 TERM EQU 1 14800013 DEOF EQU 1 14900013 ONCH EQU X'48' 15000013 ERR1 EQU X'B800' END OF FILE 15030015 ERR2 EQU X'0012' UNEXPECTED END OF FILE 15060015 SPACE 2 15100013 * MAP OF SYMBOL TABLE ENTRY AND FLAGS. 15200013 SPACE 15300013 SYMTABF DSECT 15400013 SPTR DS A ADDRESS OF NEXT ENTRY/0 15500013 SLEN DS X LENGTH OF VARIABLE NAME. 15600013 SNAM DS 255C VARIABLE NAME 15700013 SPACE 15800013 SYMTABE DSECT 15900013 SSUB DS 0X DIMENSIONALITY. 16000013 SDED DS A ADDRESS OF DED. 16100013 SFLG DS 0B FLAG BOX. 16200013 SADD DS A ADDRESS/OFFSET VARIABLE/DV. 16300013 SPRO DS H OFFSET TO DISPLAY/ANCHOR IN PRV 16400013 SPACE 16500013 CLSS EQU B'00000011' STORAGE CLASS. 16600013 NSTC EQU X'01' 16700013 TCFL EQU X'04' XMIT STACK FLAG 16800013 CHCK EQU B'01000000' ON 'CHECK' FOR VARIABLE. 16900013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI002-TSS 16930021 * ----------------------------------------------------DDI002-TSS 16960021 EJECT 17000013 IHEDDI CSECT 17100013 ENTRY IHEDDIA,IHEDDIB 17200013 IHEDDIA NOPR 0 . ENTRY FOR RESTRICTED READ. 17300013 IHEDDIB STM LR,PWR,OFLR(DR) . ENTRY FOR UNRESTRICTED READ. 17400013 BALR PWR-1,0 17500013 USING *,PWR-1 17600013 LR RD,DR 17700013 IHESDR LW4 UPDATE DR TO PGM SAVE AREA. 17800013 USING DDISAVE,DR 17900013 LR RC,RA 18000013 LR RF,BR 18100013 LA R0,LSAV+8 18200013 IHEPRV VDA,BR $$ GET VDA FOR SA AND WORKAREA 18300015 BALR LR,BR 18400013 ST RD,OFDR+8(RA) 18500013 LA DR,8(RA) 18600013 MVI 0(DR),X'61' 18700013 ST RC,WPRA SAVE PLIST POINTER. 18800013 STC RF,WPFL / SET FLAGS FOR ENTRY POINT. 18900013 IHEPRV LCA ADDRESS LIB COMMUNICATIONS AREA 19000013 USING IHEZLCA,PWR 19100013 IHEPRV CFL,RF 19200013 USING IHEZDCL,RF 19300013 LH RF,DPRO 19400013 L RF,0(RF,PR) ADDRESS CURRENT FILE FCB. 19500013 USING IHEZAPE,RF 19600013 MVI WNGW,00 SET NO NAME VDA CAS 45929 19610056 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI003-TSS 19630021 * ----------------------------------------------------DDI003-TSS 19660021 SPACE 19700013 * BEGIN PROCESSING AN ITEM. 19800013 SPACE 19900013 DD000 LA RH,DD010 RETURN ADDRESS 20000013 TM TFLX,TMEF + END FILE ALREADY ENCOUNTERED 20030015 BO DIDOF ** YES,RAISE ENDFILE CONDITION 20060015 NI IVDA+2,255-EOFF 18041 20070017 OI WPFL,LBLK+PERD+BLNK 20080015 SR BR,BR 16776 20086017 STH BR,IVDA 16776 20092017 NI TFLX,255-TMIT-TMLC / UNSET TMIT AND TMLC FLAGS. 20100013 IHEPRV CFL,BR,OP=LA 20200013 NI 4(BR),255-TCFL UNSET XMIT FLAG 20300013 LH RD,TREM LENGTH OF BUFFER LEFT. 20400013 LTR RD,RD ANY BYTES LEFT.. 20500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI004-TSS 20550021 BZ DDGET $ NO GET ANOTHER BUFFER. 20600013 B DDSET $ YES SET UP LOOP PARAMETERS. 20700013 * ----------------------------------------------------DDI004-TSS 20800021 DD010 EQU * 16776 20900017 DD020 CLI 0(RC),C' ' TEST FOR LEADING BLANK. 21100013 BNE DD030 NO. 21200013 BAL RH,DDNXT $ YES GET NEXT CHARACTER. 21300013 B DD020 FLUSHING LEADING BLANKS. 21400013 SPACE 21500013 DD030 NI WPFL,255-LBLK-INVL / UNSET LEADING BLANK SWITCH 21560001 * AND INVALID FIELD FLAG. 22459 21620001 CLI 0(RC),C',' TEST FOR COMMA 21700013 BE DDNUL YES NULL FIELD. 21800013 CLI 0(RC),C';' TEST FOR SEMI-COLON 21900013 BE DDNLT YES NULL AND END OF INPUT. 22000013 ST RC,WSDS SET BUFFER SDV TO FIRST NON- 22100013 ST RE,WSDS+4 BLANK AND LENGTH FROM IT. 22200013 ST RC,TCBA SET BUFFER POINTERS TO 22300013 STH RE,TREM BEGINNING OF ITEM. 22400013 ST RI,WSSS+4 SET SUBSCRIPT FIELD LENGTH ZERO 22500013 ST RI,WOFD+4 SET LENGTH OF FIELD TO ZERO. 22600013 ST RC,WOFD ADDRESS OF FIELD 22700013 DD040 AR RI,RD INCREMENT FIELD COUNT. 22800013 CLI 0(RC),C'=' TEST FOR EQUATE SIGN. 22900013 BE DD080 YES. 23000013 CLI 0(RC),C'(' TEST FOR LEFT PARENTHESIS. 23100013 BE DD050 YES. 23200013 BAL RH,DDNXT $ GET NEXT CHARACTER. 23300013 B DD040 CONTINUE TO SCAN NAME. 23400013 SPACE 23500013 DD050 LR BR,RI 23600013 AH BR,WOFD+CURL 23700013 ST BR,WNAM+4 SET LENGTH OF NAME FIELD. 23800013 DD060 BAL RH,DDNXT GET NEXT CHAR 22459 23830001 AR RI,RD UP COUNT BY ONE 22459 23860001 CLI 0(RC),C')' IS IT BRACKET 22459 23890001 BNE DD060 NO. SEARCH ON 22459 23920001 DD061 BAL RH,DDNXT GET NEXT CHAR 22459 23950001 AR RI,RD UP COUNT BY ONE 22459 23980001 CLI 0(RC),C'=' IS IT EQUATE 22459 24010001 BE DD070 YES. GOOD 22459 24040001 CLI 0(RC),C' ' NO. IS IT BLANK 22459 24070001 BE DD061 YES. SEARCH ON 22459 24100001 OI WPFL,INVL NO. INVALID CHAR 22459 24130001 B DD061 SEARCH ON 22459 24160001 DD070 LR BR,RI 24300013 AH BR,WOFD+CURL 24400013 SH BR,WNAM+CURL 24500013 BCTR BR,0 24600013 ST BR,WSSS+4 SET LENGTH OF SUBSCRIPTS FIELD. 24700013 B DD090 24800013 SPACE 24900013 DD080 LR BR,RI 25000013 AH BR,WOFD+CURL 25100013 ST BR,WNAM+4 SET LENGTH OF NAME FIELD. 25200013 SPACE 25300013 * 'FLUSH' BLANKS BETWEEN EQUATE SIGN AND VALUE FIELD. 25400013 SPACE 25500013 DD090 BAL RH,DDNXT $ GET NEXT CHARACTER. 25600013 AR RI,RD 25700013 CLI 0(RC),C' ' TEST FOR BALNK. 25800013 BE DD090 YES. 25900013 SPACE 26000013 BCTR RI,0 NO, END OF 'FLUSH'. 26100013 STH RI,WSDS+4 PART OF NAME STILL IN BUFFER. 26200013 AH RI,WOFD+CURL TOTAL LENGTH OF NAME. 26300013 ST RI,WODF+4 26400013 LA RA,IVDA 26500013 LA RB,WSDS 26600013 OI WPFL,TERM 26700013 MVC WADF(8),WODF 19644 26750017 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI999-TSS 26770000 L BR,VLDIC $$ CALL LDI TO SCAN VALUE FIELD. 26800013 * ----------------------------------------------------DDI999-TSS 26850000 BALR LR,BR 26900013 MVC WODF(8),WADF 19644 26950017 B *+4(BR) BR 27000013 NI WPFL,255-TERM /0 ITEM FOUND BUT NOT THE LAST. 27100013 B DNEOF 4 LAST ITEM FOUND. 27200013 B DIEOF 8 END OF FILE BEFORE END OF FIELD 27300013 SPACE 27400013 DNEOF NI IVDA+2,255-NTRF / CLEAR ENTRY FLAGS. 27500013 LM RB,RC,WOFD SDV FOR DATAFIELD. 27600013 ST RB,WNAM SET ADDRESS OF NAME FIELD. 27700013 AH RB,WODF+CURL 27800013 SH RC,WODF+CURL 27900013 MVC WODF(8),WOFD 28000013 STM RB,RC,WOFD SDV FOR SOURCEFIELD. 28100013 LM RB,RC,WNAM 28200013 LR BR,RB 28300013 AR BR,RC ADDRESS OF SUBS FIELD IF ANY. 28400013 ST BR,WSSS 28500013 TM WPFL,INVL + INVALID FIELD. 22459 28530001 BO ERROR YES RAISE NAME. 22459 28560001 BCTR RC,0 45925 28580056 LTR RC,RC WAS NAME FIELD OMITTED.. 28600013 BZ ERROR YES RAISE 'NAME' CONDITION 28700013 LA R0,9(RC) 28900013 IHEPRV VDA,BR $$ GET CORE TO COLLECT NAME 29000015 BALR LR,BR 29100013 OI WNGW,FNGT SET NAME VDA GOT CAS 45929 29150056 SR RI,RI CLEAR COUNT 29200013 LA RE,8(RA) 29300013 SPACE 29400013 * COLLECT NAME FIELD 29500013 SPACE 29600013 SCANN CLI 0(RB),C' ' TEST FOR BLANK. 29700013 BE BLANK 29800013 CLI 0(RB),C'.' TEST FOR A PERIOD. 29900013 BE PRIOD 30000013 TM WPFL,BLNK+PERD + ARE SWITCHES SAME.. 30100013 BM ERROR NO. 30200013 NI WPFL,255-BLNK-PERD / UNSET SWITCHES. 30300013 MOVEP MVC 1(1,RE),0(RB) 30400013 AR RI,RD 30500013 AR RE,RD 30600013 UPDAT AR RB,RD 30700013 BCT RC,SCANN LOOP OVER SOURCE NAME FIELD 30800013 CH RI,H255 ARE THERE MORE THAN 255 CHARS.. 30900013 BH ERROR YES RAISE 'NAME' CONDITION. 31000013 STC RI,8(RA) NO, SET LENGTH OF NAME. 31100013 SPACE 31200013 * SEARCH SYMTAB. 31300013 SPACE 31400013 L RD,WPRA ADDRESS PLIST. 31500013 TM WPFL,NTRY + ENTRY A.. 31600013 BZ RESTR YES, RESTRICTED READ. 31700013 SPACE 31800013 * SEARCH WHOLE OF SYMTAB KNOWN AT THIS POINT. 31900013 SPACE 32000013 LR RC,RD FIRST ENTRY ADDRESS. 32100013 COMPU L RC,0(RC) ADDRESS IT. 32200013 USING SYMTABF,RC 32300013 LTR RC,RC IS THERE AN ENTRY.. 32400013 BZ ERROR NO, RAISE 'NAME' CONDITION. 32500013 EX RI,CLCHR YES, IS THIS THE REQUIRED NAME 32600013 BE FOUND YES. 32700013 B COMPU NO, CONTINUE SEARCH. 32800013 SPACE 32900013 * SEARCH THOSE ENTRIES SPECIFIED IN PLIST. 33000013 SPACE 33100013 COMPR TM 0(RD),X'80' + END OF LIST. 33200013 BO ERROR YES, RAISE 'NAME' CONDITION. 33300013 LA RD,4(RD) NEXT ENTRY ADDRESS. 33400013 RESTR L RC,0(RD) . ADDRESS ENTRY. 33500013 EX RI,CLCHR IS THIS THE REQUIRED NAME.. 33600013 BNE COMPR NO, CONTINUE SEARCH. 33700013 SPACE 33800013 FOUND IHEPRV FVD,BR $$ FREE VDA FOR NAME 33900015 BALR LR,BR 34000013 NI WNGW,255-FNGT SET NAME VDA RELEASED CAS 45929 34050056 ST RC,WNAM SAVE ENTRY ADDRESS. 34100013 LA RE,8(RI,RC) 34200013 N RE,ALGN ADDRESS PART TWO OF ENTRY. 34300013 USING SYMTABE,RE 34400013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI005-TSS 34430021 * ----------------------------------------------------DDI005-TSS 34460021 L RA,SADD ADDR/OFFSET OF VARIABLE/DV. 34500013 L RB,SDED ADDRESS DED. 34600013 TM SFLG,CLSS TEST FOR STATIC. 34700013 BZ STTIC YES. 34800013 LH BR,SPRO OFFSET TO ANCHOR/DISPLAY CELL. 34900013 A RA,0(BR,PR) ADDRESS OF VARIABLE/DV. 35000013 TM SFLG,NSTC TEST FOR STRUCTURE. 35100013 BO STTIC NO. 35200013 TM 0(RB),STRN TEST FOR STRING. 35300013 BZ STTIC YES. 35400013 CLI SSUB,0 TEST FOR ARRAY. 35500013 BNE STTIC YES. 35600013 L RA,0(RA) ADDRESS ELEMENT FROM STRUCTDV. 35700013 STTIC CLI SSUB,0 WHAT IS DIMENSIONALITY.. 35800013 BE SCLAR 0 - SCALAR. 35900013 LA RD,WPDV 36000013 ST RD,WADD 36100013 LA RC,WADD 36200013 LA RD,SSUB 36300013 LR RH,RE 36400013 LA RE,WSSS 36500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI998-TSS 36550000 L BR,VDDJA $$ CALL ARRAY ELEMENT ADRESS CALC 36600013 * ----------------------------------------------------DDI998-TSS 36650000 BALR LR,BR 36700013 LR RE,RH 36800013 L RA,WADD 36900013 B ASSGN 37000013 SPACE 37100013 SCLAR CLC ZERO,WSSS+CURL SCALAR INTERNAL - ANY SUBSCR.. 37200013 BE ASSGN NO, GOOD. 37300013 LA RA,ARRR 37400013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI987-TSS 37450000 L BR,VERRC $$ 'INVALID ARRAY DATUM'. 37500013 * ----------------------------------------------------DDI987-TSS 37550000 BR BR 37600013 SPACE 37700013 ASSGN ST RA,WNAM+4 SAVE ADDRESS OF VARIABLE. 37800013 TM 0(RB),X'88' 37810015 BNO NTCD1 NOT CODED ARITH. 37820015 TM 0(RB),X'06' 37830015 BZ NTCD1 FIXED DECIMAL. 37840015 LA RA,TEMP CONVERT INTO TEMP 37850015 NTCD1 EQU * 37860015 LA RC,IVDA 37900013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI997-TSS 37950000 L BR,VLDID $$ CALL LDI TO ASSIGN VALUE. 38000013 * ----------------------------------------------------DDI997-TSS 38050000 BALR LR,BR 38100013 TM 0(RB),X'88' 38106015 BNO NTCD2 NOT CODED ARITH. 38112015 TM 0(RB),X'06' 38118015 BZ NTCD2 FIXED DECIMAL. 38124015 LA BR,2 ASSUME HALFWORD BINARY. 38126001 TM 0(RB),X'01' TEST FOR REAL/COMPLEX. 38128001 BZ SKIP1 SKIP IF REAL. 38130001 AR BR,BR DOUBLE UP IF COMPLEX. 38132001 SKIP1 TM 0(RB),X'02' TEST FOR FIXED/FLOAT. 38134001 BZ SKIP2 BRANCH IF FIXED. 38136001 AR BR,BR DOUBLE UP IF FLOAT. 38138001 TM 0(RB),X'10' TEST FOR SHORT/LONG. 38140001 BZ MOVES SKIP IF SHORT. 38142001 AR BR,BR DOUBLE UP IF LONG. 38144001 B MOVES 38146001 SKIP2 TM 0(RB),X'10' TEST FOR HALFWORD BINARY. 38148001 BO MOVES SKIP IF HALFWORD BINARY. 38150001 AR BR,BR DOUBLE UP IF FULLWORD. 38152001 MOVES BCTR BR,0 38166015 L RA,WNAM+4 38172015 EX BR,MVCAD MOVE DATA TO TARGET. 38178015 NTCD2 EQU * 38184015 LR RB,RE 38200013 TM SFLG,CHCK + ON 'CHECK' FOR VARIABLE.. 38300013 BZ DDEXT NO. 38400013 MVI WNAM,ONCH SET ON CODE FOR ONCHECK VAR. 38500013 LA RA,WNAM 38600013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI996-TSS 38650000 L BR,VERRD $$ 'CHECK(IDENTIFIER)'. 38700013 * ----------------------------------------------------DDI996-TSS 38750000 BALR LR,BR 38800013 DDEXT TM WPFL,TERM + TEST FOR END OF TRANSMISSION. 38900013 BZ DD000 NO, PROCESS NEXT INPUT ITEM. 39000013 TM IVDA+2,EOFF + WAS EOF FOUND AT END OF FIELD. 39100013 BO DIEOF YES. 39200013 L RD,OFDR(DR) RESTORE DR. 39300013 L RE,OFLR(RD) NORMAL RETURN ADDRESS. 39400013 DEOFX IHEPRV LW4,RC 39500013 ST RD,OFDR(RC) 39600013 LR DR,RC 39700013 IHEPRV FVD,BR 39800015 BALR LR,BR 39900013 LR DR,RD 40000013 LR LR,RE RETURN ADDRESS. 40100013 DEXIT LM BR,PWR,OFBR(DR) RESTORE OTHER REGISTERS. 40200013 BR LR X RETURN. 40300013 EJECT 40400013 BLANK OI WPFL,BLNK / SET BLANK FLAG. 40500013 B UPDAT 40600013 SPACE 40700013 PRIOD TM WPFL,PERD + LAST NON-BLANK A PERIOD.. 40800013 BO ERROR YES, RAISE 'NAME' CONDITION. 40900013 OI WPFL,BLNK+PERD / SET BLANK AND PERIOD FLAGS. 41000013 B MOVEP 41100013 SPACE 10 41200013 * ROUTINE TO GET NEXT CHARACTER. 41300013 SPACE 41400013 DDNXT AR RC,RD NEXT SOURCE CHARACTER. 41500013 BCTR RE,RH CONTINUE UNLESS END OF BUFFER. 41600013 TM WPFL,LBLK TEST FOR LEADING BLANKS. 41700013 BO DDGET YES. 41800013 LA R0,16 NO, STACK INFORMATION . 41900013 AH R0,WSDS+CURL 42000013 IHEPRV VDA,BR $$ GET VDA TO STACK IT 42100015 BALR LR,BR 42200013 MVC 8(8,RA),WSDS 42300013 LA LR,16(RA) 42400013 ST LR,8(RA) SET SDV FOR STACKED INFORMATION 42500013 LR RA,LR 42600013 LH LR,IVDA 42700013 AR LR,RD 42800013 STH LR,IVDA INCREMENT VDA COUNT. 42900013 LA RG,WSDS 43000013 BAL LR,DIMOV $ MOVE BUFFER TO VDA. 43100013 LH RA,WSDS+CURL 43200013 AH RA,WOFD+CURL 43300013 STH RA,WOFD+CURL INCREMENT FIELD COUNT SO FAR. 43400013 DDGET LR RA,RF 43500013 TM TTYP,TMST + TEST FOR STRING I/O. 43600013 BO ENDST YES HOW SILLY,. 43700013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI995-TSS 43750000 L BR,VIOFA $$ GET ANOTHER RECORD. 43800013 * ----------------------------------------------------DDI995-TSS 43850000 BALR LR,BR 43900013 LTR BR,BR TEST FOR END OF FILE. 44000013 BZ DDIOK NO. 44100013 * ENDFILE CONDITION HAS BEEN RAISED. 44200013 BAL RD,DIVDA $ FREE ANY VDA'S. 44300013 DIEOF EQU * 44310015 TM WPFL,LBLK + SCANNING LEADING BLANKS 44320015 BZ DIER3 ** NO, GO RAISE ERROR 44330015 DIDOF EQU * 44340015 TM TTYP,TMST IS IT A STRING 21183 44343001 BO ENDST BR IF YES 21183 44346001 LH RA,ERRA END OF FILE CODE 44350015 IHEPRV ERR,RA,OP=STH 44360015 L RA,TDCL GET A(DCLCB) 44370015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI994-TSS 44375000 L BR,VERRB 44380015 * ----------------------------------------------------DDI994-TSS 44385000 BALR LR,BR $$ RAISE ENDFILE CONDITION 44390015 IHEPRV CFL,RE,OP=LA 44440015 L RE,4(RE) GET ABNORMAL RETURN ADDRESS. 44500013 L RD,OFDR(DR) 44600013 B DEOFX 44700013 SPACE 44800013 DDIOK LH RD,TREM 44900013 DDSET L RC,TCBA 45000013 STM RC,RD,WSDS SET UP BUFFER SDV. 45100013 LR RE,RD 45200013 LA RD,1 45300013 SR RI,RI 45400013 TM TFLX,TMIE + HAS A TRANSMIT ERROR OCCURRED.. 45500013 BCR 8,RH NO. 45600013 OI TFLX,TMIT / YES, SET TRANSMIT ERROR FLAG. 45700013 IHEPRV CFL,BR,OP=LA 45800013 OI 4(BR),TCFL SET XMIT FLAG 45900013 BR RH 46000013 SPACE 3 46010015 * RAISE ERROR 46020015 SPACE 46030015 DIER3 EQU * 46040015 LA RA,EROF LOAD ERROR CODE 46050015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI993-TSS 46055000 L BR,VERRC A( ERROR ROUTINE ) 46060015 * ----------------------------------------------------DDI993-TSS 46065000 BR BR $$ RAISE ERROR 46070015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI006-TSS 46080021 * ----------------------------------------------------DDI006-TSS 46090021 EJECT 46100013 DIMOV LA RB,256 46200013 LH BR,CURL(RG) 46300013 L RC,0(RG) 46400013 TESTC CR BR,RB 46500013 BNH MVRST 46600013 MVC 0(256,RA),0(RC) 46700013 AR RA,RB 46800013 AR RC,RB 46900013 SR BR,RB 47000013 B TESTC 47100013 MVRST BCTR BR,0 47200013 EX BR,MOVEC 47300013 BR LR 47400013 MOVEC MVC 0(*-*,RA),0(RC) 47500013 SPACE 5 47600013 * FREE VDA'S. 47700013 DIVDA LH RI,IVDA 47800013 LTR RI,RI ANY TO BE FREED.. 47900013 BCR 8,RD NO. 48000013 DIFRE IHEPRV FVD,BR $$ FREE VDA 48100015 BALR LR,BR 48200013 BCT RI,DIFRE CONTINUE UNTIL ALL ARE FREED. 48300013 BR RD ALL FREED. 48400013 SPACE 5 48500013 * RAISE 'NAME' ERROR CONDITION. 48600013 SPACE 48700013 ERROR TM TTYP,TMST + TEST FOR GET STRING 48800013 BO STRNM YES RAISE STRING NAME ERROR. 48900013 LH RA,NAME RAISE ' NAME' CONDITION. 49000013 IHEPRV ERR,RA,OP=STH 49100013 L RA,TDCL ADDRESS OF DCLCB. 49200013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI992-TSS 49250000 L BR,VERRB 49300013 * ----------------------------------------------------DDI992-TSS 49350000 ERRR2 BALR LR,BR 49400013 TM WNGW,FNGT WAS NAME VDA OBTAINED ? CAS 45929 49410056 BZ DDFREVDA NO BRANCH ROUND CAS 45929 49420056 IHEPRV FVD,BR FREE VDA FOR NAME 49430015 BALR LR,BR 49460015 NI WNGW,255-FNGT SET NAME VDA RELEASED CAS 45929 49470056 DDFREVDA EQU * CAS 45929 49480056 BAL RD,DIVDA 49500013 DDTRN TM TFLX,TMIT + TEST TRANSMIT FLAG. 49600013 BZ DDEXT OFF - NO TRANSMIT ERROR. 49700013 LH RA,TRER 49800013 IHEPRV ERR,RA,OP=STH SET TRANSMIT ERROR CODE. 49900013 L RA,TDCL ADDRESS OF DCLCB. 50000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI991-TSS 50050000 L BR,VERRB $$ EXEP. 50100013 * ----------------------------------------------------DDI991-TSS 50150000 BALR LR,BR 50200013 B DDEXT 50300013 SPACE 50400013 STRNM LA RA,STRR RAISE STRING NAME CONDITION. 50500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI990-TSS 50550000 L BR,VERRC $$ CALL ERRC UNTIL CLEAR. 50600013 * ----------------------------------------------------DDI990-TSS 50650000 B ERRR2 TO ENSURE RETURN IF PLANNED. 50700013 SPACE 50800013 DDNLT OI WPFL,TERM / SET TEMINATOR FOUND FLAG. 50900013 DDNUL AR RC,RD 51000013 ST RC,TCBA 51100013 BCTR RE,0 51200013 STH RE,TREM 51300013 B DDTRN 51400013 SPACE 51500013 ENDST LA RA,NDST 51600013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI989-TSS 51650000 L BR,VERRC 51700013 * ----------------------------------------------------DDI989-TSS 51750000 BR BR 51800013 EJECT 51900013 * CONSTANTS. 52000013 SPACE 52100013 ZERO DC H'0' 52200013 NAME DC X'8800' 52300013 ARRR DC H'8' 52400013 CLCHR CLC SLEN(*-*),8(RA) 52500013 MVCAD MVC 0(*-*,RA),TEMP 52550015 H255 DC H'255' 52600013 NDST DC H'2' 52700013 TRER DC X'9802' TRANSMIT ERROR CODE. 52800013 STRR DC H'4' 52900013 ERRA DC AL2(ERR1) END OF FILR 52930015 EROF DC AL2(ERR2) ENDFILE RAISED UNEXPECTEDLY 52960015 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDI988-TSS 52980000 VLDIC DC V(IHELDIC) 53000013 VLDID DC V(IHELDID) 53100013 VDDJA DC V(IHEDDJA) 53300013 VERRB DC V(IHEERRB) 53400013 VIOFA DC V(IHEIOFA) 53600013 VERRC DC V(IHEERRC) 53700013 VERRD DC V(IHEERRD) 53800013 * ----------------------------------------------------DDI988-TSS 53850000 ALGN DC X'FFFFFFFC' 53900013 END 54000013 ./ ADD SSI=04010910,SOURCE=1,NAME=IHEDDJA DDJ TITLE ' IHEDDJ DATA DIRECTED I/P ARRAY ELEMENT ADDRESSER /00500013 OS/360 PL/I LIBRARY' 01000013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 01500013 * 02000013 * STATUS CHANGE LEVEL - 0 02500013 * 03000013 * SIZE 448 BYTES. 03500013 * 04000013 * FUNCTION 04500013 * 05000013 * ENTRY POINTS 05500013 * 06000013 * INPUT 06500013 * 07000013 * OUTPUT 07500013 * 08000013 * EXTERNAL MODULES 08500013 * 09000013 * EXITS 09500013 * 10000013 * TABLES/WORK AREA 10500013 * 11000013 * ATTRIBUTES READ ONLY AND REENTRANT 11500013 * 12000013 * PRIVATE MACROS 12500013 * IHELIB,IHEPRV,IHESDR 13000013 * 13500013 * ASSEMBLY REQUIREMENTS 14000013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 14500013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 15000013 * 15500013 * NOTES 16000013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 16500013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 17000013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 17500013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 18000013 * CONSTANTS, BY REASSEMBLY, WILL RESULT IN A CORRECT 18500013 * MODULE FOR THE NEW DEFINITIONS. 19000013 EJECT 19500013 IHEDDJ CSECT 20000013 IHELIB 20500013 SPACE 21000013 IHEZLW3 DSECT 21500013 DS 18F 22000001 WPFL DS B 22500013 PCKD DS D 23000013 WPDV DS 2A 23500013 WSAV DS 4A 24000013 SPACE 24500013 PWR EQU WR 25000013 FIXD EQU X'90' 25500013 FBIT EQU X'94' 26000013 CURL EQU 6 26500013 SEND EQU 1 27000013 MNUS EQU 2 27500013 BLNK EQU 4 28000013 UPPR EQU 0 28500013 LOWR EQU 2 29000013 EJECT 29500013 IHEDDJ CSECT 30000013 ENTRY IHEDDJA 30500013 IHEDDJA STM LR,PWR,OFLR(DR) 31000013 IHESDR LW3 31500013 USING IHEZLW3,DR 32000013 BALR PWR,0 32500013 USING *,PWR 33000013 L RF,0(RA) 33500013 TM 0(RB),FBIT 34000013 BNE NFBTS 34500013 LR RG,RF 35000013 SLDL RF,3 35500013 NFBTS SR RG,RG 36000013 IC RG,0(RD) 36500013 LR RD,RG SUBSCRIPTS COUNT. 37000013 AR RG,RG 37500013 AR RG,RG 38000013 LA BR,4(RA) ADDRESS MULTIPLIERS. 38500013 LA LR,0(RG,BR) ADDRESS BOUNDS. 39000013 L RA,0(RE) 39500013 LH RE,CURL(RE) 40000013 SR RJ,RJ 40500013 NXTSB MVI WPFL,0 41000013 SR RI,RI 41500013 LBLNK CLI 0(RA),C' ' 42000013 BNE NBLNK 42500013 LA RA,1(RA) 43000013 B LBLNK 43500013 NBLNK CLI 0(RA),C'+' TEST FOR PLUS SIGN. 44000013 BE IGNOR 44500013 CLI 0(RA),C'-' TEST FOR MINUS SIGN. 45000013 BE MINUS 45500013 LOOPC CLI 0(RA),C',' TEST FOR COMMA. 46000013 BE COMMA YES END OF THIS SUBSCRIPT. 46500013 CLI 0(RA),C')' TEST FOR RIGHT PARENTHESIS. 47000013 BE SUBND YES END OF SUBSCRIPTS. 47500013 CLI 0(RA),C' ' 48000013 BE BLANK 48500013 TM WPFL,BLNK 49000013 BO ERROR 49500013 CLI 0(RA),C'9' TEST FOR DIGIT. 50000013 BH ERROR GTR 9 NOT A DIGIT. 50500013 CLI 0(RA),C'0' TEST FOR A DIGIT. 51000013 BL ERROR LESS THAN 0 NOT A DIGIT. 51500013 BCTR RI,0 52000013 IGNOR LA RA,1(RA) 52500013 ST RA,WSAV 53000013 BCT RE,LOOPC 53500013 ERROR IHEPRV LCA,RC 54000013 USING IHEZLCA,RC 54500013 ST RA,WOCH 55000013 LA RA,SBER 55500013 L BR,VERRC 56000013 BR BR 56500013 BLANK OI WPFL,BLNK 57000013 LA RA,1(RA) 57500013 B LOOPC 58000013 MINUS OI WPFL,MNUS 58500013 B IGNOR 59000013 SUBND OI WPFL,SEND 59500013 COMMA LPR RI,RI 60000013 BZ ERROR 60500013 L R0,WSAV 61000013 ST RA,WSAV 61500013 TM WPFL,BLNK 62000013 BZ NTBLK 62500013 LR RA,R0 63000013 NTBLK SR RA,RI 63500013 CH RI,H005 64000013 BH ERRS1 MORE THAN FIVE CHARS. 64500013 RETN1 BCTR RI,0 65000013 EX RI,PACKT 65500013 SR R0,R0 66000013 SPM R0 DISABLE MASKABLE INTERRUPTS. 66500013 CVB RI,PCKD 67000013 SPM PWR RESTORE PROGRAM MASK. 67500013 TM WPFL,MNUS 68000013 BZ POSVE 68500013 LNR RI,RI 69000013 POSVE CH RI,UPPR(RJ,LR) 69500013 BH ERRS2 GREATER THAN UPPER BOUND. 70000013 CH RI,LOWR(RJ,LR) 70500013 BL ERRS2 LESS THAN LOWER BOUND. 71000013 RETN2 M RH,0(RJ,BR) 71500013 AR RF,RI 72000013 LA RJ,4(RJ) 72500013 TM WPFL,SEND 73000013 BCT RD,NOTND 73500013 BZ ERROR 74000013 SR BR,BR 74500013 LR RG,RF 75000013 TM 0(RB),FBIT 75500013 BNE NFBIT 76000013 SRDL RF,3 76500013 NFBIT TM 0(RB),FIXD TEST FOR FIXED LENGTH STRING. 77000013 BNE DJOUT 77500013 L RC,0(RC) ADDRESS SDV FOR SOURCE 78000013 LH RH,2(RJ,LR) 78500013 STM RG,RH,0(RC) 79000013 STH RH,4(RC) 79500013 B DJEXT 80000013 DJOUT ST RG,0(RC) 80500013 DJEXT L DR,OFDR(DR) 81000013 LM LR,PWR,OFLR(DR) 81500013 BR LR 82000013 NOTND BO ERROR 82500013 L RA,WSAV 83000013 LA RA,1(RA) 83500013 BCT RE,NXTSB 84000013 B ERROR 84500013 ERRS1 BAL LR,ERRSR 85000013 B RETN1 85500013 ERRS2 BAL LR,ERRSR 86000013 B RETN2 86500013 ERRSR STM LR,RA,WSAV 87000013 LH RA,SUBS 87500013 IHEPRV ERR,RA,OP=STH SET SUBSCRIPT RANGE CODE. 88000013 L BR,VERRB 88500013 BALR LR,BR 89000013 LM LR,RA,WSAV 89500013 BR LR 90000013 PACKT PACK PCKD(8),0(*-*,RA) 90500013 H005 DC H'5' 91000013 SBER DC H'8' 91500013 SUBS DC X'3000' 92000013 VERRB DC V(IHEERRB) 92500013 VERRC DC V(IHEERRC) 93000013 END 93500013 ./ ADD SSI=05011973,SOURCE=1,NAME=IHEDDOA DDO TITLE ' IHEDDO DATA DIRECTED OUTPUT /00300013 OS/360 PL/I LIBRARY' 00600013 * VERSION FOURTH VERSION OF F-LEVEL PL/I COMPILER 00900015 * 01200013 * STATUS CHANGE LEVEL - 0 01500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDO000-TSS 01600001 * ----------------------------------------------------DDO000-TSS 01700001 * 01800013 * SIZE 768 BYTES 02100015 * 02400013 * FUNCTION 02700013 * 1)A)TO WRITE AN ITEM ONTO THE SPECIFIED FILE ACCORDING 03000013 * TO THE RULES SPECIFIED FOR DATA DIRECTED OUTPUT AND 03300013 * B)TO TERMINATE THE ABOVE TRANSMISSION OR 03600013 * 2)TO WRITE A DATA VARIABLE ONTO THE SYSTEM OUTPUT 03900013 * FILE AS PART OF THE SYSTEM ACTION FOR THE CHECK ON 04200013 * CONDITION. 04500013 * 04800013 * IF THE ITEM IS AN ARRAY THEN THE ARRAY IS OUTPUT ELEMENT 05100013 * BY ELEMENT(ENTRY POINT IHEDDOA) OR THE SPECIFIED ELEMENT 05400013 * IS OUTPUT(ENTRY POINTS IHEDDOB AND IHEDDOD). THE 05700013 * SUBSCRIPTS ARE OUTPUT (AND ELEMENT ADDRESSES CALCULATED) 06000013 * BY CALLS TO MODULE IHEDDP. 06300013 * IF THE SPECIFIED FILE IS A 'PRINT' FILE THE 06600013 * DATA IS TABBED AND SPANNING OF LINES IS AVOIDED, IF 06900013 * POSSIBLE, FOR ARITHMETIC DATA. 07200013 * TO ACHIEVE THIS END, NO DATA IS PUT OUT BY THIS 07500013 * MODULE BUT IS PASSED TO MODULE IHELDO FOR TRANSMISSION. 07800013 * 08100013 * ENTRY POINTS 08400013 * IHEDDOA (SCALARS OR WHOLE ARRAYS) 08700013 * RA = A(PLIST) 09000013 * PLIST = A(SYMTAB ENTRY-VARAIBLE) 09300013 * ...... 09600013 * IHEDDOB (ELEMENT OF ARRAY) 09900013 * RA = A(PLIST) 10200013 * PLIST = A(SYMTAB ENTRY-ARRAY) 10500013 * A(ELEMENT IN ARRAY) 10800013 * ...... 11100013 * ...... 11400013 * IHEDDOC (TERMINATION) 11700013 * NO PARAMETERS. 12000013 * IHEDDOD (CHECK ON CONDITION) 12300013 * RA = A(PLIST) 12600013 * PLIST = A(SYMTAB ENTRY FOR VARIABLE) 12900013 * A(VARIABLE/ELEMENT OF ARRAY) 13200013 * 13500013 * INPUT 13800013 * ENTRY POINTS IHEDDOA,IHEDDOB,IHEDDOC. 14100013 * CURRENT FILE PSEUDO-REGISTER (IHEQCFL) 14400013 * ENTRY POINT IHEDDOD. 14700013 * SYSPRINT FILE REGISTER (IHEQSPR). 15000013 * 15300013 * OUTPUT 15600013 * SEE FUNCTION. 15900013 * 16200013 * EXTERNAL MODULES 16500013 * IHEDDP - 1) PREPARE ARRAY. 16800013 * 2) OUTPUT SUBSCRIPTS. 17100013 * 3) ADDRESS NEXT ELEMENT (ENTRY POINT IHEDDOA). 17400013 * IHEPRT - PREPARE SYSPRINT FILE. 17700013 * IHELDO - OUTPUT VALUE PART. 18000013 * 18300013 * EXITS NORMAL 18600013 * RETURN VIA LINK REGISTER. 18900013 * 19200013 * TABLES/WORK AREA 19500013 * 19800013 * ATTRIBUTES READ ONLY AND REENTRANT 20100013 * 20400013 * PRIVATE MACROS 20700013 * IHELIB,IHEPRV,IHESDR,IHEZAP 21000013 * 21300013 * ASSEMBLY REQUIREMENTS 21600013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 21900013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 22200013 * 22500013 * NOTES 22800013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 23100013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 23400013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 23700013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 24000013 * CONSTANTS, BY REASSEMBLY, WILL RESULT IN A CORRECT 24300013 * MODULE FOR THE NEW DEFINITIONS. 24600013 EJECT 24900013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDO001-TSS 25000001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 25200013 PUNCH ' LIBRARY *(IHEDDPA,IHEDDPB,IHEDDPC,IHEDDPD) /25500013 DDO0000A' 25800013 * ----------------------------------------------------DDO001-TSS 25900001 SPACE 26100013 IHEDDO CSECT 26400013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DDO002-TSS 26500001 IHEQSPR DXD A 26700013 * ----------------------------------------------------DDO002-TSS 26800001 IHEZAP 27000013 IHELIB 27300013 SYMTABF DSECT 27600013 SPTR DS A ADDRESS OF NEXT ENTRY/0. 27900013 SNAM DS 256C 28200013 SPACE 2 28500013 SYMTABE DSECT 28800013 SSUB DS 0X DIM OF ARRAY (0 FOR SCALAR). 29100013 SDED DS A ADDRESS OF VARIABLE DED. 29400013 SFLG DS 0B FLAGS 29700013 SADD DS A ADDR/OFFSET OF VARIABLE. 30000013 SPRO DS H OFFSET IN PRV TO DISPLAY PTR. 30300013 SPACE 2 30600013 ONCK EQU B'01000000' ON CHECK VARIABLE (INPUT) 30900013 CLSS EQU B'00000011' 31200013 NSTC EQU X'01' 31500013 SPACE 2 31800013 IHEZLW4 DSECT 32100013 DS 18F 32400013 WPFL DS 0B 32700013 WPRA DS A 33000013 WVDA DS A 33300013 WSUB DS 2A SDV FOR SUBSCRIPTS VDA. 33600013 WNAM DS A ADDR OF DATA VARIABLE NAME. 33900013 TEMP DS 2D 33940015 PEQ1 DS A 33980015 PEQ2 DS A 34020015 PEQ3 DS A 34060015 QUAR DS 2A 34100015 OFCF EQU 72 34140015 SPACE 34200013 PWR EQU WR 34500013 NTRY EQU 6 34800013 NTCD EQU 4 35100013 NTRD EQU 2 35400013 NTRE EQU B'10000000' 35500015 STRN EQU X'80' 35700013 EJECT 36000013 IHEDDO CSECT 36300013 ENTRY IHEDDOA,IHEDDOB,IHEDDOC,IHEDDOD,IHEDDOE 36600015 IHEDDOA NOPR 0 . ENTRY FOR SCALAR/WHOLE ARRAYS. 36900013 IHEDDOB NOPR 0 . ENTRY FOR ELEMENT OF ARRAY. 37200013 IHEDDOC NOPR 0 . ENTRY TO TERMINATE DDO. 37500013 IHEDDOD NOPR 0 ENTRY FORM IHEERR (ON-CHECK) 37700015 IHEDDOE STM LR,PWR,OFLR(DR) ENTRY TO PUT ALL KNOWN ITEMS 37900015 BALR PWR-1,0 38100013 USING *,PWR-1 38400013 IHESDR LW4,PWR UPDATE SAVE AREA POINTER. 38700013 USING IHEZLW4,DR 39000013 ST RA,WPRA SAVE P.LIST POINTER. 39300013 STC BR,WPFL SET ENTRY POINT FLAGS. 39600013 NI WPFL,255-NTRE 39680015 LA BR,0(BR) 39760015 C BR,VDDOE ENTRY POINT DDOE.. 39840015 BNE NDDOE NO. 39920015 OI WPFL,NTRE 40000015 NDDOE SR RE,RE 40080015 STH RE,WSUB+6 INIT CUR LENGTH TO ZERO. 40200013 TM WPFL,NTCD + TEST FOR ENTRY C OR D. 40500013 BO DODDC YES. 40800013 DODDR TM WPFL,NTRY + TEST FOR ENTRY A OR D. 41100013 BO DODDA ENTRY D. 41400013 BZ DDFLE ENTRY A. 41700013 L RB,4(RA) NO, ADDRESS ELEMENT FROM P.LIST 42000013 SPACE 42300013 DDFLE IHEPRV CFL,RC ADDRESS DCLCB FOR FILE. 42600013 USING IHEZDCL,RC 42900013 LH RC,DPRO 43200013 L RC,0(RC,PR) ADDRESS FCB FOR FILE. 43500013 SPACE 43800013 USING IHEZAPE,RC 44100013 DODAR L RG,0(RA) ADDRESS SYMTAB ENTRY. 44400013 USING SYMTABF,RG 44700013 SR RE,RE 45000013 IC RE,SNAM GET LENGTH OF NAME. 45300013 LA RG,8(RE,RG) 45600013 N RG,ALGN ADDRESS 2ND PART OF SYMTAB. 45900013 USING SYMTABE,RG 46200013 CLI SSUB,0 IS IT AN ARRAY VARIABLE.. 46500013 BE DODR2 NO, SCALAR. 46800013 LR RD,RB ADDRESS OF ELEMENT(NOT ENTRY A) 47100013 LA RB,WSUB ADDRESS SUBSCRIPTS AREA SDV. 47400013 LR RH,RC SAVE ADDRESS OF FCB. 47700013 LR RC,RG ADDRESS OF 2ND PART OF SYMTAB. 48000013 LR RG,RA SAVE P.LIST POINTER. 48300013 SR RA,RA 48600013 DROP RG 48900013 USING SYMTABE,RC 49200013 IC RA,SSUB DIMENSIONALITY. 49500013 DROP RC 49800013 MH RA,H007 COMPUTE MAX AREA REQUIRED FOR 50100013 LA RA,1(RA) SUBSCRIPTS. 50400013 STH RA,WSUB+4 50700013 LA R0,8(RA) 51000013 IHEPRV VDA,BR $$ GET VDA TO HOLD SUBSCRIPTS 51300015 BALR LR,BR 51600013 LA RA,8(RA) ADDRESS AREA FOR SUBSCRIPTS. 51900013 ST RA,WSUB COMPLETE SDV FOR AREA. 52200013 LA RA,WVDA CELL FOR A(ARRAY.VDA). 52500013 L BR,VDDPA $$ INITIALIZE FOR WHOLE ARRAY. 52800013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 53100013 BNL CLDDP YES. 53400013 L BR,VDDPD $$ INITIALIZE FOR SINGLE ELEMENT. 53700013 CLDDP BALR LR,BR CALL INDEXER (INITIALIZATION). 54000013 LR RA,RG RESTORE P.LIST POINTER. 54300013 LR RC,RH AND ADDRESS OF FCB. 54600013 * RE-ENTER HERE FOR NEXT ELEMENT OF ARRAY VARIABLE. 54900013 NXTEL L RB,WVDA ADDRESS ARRAY VDA. 55200013 L RB,0(RB) ADDRESS OF ELEMENT 55500013 DODR2 L RG,0(RA) ADDRESS SYMTAB ENTRY. 55800013 USING SYMTABF,RG 56100013 LA RF,SNAM ADDRESS OF NAME FIELD. 56400013 ST RF,WNAM 56700013 SR RE,RE 57000013 IC RE,0(RF) GET LENGTH OF NAME 57300013 LA RG,8(RE,RG) 57600013 N RG,ALGN ADDRESS WORD BOUNDARY AFTER NM. 57900013 USING SYMTABE,RG 58200013 CLI SSUB,0 IS IT AN ARRAY VARIABLE.. 58500013 BNE SUBSC YES, OUTPUT SUBSCRIPTS. 58800013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 59100013 BNL DELLA YES, ADDR ELEMENT FROM SYMTAB. 59400013 STTIC EQU * 59700013 LR RA,RB ADDRESS SOURCE ITEM 60000013 L RB,SDED ADDRESS SOURCE DED 60300013 TM 0(RB),X'88' TEST FO CAD. 60320015 BNO CALLC NO. 60340015 TM 0(RB),X'06' 60360015 BZ CALLC FIXED DECIMAL. 60380015 LA BR,4 60400015 TM 0(RB),X'11' FLT LONG AND COMPLEX.. 60420015 BZ MOVES NEITHER MOVE 4 BYTES. 60440015 BM MOVEL ONE OR T'OTHER MOVE 8 BYTES. 60460015 AR BR,BR BOTH MOVE 16 BYTES. 60480015 MOVEL AR BR,BR 60500015 MOVES BCTR BR,0 60520015 EX BR,MVCAD MOVE DATA TO TEMP. 60540015 LA RA,TEMP 60560015 CALLC EQU * 60580015 L RD,WNAM GET ADDRESS OF NAME FIELD. 60600013 LA RE,WSUB 60900013 L BR,VLDOC $$ OUTPUT USING LIST OUTPUT. 61200013 BALR LR,BR 61500013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 61800013 BL NDLST NOT ENTRY A OR D. 62100013 DDLAB CLI SSUB,0 IS IT AN ARRAY VARIABLE.. 62400013 BE NDLST NO. 62700013 L RA,WVDA ADDRESS OF ARRAY VDA. 63000013 L BR,VDDPC $$ ADDRESS NEXT ELEMENT. 63300013 BALR LR,BR 63600013 L RA,WPRA RESTORE P.LIST POINTER. 63900013 LTR BR,BR IS IT THE END OF THE ARRAY.. 64200013 BZ NXTEL NO, OUTPUT NEXT ELEMENT. 64500013 NDLST CLC WSUB+6(2),ZERO TEST FOR ARRAY DATA ITEM. 64800013 BE DOXXX NO. 65100013 IHEPRV FVD,BR $$ FREE VDA FOR SUBSCRIPTS AREA 65400015 BALR LR,BR 65700013 SR BR,BR 66000013 STH BR,WSUB+6 RESET LENGTH OF SUBSCRIPTS. 66300013 DOXXX L RA,WPRA P.LIST POINTER. 66600013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 66900013 BO DODDD ENTRY D. 67200013 BZ NTRAE ENTRY A OR E. 67500015 LA RA,4(RA) ADDRESS 2ND WORD OF P.LIST. 67800013 NTRYA TM 0(RA),X'80' + TEST FOR END OF P.LIST. 68100013 BO DOEXT YES. 68400013 LA RA,4(RA) ADDRESS NEXT ENTRY. 68700013 NTRYE IC BR,WPFL 69000015 ST RA,WPRA 69300013 STC BR,WPFL 69600013 B DODDR OUTPUT NEW VARIABLE. 69900013 DOEXT L DR,OFDR(DR) RESTORE DR. 70200013 LM LR,PWR,OFLR(DR) RESTORE OTHER REGISTERS. 70500013 BR LR X RETURN. 70800013 SPACE 70830015 NTRAE TM WPFL,NTRE TEST FOR DDOE ENTRY. 70860015 BZ NTRYA 70890015 L RA,0(RA) ADDRESS CURRENT SYMTAB 70920015 L BR,0(RA) ADDRESS NEXT SYMTAB 70950015 LTR BR,BR ..IS THERE ONE.. 70980015 BZ DODDD NO. 71010015 B NTRYE 71040015 SPACE 71100013 DODDA LR RE,RB 71200015 LA RB,ZERO SET FOR FILE CHECK ONLY. 71700013 L BR,VPRTB $$ CALL SYSPRINTER TO CHECK FOR 72000013 BALR LR,BR SYSPRINT FILE. 72300013 LR RB,RE 72600015 L RA,WPRA RESTORE P.LIST POINTER. 72900013 IHEPRV SPR,RC ADDRESS DCLCB FOR SYSPRINT. 73200013 LTR RC,RC IS FILE OPEN.. 73500013 BP DODAR YES, AND AT A NEW LINE. 73800013 B DOEXT NO FILE - REQUEST IGNORED. 74100013 SPACE 74400013 DODXT LR RA,RC 74700013 USING IHEZAPE,RC 75000013 DOOUT L BR,VIOFA $$ OUTPUT LINE. 75300013 BALR LR,BR 75600013 B DOEXT RETURN TO ERROR PACKAGE. 75900013 SPACE 76200013 DODDC TM WPFL,NTRD + TEST FOR ENTRY D. 76500013 BO DODDR YES. 76800013 IHEPRV CFL,RC ADDRESS DCLCB FOR FILE. 77100013 USING IHEZDCL,RC 77400013 LH RC,DPRO 77700013 L RC,0(RC,PR) ADDRESS FCB FOR FILE. 78000013 USING IHEZAPE,RC 78300013 DODDD L RD,TCBA 78600013 BCTR RD,0 ADDRESS LAST USED BYTE. 78900013 MVI 0(RD),C';' MOVE TERMINATING SEMI-COLON. 79200013 TM WPFL,NTRY + TEST FOR ENTRY D. 79500013 BO DODXT YES. 79800013 B DOEXT NO. 80100013 SPACE 80400013 DELLA L RB,SADD ADDR/OFFSET OF VARIABLE/DV. 80700013 L LR,SDED ADDRESS DED. 81000013 TM SFLG,CLSS TEST FOR STATIC. 81300013 BZ STTIC YES. 81600013 LH BR,SPRO OFFSET TO ANCHOR/DISPLAY CELL. 81900013 A RB,0(BR,PR) ADDRESS OF VARIABLE/DV. 82200013 TM SFLG,NSTC TEST FOR STRUCTURE. 82500013 BO STTIC NO. 82800013 TM 0(LR),STRN TEST FOR STRING. 83100013 BZ STTIC YES. 83400013 L RB,0(RB) ADDRESS ELEMENT FROM STRUCTDV. 83700013 B STTIC 84000013 SPACE 84300013 SUBSC L RA,WVDA ADDRESS OF ARRAY VDA. 84600013 L BR,VDDPB $$ INDEXER TO OUTPUT SUBSCRIPTS. 84900013 BALR LR,BR 85200013 B STTIC 85500013 SPACE 85800013 SPACE 86080015 ZERO DC H'0' 86100013 H007 DC H'7' 86400013 MVCAD MVC TEMP(*-*),0(RA) 86420015 DS 0F 86440015 VDDOE DC V(IHEDDOE) 86500015 VIOFA DC V(IHEIOFA) 86700013 VLDOC DC V(IHELDOC) 87600013 VPRTB DC V(IHEPRTB) 87900013 VDDPA DC V(IHEDDPA) 88200013 VDDPB DC V(IHEDDPB) 88500013 VDDPC DC V(IHEDDPC) 88800013 VDDPD DC V(IHEDDPD) 89100013 ALGN DC X'FFFFFFFC' 89400013 END 89700013 ./ ADD SSI=21400052,NAME=IHEDDPA,SOURCE=0 DDP TITLE ' IHEDDP DATA DIRECTED OUTPUT ARRAY INDEXER /00200013 OS/360 PL/I LIBRARY' 00400013 * VERSION THIRD VERSION OF F-LEVEL PL/1 COMPILER 00600013 * 00800013 * STATUS CHANGE LEVEL - 0 01000013 * 01050056 *A350000,736000 BPC 47607 01100056 *C722000,730000 BPC 47607 01150056 * 01200013 * SIZE 736 BYTES. 01400013 * 01600013 * FUNCTION 01800013 * 1)TO PREPARE AN ARRAY FOR OUTPUTTING THE SUBSCRIPTS AND 02000013 * TO ADDRESS THE FIRST ELEMENT. 02200013 * 2) TO PREPARE THE SUBCRIPTS FOR OUTPUT ON TO THE 02400013 * SPECIFIED FILE. 02600013 * 3)TO ADDRESS THE NEXT ELEMENT. 02800013 * 03000013 * THE PREPARATION OF THE ARRAY INVOLVES THE CREATING OF 03200013 * A SPECIALLY MODIFIED DV WHICH CONTAINS ALSO THE 03400013 * DIMENSIONALITY AND THE ADDRESS OF THE FILE CONTROL 03600013 * BLOCK. SEE TABLES/WORKAREA FOR MAP. 03800013 * 04000013 * THE ALGORITHM USED TO COMPUTE THE SUBSCRIPTS FOR A 04200013 * SPECIFIED ELEMENT FROM ITS ADDRESS IS AS FOLLWS - 04400013 * (N) (N) 04600013 * SUM(M(I)*(S(I)-LB(I))) = M(R)*(S(R)-LB(R)) + SUM(M(I)*(S(I)-LB(I))) 04800013 * (I=R) (I=R+1) 05000013 * WHERE S(I) = SUBSCRIPT FOR THE I-TH DIMENSION. 05200013 * LB(I)= LOWER BOUND FOR THE I-TH DIMENSION. 05400013 * M(I) = MULTIPLIER FOR THE I-TH DIMENSION. 05600013 * R = THE DIMENSION UNDER CONSIDERATION. 05800013 * N = THE DIMENSIONALITY OF THE ARRAY. 06000013 * DIVIDING THE LEFT HAND SIDE BY THE MULTIPLIER FOR THE 06200013 * DIMENSION UNDER CONSIDERATION YIELDS A QUOTIENT OF 06400013 * (S(R)-LB(R)) AND A REMAINDER OF THE REST OF THE RIGHT 06600013 * HAND SIDE. 06800013 * (PROVIDED THAT THE MAJOR OPERANDS ARE ALL OF THE SAME 07000013 * SIGN, AND SINCE THE M(I) ARE ALWAYS POSITIVE THEN ALL 07200013 * MAJOR OPERANDS MUST BE POSITIVE. THIS IS WHY THE 07400013 * DIFFERENCE BETWEEN THE S(I) AND LB(I) IS USED) 07600013 * 07800013 * TO COMPUTE THE LEFT HAND SIDE FOR R=1. 08000013 * (N) 08200013 * A(ELEMENT) = SUM(M(I)*(S(R)) + A(V.ORIGIN) 08400013 * (I=1) 08600013 * 08800013 * (N) 09000013 * A(LB-ELEMENT) = SUM(M(I)*(LB(R)) + A(V.ORIGIN) 09200013 * (I=1) 09400013 * 09600013 * WHERE LB-ELEMENT = ELEMENT WHOSE SUBSCRIPTS ARE THE 09800013 * LOWER BOUNDS. 10000013 * HENCE 10200013 * (N) 10400013 * SUM(M(I)*(S(I)-LB(I))) = A(ELEMENT)-A(LB-ELEMENT) 10600013 * (I=1) 10800013 * 11000013 * FOR THE R-TH SUBSCRIPT (R = 2 TO N) ITERATE BY 11200013 * REPLACING THE LEFT HAND SIDE BY THE REMAINDER AND R BY 11400013 * R+1 IN THE ALGORITHM. 11600013 * 11800013 * ENTRY POINTS 12000013 * IHEDDPA (PREPARE FOR WHOLE ARRAY) 12200013 * RA = A(CELL FOR ADDRESS OF CREATED DOPE VECTOR) 12400013 * RB = A(SDV FOR SUBS AREA) 12600013 * RC = A(2ND PART OF SYMBOL TABLE ENTRY) 12800013 * IHEDDPB (OUTPUT SUBSCRIPT FOR ELEMENT) 13000013 * RA = A(PLIST) 13200013 * PLIST = A(CREATED DOPE VECTOR) 13400013 * IHEDDPC (ADDRESS NEXT ELEMENT) 13600013 * RA = A(PLIST) 13800013 * PLIST = A(CREATED DOPE VECTOR) 14000013 * IHEDDPD (PREPARE FOR SINGLE ELEMENT OF ARRAY) 14200013 * RA = A(CELL FOR ADDRESS OF CREATED DOPE VECTOR) 14400013 * RB = A(SDV FOR SUBS AREA) 14600013 * RC = A(2ND PART OF SYMBOL TABLE) 14800013 * RD = A(ELEMENT) 15000013 * 15200013 * INPUT 15400013 * N/A 15600013 * 15800013 * OUTPUT 16000013 * SEE FUNCTION. 16200013 * 16400013 * EXTERNAL MODULES 16600013 * 16800013 * EXITS NORMAL 17000013 * RETURN VIA LINK REGISTER 17200013 * RETURN CODES FOR ENTRY POINT IHEDDPC 17400013 * BR = 0 NEXT ELEMENT ADDRESS ED. 17600013 * BR = 4 END OF ARRAY. 17800013 * ERROR 18000013 * 18200013 * TABLES/WORK AREA 18400013 * MAP OF CREATED DOPE VECTOR FOR ARRAY. 18600013 * 18800013 * 0 *********************************** 19000013 * * ADDRESS OF ELEMENT/SDV * 19200013 * 4 *********************************** 19400013 * * ADDRESS OF SUBSCRIPTS VDA SDV * 19600013 * 8 *********************************** 19800013 * * ADDRESS OF DED * 20000013 * 12 *********************************** 20200013 * * ADDRESS OF ADV * 20400013 * 16 *********************************** 20600013 * * DIMENSIONALITY * 20800013 * 20 *********************************** 21000013 * * ADDRESS OF VIRTUAL ORIGIN * 21200013 * 24 *********************************** 21400013 * * CREATED SDV FOR FIXED LENGTH * 21600013 * ********** ********** 21800013 * * STRING * 22000013 * 32 *********************************** 22200013 * * CURRENT SUBSCRIPT(1) * 22400013 * *********************************** 22600013 * * UPPER BOUND(1) * 22800013 * *********************************** 23000013 * --- --- 23200013 * --- --- 23400013 * *********************************** 23600013 * * CURRENT SUBSCRIPT(N) * 23800013 * *********************************** 24000013 * * UPPER BOUND(N) * 24200013 * 32+8N *********************************** 24400013 * 24600013 * ATTRIBUTES READ ONLY AND REENTRANT 24800013 * 25000013 * PRIVATE MACROS 25200013 * IHELIB,IHESDR 25400013 * 25600013 * ASSEMBLY REQUIREMENTS 25800013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 26000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 26200013 * 26400013 * NOTES 26600013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 26800013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 27000013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 27200013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 27400013 * CONSTANTS, BY REASSEMBLY, WILL RESULT IN A CORRECT 27600013 * MODULE FOR THE NEW DEFINITIONS. 27800013 EJECT 28000013 IHEDDP CSECT 28200013 IHELIB 28400013 IHEZLW2 DSECT 28600013 DS 18F 28800001 WPFL DS 0B 29000013 WPEL DS A 29200013 DECM DS D 29400013 EDIT DS CL6 29600013 SPACE 29800013 VDAD DSECT 30000013 VELM DS A 30200013 VVDA DS A 30400013 VDED DS A 30600013 VADV DS A 30800013 VSUB DS A 31000013 VORG DS A 31200013 VSDV DS 2A 31400013 LVDA EQU *-VDAD 31600013 SPACE 31800013 SYMTABF DSECT 32000013 DS A 32200013 SNAM DS 256C 32400013 SPACE 32600013 SYMTABE DSECT 32800013 SSUB DS 0AL1 33000013 SDED DS A 33200013 SFLG DS 0B 33400013 SADD DS A 33600013 SPRO DS H 33800013 SPACE 34000013 CURL EQU 6 34200013 LOWR EQU 2 34400013 UPPR EQU 0 34600013 FIXT EQU X'90' 34800013 FBIT EQU X'94' 35000013 VBIT EQU X'04' 47607 35100056 CLSS EQU 3 35200013 NTRY EQU X'06' 35400013 NTRC EQU X'04' 35600013 DFLG EQU 1 35800013 PWR EQU WR 36000013 EJECT 36200013 IHEDDP CSECT 36400013 ENTRY IHEDDPA,IHEDDPB,IHEDDPC,IHEDDPD 36600013 IHEDDPA NOPR 0 . ENTRY TO INITIALIZE FOR WHOLE /36800013 ARRAY. 37000013 IHEDDPB NOPR 0 . ENTRY TO OUTPUT SUBSCRIPTS. 37200013 IHEDDPC NOPR 0 . ENTRY TO ADDRESS NEXT ELEMENT. 37400013 IHEDDPD STM LR,PWR,OFLR(DR) . ENTRY TO INITIALIZE FOR SINGLE /37600013 ELEMENT 37800013 USING SYMTABE,RC 38000013 IHESDR LW2,PWR UPDATE DR. 38200013 USING IHEZLW2,DR 38400013 BALR PWR,0 38600013 USING *,PWR 38800013 ST RD,WPEL SAVE ADDRESS OF ELEMENT. 39000013 STC BR,WPFL / SET ENTRY FLAGS. 39200013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 39400013 BM DP010 NO. 39600013 SPACE 39800013 * INITIALIZE ARRAY. 40000013 SPACE 40200013 LR RE,RA SAVE ADDR OF CB POINTER 40400013 SR RD,RD 40600013 IC RD,SSUB SUBSCRIPT COUNT 40800013 LR RG,RD 41000013 SLL RD,3 SUBSCRIPT.COUNT*8 41200013 LA R0,LVDA+8(RD) REQUIRED LENGTH OF VDA. 41400013 IHEPRV VDA,BR $$ GET IT 41600015 BALR LR,BR 41800013 LA RA,8(RA) 42000013 USING VDAD,RA 42200013 ST RB,VVDA SAVE ADDR OF SUBSCRIPT AREA SDV 42400013 ST RA,0(RE) SET POINTER IN CALLER'S PGM. 42600013 L RE,SDED ADDRESS OF DED FOR VARIABLE. 42800013 L RF,SADD ADDR/OFFSET OF VARIABLE/DV. 43000013 TM SFLG,CLSS TEST FOR STATIC. 43200013 BZ STTIC YES. 43400013 LH BR,SPRO OFFSET TO ANCHOR/DISPLAY CELL. 43600013 A RF,0(BR,PR) ADDRESS OF VARIABLE ADV. 43800013 STTIC STM RE,RG,VDED SET A(DED),A(ADV), SUBS COUNT. 44000013 NI VADV,255-DFLG / ENSURE FLAG IS OFF. 44200013 L RH,0(RF) A(ARRAY.ORIGIN). 44400013 N RH,MASK ENSURE UNWANTED BITS ARE 0. 44600013 TM 0(RE),FBIT + IS ITEM FIXED BIT STRING.. 44800013 BNE NFBIT NO. 45000013 LR RI,RH YES, COMPUTE BIT ADDRESS. 45200013 SLDL RH,3 BIT ADDRESS. 45400013 NFBIT ST RH,VORG ADDRESS OF ARRAY ORIGIN. 45600013 SPACE 45800013 * RE-ENTER HERE FOR ENTRY B OR C. 46000013 SPACE 46200013 DP010 LA BR,LVDA(RA) ADDRESS BOUNDS AND CURRENT SUBS 46400013 L RF,VADV ADDRESS ADV. 46600013 L RD,VSUB SUBSCRIPT COUNT. 46800013 LA RI,0(RD,RD) SUBS.CNT*4 47000013 AR RI,RI SUBS.CNT*8 47200013 LA RG,4(RI,RF) ADDRESS BOUNDS IN ADV 47400013 LA RJ,4(RF) ADDRESS MULTIPLIERS IN ADV. 47600013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 47800013 BM NNTRA NO. 48000013 SR RI,RI 48200013 LOOPA L RF,0(RI,RJ) MULTIPLIER FOR DIM N. 48400013 MH RF,LOWR(RI,RG) *LB. 48600013 ALR RH,RF INCREMENT ELEMENT ADDRESS. 48800013 LH RB,UPPR(RI,RG) UB. 49000013 LH RC,LOWR(RI,RG) LB. 49200013 STM RB,RC,0(BR) 49400013 LA RI,4(RI) NEXT UB/LB IN ADV. 49600013 LA BR,8(BR) NEXT FIELD IN VDA. 49800013 BCT RD,LOOPA LOOP ON SUBS COUNT. 50000013 LR RD,RH SAVE ADDRESS OF ELEMENT. 50400013 TM 0(RE),FIXT FIXED LENGTH STRING.. 50600013 BNE NFIXT NO. 50800013 LH RF,2(RI,RG) 51000013 STH RF,VSDV+CURL SET CURRENT LENGTH IN SDV. 51200013 SETEL LR RI,RH 51400013 TM 0(RE),FBIT FIXED LENGTH BIT STRING.. 51600013 BNE NFBTS NO. 51800013 SRDL RH,3 BYTE ADDR WITH BIT OFFSET. 52000013 NFBTS N RI,MASK 52100019 ST RI,VSDV 52200019 LA RH,VSDV ADDRESS SDV. 52400013 NFIXT ST RH,VELM ADDRESS OF ELEMENT. 52600013 TM WPFL,NTRY + TEST FOR ENTRY D. 52800013 BO NTRYD YES. 53000013 DPEXT L DR,OFDR(DR) RESTORE CALLER'S REGISTERS. 53200013 L LR,OFLR(DR) 53400013 LM R0,PWR,OFR0(DR) 53600013 BR LR X RETURN TO CALLER. 53800013 EJECT 54000013 NNTRA TM WPFL,NTRC + TEST FOR ENTRY C. 54200013 BO NTRYC YES. 54400013 SPACE 54600013 * OUTPUT SUBSCRIPTS. 54800013 SPACE 55000013 L RG,VVDA ADDRESS OF SUBSCRIPTS AREA SDV. 55200013 LR RI,RA SAVE ADDRESS OF VDA. 55400013 L RF,0(RG) ADDRESS OF AREA. 55600013 MVI 0(RF),C'(' MOVE IN OPEN PARENS. 55800013 LA RF,1(RF) 56000013 LOOPB L RA,4(BR) SUBSCRIPT. 56200013 CVD RA,DECM CONVERT 56400013 MVC EDIT,EDMK TO 56600013 LA RA,EDIT+5 EXTERNAL 56800013 LA RB,1(RA) DECIMAL 57000013 EDMK EDIT,DECM+5 SUPPRESSING LEADING ZEROS. 57200013 BNL POSVE BRANCH IF NOT NEGATIVE. 57400013 BCTR RA,0 INCLUDE - SIGN(EDIT FILL CHAR). 57600013 POSVE MVI 0(RB),C',' MOVE IN SEPARATING COMMA. 57800013 SR RB,RA NO. OF CHARS-1. 58000013 EX RB,DPMOV MOVE SUBSCRIPT TO VDA. 58200013 LA RF,1(RB,RF) 58400013 LA BR,8(BR) POINT TO NEXT SUBSCRIPT. 58600013 BCT RD,LOOPB LOOP ON SUBSCRIPT COUNT. 58800013 BCTR RF,0 END OF SUBSCRIPTS SO REPLACE 59000013 MVI 0(RF),C')' COMMA BY CLOSE PARENS. 59200013 LA RF,1(RF) 59400013 S RF,0(RG) COMPUTE CURRENT LENGTH OF AREA. 59600013 STH RF,6(RG) SET LENGTH OF SUBSCRIPTS FIELD 59800013 DROP RA 60000013 USING VDAD,RI USE RI TEMPORARILY. 60200013 TM VADV,DFLG + TEST FOR SINGLE ELEMENT. 60400013 DROP RI 60600013 USING VDAD,RA RESTORE TO TA. 60800013 BO FREVD 61000013 B DPEXT EXIT. 61200013 EJECT 61400013 * ADDRESS NEXT ELEMENT. 61600013 SPACE 61800013 NTRYC LR RC,RD 62000013 L RH,VELM ADDRESS PREVIOUS ELEMENT/SDV. 62200013 L RE,VDED ADDRESS DED. 62400013 TM 0(RE),FIXT + IS ITEM FIXED STRING.. 62600013 BNE NFXT2 NO. 62800013 L RH,0(RH) ADDRESS ELEMENT FROM SDV. 63000013 TM 0(RE),FBIT + IS ITEM FIXED BIT STRING.. 63200013 BNE NFXT2 NO. 63400013 LR RI,RH 63600013 SLDL RH,3 GET BIT ADDRESS. 63800013 NFXT2 LA RD,1 64000013 LA RE,0(RC,RC) SUBS.CNT*2 64200013 LA RI,0(RE,RE) SUBS.CNT*4 64400013 LA RE,0(RI,RI) SUBS.CNT*8 64600013 AR BR,RE 64800013 LOOPC SH BR,H008 65000013 SH RI,H004 65200013 A RH,0(RI,RJ) INCREMENT ELEMENT ADDRESS. 65400013 LM RE,RF,0(BR) CURRENT AND UPPER BOUNDS. 65600013 BXH RF,RD,NXTSB NEXT SUBS UNLESS END OF DIM. 65800013 ST RF,4(BR) 66000013 SR BR,BR SET RC=0 FOR ANOTHER ELEMENT. 66200013 L RE,VDED ADDRESS DED. 66400013 TM 0(RE),FIXT + IS ITEM FIXED STRING. 66600013 BNE NFIXT NO. 66800013 B SETEL YES, UPDATE ADDRESS IN SDV. 67000013 SPACE 2 67200013 NXTSB LR RE,RF 67400013 SH RE,LOWR(RI,RG) SET TO PREVIOUS DIMENSION. 67600013 M RD,0(RI,RJ) ADDRESS FIRST ELEMENT OF 67800013 SR RH,RE CURRENT DIMENSION. 68000013 LA RD,1 68200013 LH RE,LOWR(RI,RG) SET TO LOWER BOUND OF 68400013 ST RE,4(BR) CURRENT DIMENSION. 68600013 BCT RC,LOOPC LOOP ON SUBSCRIPT COUNT. 68800013 FREVD IHEPRV FVD,BR $$ NO MORE, FREE VDA 69000015 BALR LR,BR 69200013 LA BR,4 SET RC=4 FOR END OF ARRAY. 69400013 B DPEXT 69600013 EJECT 69800013 * COMPUTE SUBSCRIPTS FROM ELEMENT ADDRESS AND ADV. 70000013 SPACE 70200013 NTRYD OI VADV,DFLG / SET SINGLE ELEMENT FLAG. 70400013 LR RH,RD RESTORE ADDRESS OF ELEMENT. 70600013 L RD,VSUB SUBSCRIPT COUNT. 70800013 LA BR,LVDA(RA) RESET POINTERS TO BEGINNING 71000013 SR RI,RI OF FIELDS. 71200013 L RB,WPEL ADDRESS OF ELEMENT/SDV. 71400013 ST RB,VELM 71600013 LA RA,0(RB) ENSURE TOP BYTE IS ZERO. 71800013 TM 0(RE),FIXT + IS ITEM FIXED STRING.. 72000013 BNE CLRBYT NO 47607 72200056 L RA,0(RA) ADDRESS OF ELEMENT FROM SDV. 72400013 N RA,MASK ENSURE UNWANTED BITS ARE 0. 72600013 TM 0(RE),FBIT + IS ITEM FIXED BIT STRING.. 72800013 BNE CLRBYT NO 47607 73000056 LR R0,RA 73200013 SLDL R0,3 GET BIT ADDRESS. 73400013 LR RA,R0 73600013 B OFFST 47607 73620056 CLRBYT TM 0(RE),VBIT IS ITEM A BIT STRING 47607 73640056 BO OFFST YES 47607 73660056 * A47607 NOT FIXED FOR BIT STRINGS 47607 73680056 LA RH,0(RH) CLEAR TOP BYTE IN CAS V.O. 47607 73700056 * HAS NEGATIVE ADDRESS 47607 73720056 OFFST SR RA,RH 73800013 LOOPD SR R0,R0 74000013 D R0,0(RI,RJ) RA=S(I)-LB(I),R0=NEXT DIVIDEND. 74200013 AH RA,LOWR(RI,RG) SUBSCRIPT FOR DIMENSION. 74400013 ST RA,4(BR) 74600013 LR RA,R0 74800013 LA BR,8(BR) 75000013 LA RI,4(RI) 75200013 BCT RD,LOOPD LOOP ON SUBSCRIPT COUNT. 75400013 B DPEXT 75600013 EJECT 75800013 DPMOV MVC 0(*-*,RF),0(RA) 76000013 H008 DC H'8' 76200013 H004 DC H'4' 76400013 EDMK DC C'-' 76600013 DC X'2020202120' 76800013 DS 0F 77000013 MASK DC X'E0FFFFFF' 77200013 END 77800013 ./ ADD SSI=01012041,SOURCE=1,NAME=IHEDDTA DDT TITLE ' IHEDDT DATA DIRECTED OUTPUT (TASKING) *00300016 OS/360 PL/I LIBRARY' 00600013 * VERSION FOURTH VERSION OF F-LEVEL PL/I COMPILER 00900015 * 01200013 * STATUS CHANGE LEVEL - 0 01500013 * 01800013 * SIZE 768 BYTES 02100015 * 02400013 * FUNCTION 02700013 * 1)A)TO WRITE AN ITEM ONTO THE SPECIFIED FILE ACCORDING 03000013 * TO THE RULES SPECIFIED FOR DATA DIRECTED OUTPUT AND 03300013 * B)TO TERMINATE THE ABOVE TRANSMISSION OR 03600013 * 2)TO WRITE A DATA VARIABLE ONTO THE SYSTEM OUTPUT 03900013 * FILE AS PART OF THE SYSTEM ACTION FOR THE CHECK ON 04200013 * CONDITION. 04500013 * 04800013 * IF THE ITEM IS AN ARRAY THEN THE ARRAY IS OUTPUT ELEMENT 05100013 * BY ELEMENT(ENTRY POINT IHEDDOA) OR THE SPECIFIED ELEMENT 05400013 * IS OUTPUT(ENTRY POINTS IHEDDOB AND IHEDDOD). THE 05700013 * SUBSCRIPTS ARE OUTPUT (AND ELEMENT ADDRESSES CALCULATED) 06000013 * BY CALLS TO MODULE IHEDDP. 06300013 * IF THE SPECIFIED FILE IS A 'PRINT' FILE THE 06600013 * DATA IS TABBED AND SPANNING OF LINES IS AVOIDED, IF 06900013 * POSSIBLE, FOR ARITHMETIC DATA. 07200013 * TO ACHIEVE THIS END, NO DATA IS PUT OUT BY THIS 07500013 * MODULE BUT IS PASSED TO MODULE IHELDO FOR TRANSMISSION. 07800013 * 08100013 * ENTRY POINTS 08400013 * IHEDDOA (SCALARS OR WHOLE ARRAYS) 08700013 * RA = A(PLIST) 09000013 * PLIST = A(SYMTAB ENTRY-VARAIBLE) 09300013 * ...... 09600013 * IHEDDOB (ELEMENT OF ARRAY) 09900013 * RA = A(PLIST) 10200013 * PLIST = A(SYMTAB ENTRY-ARRAY) 10500013 * A(ELEMENT IN ARRAY) 10800013 * ...... 11100013 * ...... 11400013 * IHEDDOC (TERMINATION) 11700013 * NO PARAMETERS. 12000013 * IHEDDOD (CHECK ON CONDITION) 12300013 * RA = A(PLIST) 12600013 * PLIST = A(SYMTAB ENTRY FOR VARIABLE) 12900013 * A(VARIABLE/ELEMENT OF ARRAY) 13200013 * 13500013 * INPUT 13800013 * ENTRY POINTS IHEDDOA,IHEDDOB,IHEDDOC. 14100013 * CURRENT FILE PSEUDO-REGISTER (IHEQCFL) 14400013 * ENTRY POINT IHEDDOD. 14700013 * SYSPRINT FILE REGISTER (IHEQSPR). 15000013 * 15300013 * OUTPUT 15600013 * SEE FUNCTION. 15900013 * 16200013 * EXTERNAL MODULES 16500013 * IHEDDP - 1) PREPARE ARRAY. 16800013 * 2) OUTPUT SUBSCRIPTS. 17100013 * 3) ADDRESS NEXT ELEMENT (ENTRY POINT IHEDDOA). 17400013 * IHEPRT - PREPARE SYSPRINT FILE. 17700013 * IHELDO - OUTPUT VALUE PART. 18000013 * 18300013 * EXITS NORMAL 18600013 * RETURN VIA LINK REGISTER. 18900013 * 19200013 * TABLES/WORK AREA 19500013 * 19800013 * ATTRIBUTES READ ONLY AND REENTRANT 20100013 * 20400013 * PRIVATE MACROS 20700013 * IHELIB,IHEPRV,IHESDR,IHEZAP 21000013 * 21300013 * ASSEMBLY REQUIREMENTS 21600013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 21900013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 22200013 * 22500013 * NOTES 22800013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 23100013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 23400013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 23700013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 24000013 * CONSTANTS, BY REASSEMBLY, WILL RESULT IN A CORRECT 24300013 * MODULE FOR THE NEW DEFINITIONS. 24600013 EJECT 24900013 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 25200013 PUNCH ' LIBRARY *(IHEDDPA,IHEDDPB,IHEDDPC,IHEDDPD) /25500013 DDO0000A' 25800013 SPACE 26100013 IHEDDT CSECT 26400016 IHEQSPR DXD A 26700013 IHEZAP 27000013 IHELIB 27300013 SYMTABF DSECT 27600013 SPTR DS A ADDRESS OF NEXT ENTRY/0. 27900013 SNAM DS 256C 28200013 SPACE 2 28500013 SYMTABE DSECT 28800013 SSUB DS 0X DIM OF ARRAY (0 FOR SCALAR). 29100013 SDED DS A ADDRESS OF VARIABLE DED. 29400013 SFLG DS 0B FLAGS 29700013 SADD DS A ADDR/OFFSET OF VARIABLE. 30000013 SPRO DS H OFFSET IN PRV TO DISPLAY PTR. 30300013 SPACE 2 30600013 ONCK EQU B'01000000' ON CHECK VARIABLE (INPUT) 30900013 CLSS EQU B'00000011' 31200013 NSTC EQU X'01' 31500013 SPACE 2 31800013 IHEZLW4 DSECT 32100013 DS 18F 32400013 WPFL DS 0B 32700013 WPRA DS A 33000013 WVDA DS A 33300013 WSUB DS 2A SDV FOR SUBSCRIPTS VDA. 33600013 WNAM DS A ADDR OF DATA VARIABLE NAME. 33900013 TEMP DS 2D 33940015 PEQ1 DS A 33980015 PEQ2 DS A 34020015 PEQ3 DS A 34060015 QUAR DS 2A 34100015 OFCF EQU 72 34140015 SPACE 34200013 PWR EQU WR 34500013 NTRY EQU 6 34800013 NTCD EQU 4 35100013 NTRD EQU 2 35400013 NTRE EQU B'10000000' 35500015 STRN EQU X'80' 35700013 EJECT 36000013 IHEDDT CSECT 36200016 ENTRY IHEDDTA,IHEDDTB,IHEDDTC,IHEDDTD,IHEDDTE 36400016 IHEDDTA NOPR 0 ENTRY FOR SCALAR/WHOLE ARRAYS 36600016 IHEDDTB NOPR 0 ENTRY FOR ELEMENT OF ARRAY 36800016 IHEDDTC NOPR 0 ENTRY TO TERMINATE DDO 37000016 IHEDDTD NOPR 0 ENTRY FRON ERR (ON CHECK) 37200016 IHEDDTE STM LR,PWR,OFLR(DR) ENTRY FOR ALL KNOWN ITEMS 37400016 BALR PWR-1,0 38100013 USING *,PWR-1 38400013 IHESDR LW4,PWR UPDATE SAVE AREA POINTER. 38700013 USING IHEZLW4,DR 39000013 ST RA,WPRA SAVE P.LIST POINTER. 39300013 STC BR,WPFL SET ENTRY POINT FLAGS. 39600013 NI WPFL,255-NTRE 39680015 LA BR,0(BR) 39760015 C BR,VDDOE ENTRY POINT DDOE.. 39840015 BNE NDDOE NO. 39920015 OI WPFL,NTRE 40000015 NDDOE SR RE,RE 40080015 STH RE,WSUB+6 INIT CUR LENGTH TO ZERO. 40200013 TM WPFL,NTCD + TEST FOR ENTRY C OR D. 40500013 BO DODDC YES. 40800013 DODDR TM WPFL,NTRY + TEST FOR ENTRY A OR D. 41100013 BO DODDA ENTRY D. 41400013 BZ DDFLE ENTRY A. 41700013 L RB,4(RA) NO, ADDRESS ELEMENT FROM P.LIST 42000013 SPACE 42300013 DDFLE IHEPRV CFL,RC ADDRESS DCLCB FOR FILE. 42600013 USING IHEZDCL,RC 42900013 LH RC,DPRO 43200013 L RC,0(RC,PR) ADDRESS FCB FOR FILE. 43500013 SPACE 43800013 USING IHEZAPE,RC 44100013 DODAR L RG,0(RA) ADDRESS SYMTAB ENTRY. 44400013 USING SYMTABF,RG 44700013 SR RE,RE 45000013 IC RE,SNAM GET LENGTH OF NAME. 45300013 LA RG,8(RE,RG) 45600013 N RG,ALGN ADDRESS 2ND PART OF SYMTAB. 45900013 USING SYMTABE,RG 46200013 CLI SSUB,0 IS IT AN ARRAY VARIABLE.. 46500013 BE DODR2 NO, SCALAR. 46800013 LR RD,RB ADDRESS OF ELEMENT(NOT ENTRY A) 47100013 LA RB,WSUB ADDRESS SUBSCRIPTS AREA SDV. 47400013 LR RH,RC SAVE ADDRESS OF FCB. 47700013 LR RC,RG ADDRESS OF 2ND PART OF SYMTAB. 48000013 LR RG,RA SAVE P.LIST POINTER. 48300013 SR RA,RA 48600013 DROP RG 48900013 USING SYMTABE,RC 49200013 IC RA,SSUB DIMENSIONALITY. 49500013 DROP RC 49800013 MH RA,H007 COMPUTE MAX AREA REQUIRED FOR 50100013 LA RA,1(RA) SUBSCRIPTS. 50400013 STH RA,WSUB+4 50700013 LA R0,8(RA) 51000013 IHEPRV VDA,BR $$ GET VDA TO HOLD SUBSCRIPTS 51300015 BALR LR,BR 51600013 LA RA,8(RA) ADDRESS AREA FOR SUBSCRIPTS. 51900013 ST RA,WSUB COMPLETE SDV FOR AREA. 52200013 LA RA,WVDA CELL FOR A(ARRAY.VDA). 52500013 L BR,VDDPA $$ INITIALIZE FOR WHOLE ARRAY. 52800013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 53100013 BNL CLDDP YES. 53400013 L BR,VDDPD $$ INITIALIZE FOR SINGLE ELEMENT. 53700013 CLDDP BALR LR,BR CALL INDEXER (INITIALIZATION). 54000013 LR RA,RG RESTORE P.LIST POINTER. 54300013 LR RC,RH AND ADDRESS OF FCB. 54600013 * RE-ENTER HERE FOR NEXT ELEMENT OF ARRAY VARIABLE. 54900013 NXTEL L RB,WVDA ADDRESS ARRAY VDA. 55200013 L RB,0(RB) ADDRESS OF ELEMENT 55500013 DODR2 L RG,0(RA) ADDRESS SYMTAB ENTRY. 55800013 USING SYMTABF,RG 56100013 LA RF,SNAM ADDRESS OF NAME FIELD. 56400013 ST RF,WNAM 56700013 SR RE,RE 57000013 IC RE,0(RF) GET LENGTH OF NAME 57300013 LA RG,8(RE,RG) 57600013 N RG,ALGN ADDRESS WORD BOUNDARY AFTER NM. 57900013 USING SYMTABE,RG 58200013 CLI SSUB,0 IS IT AN ARRAY VARIABLE.. 58500013 BNE SUBSC YES, OUTPUT SUBSCRIPTS. 58800013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 59100013 BNL DELLA YES, ADDR ELEMENT FROM SYMTAB. 59400013 STTIC EQU * 59700013 LR RA,RB ADDRESS SOURCE ITEM 60000013 L RB,SDED ADDRESS SOURCE DED 60300013 TM 0(RB),X'88' TEST FO CAD. 60320015 BNO CALLC NO. 60340015 TM 0(RB),X'06' 60360015 BZ CALLC FIXED DECIMAL. 60380015 LA BR,4 60400015 TM 0(RB),X'11' FLT LONG AND COMPLEX.. 60420015 BZ MOVES NEITHER MOVE 4 BYTES. 60440015 BM MOVEL ONE OR T'OTHER MOVE 8 BYTES. 60460015 AR BR,BR BOTH MOVE 16 BYTES. 60480015 MOVEL AR BR,BR 60500015 MOVES BCTR BR,0 60520015 EX BR,MVCAD MOVE DATA TO TEMP. 60540015 LA RA,TEMP 60560015 CALLC EQU * 60580015 L RD,WNAM GET ADDRESS OF NAME FIELD. 60600013 LA RE,WSUB 60900013 L BR,VLDOC $$ OUTPUT USING LIST OUTPUT. 61200013 BALR LR,BR 61500013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 61800013 BL NDLST NOT ENTRY A OR D. 62100013 DDLAB CLI SSUB,0 IS IT AN ARRAY VARIABLE.. 62400013 BE NDLST NO. 62700013 L RA,WVDA ADDRESS OF ARRAY VDA. 63000013 L BR,VDDPC $$ ADDRESS NEXT ELEMENT. 63300013 BALR LR,BR 63600013 L RA,WPRA RESTORE P.LIST POINTER. 63900013 LTR BR,BR IS IT THE END OF THE ARRAY.. 64200013 BZ NXTEL NO, OUTPUT NEXT ELEMENT. 64500013 NDLST CLC WSUB+6(2),ZERO TEST FOR ARRAY DATA ITEM. 64800013 BE DOXXX NO. 65100013 IHEPRV FVD,BR $$ FREE VDA FOR SUBSCRIPTS AREA 65400015 BALR LR,BR 65700013 SR BR,BR 66000013 STH BR,WSUB+6 RESET LENGTH OF SUBSCRIPTS. 66300013 DOXXX L RA,WPRA P.LIST POINTER. 66600013 TM WPFL,NTRY + TEST FOR ENTRY A OR D. 66900013 BO DODDD ENTRY D. 67200013 BZ NTRAE ENTRY A OR E. 67500015 LA RA,4(RA) ADDRESS 2ND WORD OF P.LIST. 67800013 NTRYA TM 0(RA),X'80' + TEST FOR END OF P.LIST. 68100013 BO DOEXT YES. 68400013 LA RA,4(RA) ADDRESS NEXT ENTRY. 68700013 NTRYE IC BR,WPFL 69000015 ST RA,WPRA 69300013 STC BR,WPFL 69600013 B DODDR OUTPUT NEW VARIABLE. 69900013 DOEXT L DR,OFDR(DR) RESTORE DR. 70200013 LM LR,PWR,OFLR(DR) RESTORE OTHER REGISTERS. 70500013 BR LR X RETURN. 70800013 SPACE 70830015 NTRAE TM WPFL,NTRE TEST FOR DDOE ENTRY. 70860015 BZ NTRYA 70890015 L RA,0(RA) ADDRESS CURRENT SYMTAB 70920015 L BR,0(RA) ADDRESS NEXT SYMTAB 70950015 LTR BR,BR ..IS THERE ONE.. 70980015 BZ DODDD NO. 71010015 B NTRYE 71040015 SPACE 71100013 DODDA LR RE,RB 71200015 LA PWR,1 INDICATE ENQ 71300015 BAL RG,ENQ DO IT 71400015 LA RB,ZERO SET FOR FILE CHECK ONLY. 71700013 L BR,VPRTB $$ CALL SYSPRINTER TO CHECK FOR 72000013 BALR LR,BR SYSPRINT FILE. 72300013 LR RB,RE 72600015 L RA,WPRA RESTORE P.LIST POINTER. 72900013 IHEPRV SPR,RC ADDRESS DCLCB FOR SYSPRINT. 73200013 LTR RC,RC IS FILE OPEN.. 73500013 BP DODAR YES, AND AT A NEW LINE. 73800013 B DOEXT NO FILE - REQUEST IGNORED. 74100013 SPACE 74400013 DODXT LR RA,RC 74700013 USING IHEZAPE,RC 75000013 DOOUT L BR,VIOFA $$ OUTPUT LINE. 75300013 BALR LR,BR 75600013 TM WPFL,NTRY WKICH ENTRY POINT.. 75650015 BNO DOEXT NOT D - THATS OK THEN 75700015 SR PWR,PWR 75750015 BCTR PWR,0 INDICATE DEQ 75800015 BAL RG,DEQ 75850015 B DOEXT RETURN TO ERROR PACKAGE. 75900013 SPACE 76200013 DODDC TM WPFL,NTRD + TEST FOR ENTRY D. 76500013 BO DODDR YES. 76800013 IHEPRV CFL,RC ADDRESS DCLCB FOR FILE. 77100013 USING IHEZDCL,RC 77400013 LH RC,DPRO 77700013 L RC,0(RC,PR) ADDRESS FCB FOR FILE. 78000013 USING IHEZAPE,RC 78300013 DODDD L RD,TCBA 78600013 BCTR RD,0 ADDRESS LAST USED BYTE. 78900013 MVI 0(RD),C';' MOVE TERMINATING SEMI-COLON. 79200013 TM WPFL,NTRY + TEST FOR ENTRY D. 79500013 BO DODXT YES. 79800013 B DOEXT NO. 80100013 SPACE 80400013 DELLA L RB,SADD ADDR/OFFSET OF VARIABLE/DV. 80700013 L LR,SDED ADDRESS DED. 81000013 TM SFLG,CLSS TEST FOR STATIC. 81300013 BZ STTIC YES. 81600013 LH BR,SPRO OFFSET TO ANCHOR/DISPLAY CELL. 81900013 A RB,0(BR,PR) ADDRESS OF VARIABLE/DV. 82200013 TM SFLG,NSTC TEST FOR STRUCTURE. 82500013 BO STTIC NO. 82800013 TM 0(LR),STRN TEST FOR STRING. 83100013 BZ STTIC YES. 83400013 L RB,0(RB) ADDRESS ELEMENT FROM STRUCTDV. 83700013 B STTIC 84000013 SPACE 84300013 SUBSC L RA,WVDA ADDRESS OF ARRAY VDA. 84600013 L BR,VDDPB $$ INDEXER TO OUTPUT SUBSCRIPTS. 84900013 BALR LR,BR 85200013 B STTIC 85500013 SPACE 85800013 ENQ IHEPRV SPR,RC 85810015 LTR RC,RC OPEN.. 85820015 BCR 8,RG 85830015 BM DOEXT CANNOT BE OPENED 85840015 DEQ LA RB,0(0,RC) 85860016 LR RA,RB 85880015 LA BR,QUAR 85890015 L LR,EQLST 85900015 LR RI,DR 85910015 DSANG L RI,4(0,RI) CHAIN TO LAST DSA 85920015 TM 0(RI),X'80' 85930015 BZ DSANG 85940015 LA R0,OFCF(0,RI) 85950015 STM LR,RB,PEQ1 SET UP PLIST FOR ENQ/DEQ 85960015 LA RA,PEQ1 85970015 IC RB,OFCF(0,RI) 85980015 ALR RB,PWR UP/DOWN DATE DSA COUNT 85990015 LTR PWR,PWR 86000015 BP EXEQ 86010015 STC RB,OFCF(0,RI) 86020015 DEQ ,MF=(E,(1)) 86030015 BR RG 86040015 EXEQ ENQ ,MF=(E,(1)) 86050015 STC RB,OFCF(0,RI) 86060015 BR RG 86070015 SPACE 86080015 ZERO DC H'0' 86100013 H007 DC H'7' 86400013 MVCAD MVC TEMP(*-*),0(RA) 86420015 DS 0F 86440015 EQLST DC X'FF010000' 86460015 VDDOE DC V(IHEDDTE) 86560016 VIOFA DC V(IHEIOFA) 86700013 VLDOC DC V(IHELDOC) 87600013 VPRTB DC V(IHEPTTB) 87900016 VDDPA DC V(IHEDDPA) 88200013 VDDPB DC V(IHEDDPB) 88500013 VDDPC DC V(IHEDDPC) 88800013 VDDPD DC V(IHEDDPD) 89100013 ALGN DC X'FFFFFFFC' 89400013 END 89700013 ./ ADD SSI=05010650,SOURCE=1,NAME=IHEDIAA DIA TITLE ' IHEDIA F/E FORMAT INPUT DIRECTOR *00300013 O/S 360 PL/1 LIBRARY' 00600013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00900013 SPACE 1 00970019 * R19 423000,* H438 01040019 SPACE 1 01110019 * 01200013 * STATUS CHANGE LEVEL - 0 01500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIA000-TSS 01600001 * ----------------------------------------------------DIA000-TSS 01700001 * 01800013 * SIZE 778 BYTES 02100001 * 02400013 * FUNCTION TO DIRECT THE CONVERSION OF EXTERNAL DATA 02700013 * OF F OR E FORMAT TO ANY INTERNAL DATA TYPE 03000013 * 03300013 * ENTRY POINTS 03600013 * IHEDIAA - F FORMAT INPUT 03900013 * RA = A(TARGET) 04200013 * RB = A(TARGET DED) 04500013 * RC = A(SOURCE FED) 04800013 * IHEDIAB - E FORMAT INPUT 05100013 * CF IHEDIAA 05400013 * 05700013 * INPUT BIT SET IN SWITCH WSWA IN LCA IF THIS MODULE CALLED BY 06000013 * 'C' FORMAT DIRECTOR 06300013 * OUTPUT N/A 06600013 * 06900013 * EXTERNAL MODULES 07200013 * IHEIODG- REQUEST ADDRESS OF EXTERNAL DATUM 07500013 * IHEIODT- SIGNAL CONVERSION COMPLETE 07800013 * IHEDMAA- ARITHMETIC CONVERSION DIRECTOR 08100013 * IHEUPA/IHEUPB - ZERO IMAGINARY PART OF COMPLEX 08400013 * CODED OR NUMERIC TARGET 08700013 * IHEDNC - ARITHMETIC TO CHARACTER STRING DIRECTOR 09000013 * IHEDNB - ARITHMETIC TO BIT DIRECTOR 09300013 * IHEVSC - CHARACTER STRING ASSIGNMENT ROUTINE 09600013 * IHEVSA - BIT STRING ASSIGNMENT ROUTINE 09900013 * IHEVCA - DYNAMIC CONSTANT ANALYSER ROUTINE 10200013 * 10500013 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 10800013 * ABNORMAL - END FILE SIGNALLED 11100013 * 11400013 * TABLES/WORKAREA 11700013 * WORKAREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 12000013 * 12300013 * ATTRIBUTES READ ONLY AND REENTRANT 12600013 * 12900013 * PRIVATE MACROS 13200013 * IHELIB,IHEPRV,IHESDR 13500013 * 13800013 * ASSEMBLY REQUIREMENTS 14100013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 14400013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 14700013 * 15000013 * NOTE SEE O/S360 PL/1 LIBRARY PLM FOR DESCRIPTION OF 15300013 * LIBRARY CONVENTIONS AND STANDARDS. 15600013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 15900013 * 1 PARTICULAR INTERNAL REPRESENTATION OF THE 16200013 * EXTERNAL CHARACTER SET. 16500013 EJECT 16800013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIA001-TSS 16900001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 17100013 PUNCH ' LIBRARY *(IHEDMAA,IHEUPAB,IHEUPBB,IHEDNCA,IHEDNBA,/17400013 IHEVSCA,IHEVSAA) DIA0000A' 17700013 PUNCH ' LIBRARY *(IHEVCAA,IHEVQBA) /18000013 DIA0000B' 18300013 * ----------------------------------------------------DIA001-TSS 18400001 SPACE 18600013 IHEDIA CSECT 18900013 IHELIB 19200013 IHEZAP 19260001 TMVD EQU X'40' VDA USED SWITCH. 19320001 TCFL EQU X'04' XMIT STACK FLAG. 19380001 ERR1 EQU X'9802' ON-CODE FOR INPUT TRANSMIT. 19440001 IHEZLW3 DSECT 19500013 DS 15D 19800013 WORK EQU IHEZLW3 20100013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIA002-TSS 20300001 * ----------------------------------------------------DIA002-TSS 20500001 IHEDIA CSECT 20700013 ENTRY IHEDIAA 21000013 ENTRY IHEDIAB 21300013 USING IHEZLCA,WR 21600013 USING IHEZLW3,DR 21900013 IHEDIAA NOPR 0 F FORMAT ENTRY POINT 22200013 IHEDIAB STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 22500013 BALR RJ,0 SET UP ADDRESSABILITY 22800013 USING *,RJ 23100013 TM OFBR+3(DR),X'02' TEST ENTRY POINT 23700013 IHESDR LW3,WR UPDATE SAVE AREA POINTER 24000013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 24300013 ST RC,WFED SAVE FED POINTER 24600013 LR RC,RA SET TARGET 24900013 LR RD,RB PARAMETERS 25200013 BZ SFMAT BRANCH IF F FORMAT ENTRY 25500013 LA RB,EDED SET FOR E FORMAT 25800013 IHEPRV ERR,RE,OP=LA 26100013 OI 1(RE),FMTE SET UP E-FORMAT TYPE SOURCE 26400013 SIOBT OI 0(RE),IOBT 26700013 ST RB,PWRK+8 26800015 SR RF,RF GET W 27000013 L RE,WFED FROM FED. 27200001 AH RF,0(RE) 27400001 BNH TSTRG BRANCH IF W ZERO OR MINUS 27600013 TM WSWA,X'40' TEST WHO CALLED 27900013 BO TESTC BRANCH IF C FORMAT 28200013 STH RF,WSDV+6 SET UP FIELD WIDTH 28500013 USING IHEZAPE,RH DEFINE BASE-REG. FOR DCBAPE. 28520001 IHEPRV CFL,RA ADDRESS CFL FCB, 28540001 LH RA,DPRO-IHEZDCL(RA) VIA DCLCB, 28560001 L RH,0(RA,PR) THEN FILE REGISTER. 28580001 LR RA,RC RESTORE RA. 28600001 TM TFLX,TMEF ENDFILE ALREADY ENCOUNTERED.. 28620001 BO CIODG YES. CALL IODG. 28640001 MVC WSDV+4(2),WSDV+6 28660001 NI WONC+2,255-TMVD CLEAR VDA ALLOCATED FLAG. 28680001 NI TFLX,255-TMIT-TMLC UNSET TMIT AND TMLC FLAGS. 28700001 IHEPRV CFL,BR,OP=LA 28720001 NI 4(BR),255-TCFL UNSET XMIT FLAG. 28740001 TM TFLX,TMIE IS INPUT TRANSMIT ON FOR BLOCK.. 28760001 BZ TYPES NO. 28780001 NC TREM,TREM ANY LEFT IN BUFFER.. 28800001 BZ TYPES NO. 28820001 OI TFLX,TMIT YES. SET DATAFIELD TRANS. ON. 28840001 OI 4(BR),TCFL SET XMIT FLAG. 28860001 TYPES LH RI,TREM NUMBER OF BYTES LEFT IN RECORD. 28880001 CH RI,WSDV+6 BYTES WANTED GT.CURRENT REC.. 28900001 BL CIODG YES. CALL IODG. 28920001 L RI,TCBA SET A(DATAFIELD) WITHIN 28940001 ST RI,WSDV BUFFER FOR CALLER. 28960001 TM TFIO,TMCY GET WITH COPY OPTION.. 28980001 BO CIODG YES. CALL IODG. 29000001 TM WONC+2,TMVD NO. VDA ALLOCATED.. 29020001 BO RETUR YES. 29040001 AH RI,WSDV+6 NO. UPDATE BUFFER PTRS. 29060001 ST RI,TCBA 29080001 LH RI,TREM 29100001 SH RI,WSDV+6 29120001 STH RI,TREM 29140001 B RETUR 29160001 CIODG L BR,IODG GET FIELD ADDRESS 29180001 BALR LR,BR WITHIN BUFFER. 29200001 LTR BR,BR TEST RETURN CODE 29400013 BNZ ABNRM BRANCH IF NOT ZERO 29700013 RETUR MVC WOFD(8),WSDV SET ON-SOURCE DOPE VECTOR. 30000001 LA LR,RETRY STORE RETRY ENTRY POINT 30300013 STM DR,LR,WCNV AND SAVE AREA ADDRESS IN LCA 30600013 TESTC L RA,WSDV SET SOURCE POINTER 30900013 TM 0(RD),STRG TARGET TYPE STRING 31200013 BZ STRNG YES,BRANCH 31500013 TM 0(RD),CADD TEST FOR C.A.D. TARGET. 31800013 BO QPOSS YES. 32100013 QGONE L BR,DMAA CALL ARITHMETIC 32400013 BALR LR,BR CONVERSION DIRECTOR 32700013 TCOMP TM WSWA,CPLX TEST COMPLEX FORMAT SWITCH 33000013 BO ENDRT BRANCH IF SET 33300013 TM 0(RD),MODE TEST MODE OF TARGET 33600013 BO CALUP BRANCH IF COMPLEX 33900013 ENDRT TM WSWA,X'40' TEST WHO CALLED 34200013 BO FINIS BRANCH IF C FORMAT 34500013 L RI,TCNT BUMP COUNT VALUE. 34550001 LA RI,1(RI) 34600001 ST RI,TCNT 34650001 TM TFLX,TMIT INPUT TRANSMIT ON DATAFIELD.. 34700001 BZ ALLOC NO. 34750001 LH RI,ERRB YES. SET ERROR CODE. 34800001 IHEPRV ERR,RI,OP=STH 34850001 LR RE,RA SAVE RA. 34900001 L RA,TDCL GET A(DCLCB). 34950001 L BR,VERRB 35000001 BALR LR,BR TELL EXEP. 35050001 LR RA,RE RESTORE RA. 35100001 ALLOC TM WONC+2,TMVD VDA ALLOCATED.. 35150001 BZ FINIS NO. 35200001 NI WONC+2,TMVD YES. UNSET FLAG. 35250001 IHEPRV FVD,BR 35300001 BALR LR,BR FREE VDA. 35350001 FINIS SR RE,RE ZERO REGISTER 35400013 IHEPRV ERR,RE,OP=STH RESET ERROR CODE 35700013 L DR,OFDR(DR) RESET SAVE AREA POINTER 36000013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 36300013 SR BR,BR SET CODE FOR NORMAL RETURN 36600013 BR LR EXIT 36900013 ABNRM TM WSWA,X'40' TEST C FORMAT SWITCH 37200013 L DR,OFDR(DR) RESET SAVE AREA POINTER 37500013 BO CFRMT BRANCH IF SWITCH SET 37800013 IHEPRV CFL,BR,OP=LA 38100013 L LR,4(BR) LOAD ADDRESS OF NEXT STATEMENT 38400013 LM RB,WR,OFRB(DR) RESTORE CALLERS REGISTERS 38700013 BR LR EXIT 39000013 CFRMT LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 39300013 BR LR EXIT 39600013 CALUP LR RA,RC SET PARAMETERS 39900013 LR RB,RD FOR CALL 40200013 L BR,UPAB SET FOR CODED TARGET 40500013 TM 0(RB),CODE TEST TARGET TYPE 40800013 BO CALLR BRANCH IF CODED 41100013 L BR,UPBB SET FOR NUMBERIC TARGET 41400013 CALLR BALR LR,BR CALL ZERO IMAG.PART ROUTINE 41700013 B ENDRT 42000013 RETRY EQU * RE-ESTABLISH I/O AND SOURCEH438 42040019 * ENVIRONMENT IN ERROR SLOT. H438 42080019 * IN CASE ERROR IS RAISED AGAIN. 42120019 L RF,OFDR(DR) ADDRESS PREVIOUS SAVE AREA.H438 42160019 IHEPRV ERR,RE,OP=LA GET ERROR SLOT IN PRV. H438 42200019 TM OFBR+3(RF),X'02' TEST ENTRY POINT. H438 42240019 BZ RETRY1 BRANCH IF F-FORMAT. H438 42280019 OI 1(RE),FMTF INDICATE F-FORMAT TYPE SOURCE. 42320019 B RETRY2 H438 42360019 RETRY1 OI 1(RE),FMTE INDICATE E-FORMAT TYPE SOURCE. 42400019 RETRY2 OI 0(RE),IOBT INDICATE I/O OPERATIVE. H438 42440019 L RF,WFED GET ADDRESS OF FED. H438 42480019 LH RF,0(RF) RESTORE FIELD WIDTH 42600013 B TESTC GO TRY CONVERSION AGAIN 42900013 STRNG LA RG,WCN1 SET DESCRIPTOR POINTER 43200013 ST RG,WCNP IN COMMUNICATION AREA 43500013 ST RA,WCN1 SET DATA START ADDRESS 43800013 AR RF,RA CALC.END ADDRESS 44100013 BCTR RF,0 AND STORE 44400013 ST RF,WCN1+4 IN DESCRIPTOR 44700013 LA RA,PWRK ALLOCATE DED 45000013 L BR,VCAA CALL 45300013 BALR LR,BR DATA ANALYSIS ROUTINE 45600013 B STAR4(BR) TEST RETURN CODE 45900013 STAR4 B ADDDS BRANCH IF ZERO 46200013 TESTF CLI 0(RB),FMAT TEST FOR F-FORMAT 46500013 BNE SETDD 46800013 SR RF,RF ZERO REGISTERS 47100013 LR RG,RF 47400013 IC RF,PWRK+2 GET S FROM CREATED DED 47700013 L RE,WFED 47900001 IC RG,3(RE) GET S FROM FED. 48100001 SR RF,RG COMBINE 48300013 AH RF,K128 RESTORE EXCESS 48600013 STC RF,PWRK+2 STORE IN CREATED DED 48900013 SETDD MVC PWRK(1),0(RB) SET TRUE FORMAT FLAG BYTE 49200013 LA RB,PWRK SET SOURCE DED POINTER 49500013 L RA,WSDV SET SOURCE POINTER 49800013 L BR,DNCA SET FOR CHARACTER STRING TARGET 50100013 TM 0(RD),CHAR TEST TARGET TYPE 50400013 BO CALLR BRANCH IF CHARACTER 50700013 L BR,DNBA SET FOR BIT STRING TARGET 51000013 B CALLR GO CALL ASSIGNMENT ROUTINE 51300013 SFMAT LA RB,FDED SET FOR F FORMAT 51600013 IHEPRV ERR,RE,OP=LA 51900013 OI 1(RE),FMTF SET UP F-FORMAT TYPE SOURCE 52200013 B SIOBT 52500013 TSTRG TM 0(RD),STRG TEST TARGET TYPE 52800013 BO FINIS BRANCH NOT STRING 53100013 LA RA,NULD SET NULL DOPE VECTOR POINTER 53400013 LA RB,CDED SET FOR CHARACTER STRING 53700013 L BR,VSCA SET TO ASSIGN CHAR STRING 54000013 TM 0(RD),CHAR TEST TARGET STRING TYPE 54300013 BO CALSA BRANCH IF CHARACTER 54600013 LA RB,BDED SET FOR BIT STRING 54900013 L BR,VSAA SET TO ASSIGN BIT STRING 55200013 CALSA BALR LR,BR CALL ASSIGNMENT ROUTINE 55500013 B FINIS 55800013 ADDDS SR RF,RF 56100013 L RE,WFED 56300001 IC RF,2(RE) GET D FROM FED. 56500001 AH RF,K128 ADD EXCESS 56700013 STC RF,PWRK+2 STORE IN CREATED FED 57000013 B TESTF 57300013 SPACE 57600013 QPOSS EQU * 58200001 NI WSWB,255-3 RESET SWITCH BITS. 58800013 L RB,PWRK+8 58900015 TM 0(RB),FLOT SET 59100013 BZ QEFFF WSWB 59400013 OI WSWB,2 ACCORDING 59700013 B QCALL TO 60000013 QEFFF OI WSWB,1 FORMAT. 60300013 QCALL EQU * 60400001 L BR,VQBA GET A(IHEVQB). 60500001 LTR BR,BR IS THE MODULE PRESENT. 60600001 BZ QGONE NO. USE IHEDMA. 60700001 LH BR,0(BR) GET TOP TWO BYTES OF VCON. 60707001 CH BR,XFER + IS IT A TRANSFER VECTOR. 60714001 L BR,VQBA GET VCON ONCE AGAIN. 60721001 BNE SHRLIB * NO. MUST BE A(CONV MODULE). 60728001 LR R0,RA SAVE REGISTER ONE. 60735001 LH LR,2(BR) STEP DOWN TRANSFER 60742001 LH RA,6(BR) VECTOR UNTILL THE 60749001 L BR,0(LR,PR) REAL VCON IS 60756001 L BR,0(RA,BR) LOADED INTO BR. 60763001 LR RA,R0 RESTORE REGISTER ONE. 60770001 LTR BR,BR + IS THE MODULE PRESENT. 60777001 BZ QGONE * NO. USE IHEDMA. 60784001 SHRLIB EQU * 60791001 LR RB,RA YES. USE IHEVQB. 60800001 L RE,WFED 60900013 AH RB,0(RE) 61200013 BCTR RB,0 FIND LAST CHARACTER. 61500013 QLOOP CLI 0(RA),C' ' REMOVE LEADING BLANKS. 61800013 BNE QTAIL 62100013 CR RA,RB ALL BLANK ? 62400013 BE CVQBA YES. 62700013 LA RA,1(RA) FIND FIRST NON-BLANK CHARACTER. 63000013 B QLOOP 63300013 QTAIL CLI 0(RB),C' ' FIND LAST NON BLANK CHAR. 63600013 BNE CVQBA 63900013 BCT RB,QTAIL 64200013 CVQBA BALR LR,BR CALL CONVERSION. 64500013 B TCOMP 64800013 SPACE 65100013 K128 DC H'128' 65400013 EDED DC X'CA' 65700013 FDED DC X'C8' 66000013 CDED DC X'1C' VARIABLE LENGTH CHAR.STR.DED 66300013 BDED DC X'18' 66600013 IODG DC V(IHEIODG) 66900013 IODT DC V(IHEIODT) 67200013 DMAA DC V(IHEDMAA) 67500013 UPAB DC V(IHEUPAB) 67800013 UPBB DC V(IHEUPBB) 68100013 DNCA DC V(IHEDNCA) 68400013 DNBA DC V(IHEDNBA) 68700013 VSCA DC V(IHEVSCA) 69000013 VQBA DC V(IHEVQBA) 69300013 VSAA DC V(IHEVSAA) 69600013 VCAA DC V(IHEVCAA) 69900013 NULD DC A(*) 70200013 DC F'0' 70500013 FMTF EQU X'01' 70800013 FMTE EQU X'02' 71100013 FMAT EQU X'C8' F-FORMAT FLAG BYTE 71400013 IOBT EQU X'80' 71700013 ZERO EQU X'00' 72000013 STRG EQU X'80' 72300013 CPLX EQU X'01' 72600013 MODE EQU X'01' 72900013 CODE EQU X'08' 73200013 CHAR EQU X'04' 73500013 PWRK EQU WORK+72 73800013 CADD EQU X'88' 74100013 FLOT EQU X'02' 74400013 VERRB DC V(IHEERRB) EXEP (ON CONDITIONS). 74500001 ERRB DC AL2(ERR1) 74600001 DS 0H 74630001 XFER DC X'58FC' 74660001 END 74700013 ./ ADD SSI=03011973,SOURCE=1,NAME=IHEDIBA DIB TITLE ' IHEDIB A AND CP FORMAT INPUT DIRECTOR *00020000 O/S 360 PL/1 LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0 00100000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIB000-TSS 00106001 * ----------------------------------------------------DIB000-TSS 00112001 * 00120000 * SIZE 272 BYTES 00140000 * 00160000 * FUNCTION TO DIRECT THE CONVERSION OF EXTERNAL DATA DESCRIBED 00180000 * BY A FORMAT OR CHARACTER PICTURE FORMAT TO ANY 00200000 * INTERNAL DATA TYPE 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEDIBA - A FORMAT 00280000 * RA = A(TARGET/TARGET DOPE VECTOR) 00300000 * RB = A(TARGET DED) 00320000 * RC = A(FED) 00340000 * IHEDIBB - CHARACTER PICTURE FORMAT 00360000 * AS FOR IHEDIBA 00380000 * 00400000 * INPUT N/A 00420000 * 00440000 * OUTPUT N/A 00460000 * 00480000 * EXTERNAL MODULES 00500000 * IHEDCN -ARITHMETIC TO CHARACTER STRING CONVERSION 00520000 * IHEIOD -TO GET EXTERNAL DATA ADDRESS 00540000 * IHEKCD -TO CHECK DATA AGAINST CHARACTER PICTURE 00560000 * IHEVSC -CHARACTER STRING ASSIGNMENT 00580000 * IHEVSD -CHARACTER TO BIT CONVERSION 00600000 * IHEVSE -CHARACTER TO PICTURED CHARACTER CONVERSION 00620000 * 00640000 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 00660000 * ABNORMAL - AFTER ENDFILE CONDITION HAS BEEN RAISED 00680000 * CONTROL IS PASSED TO THE NEXT LANGUAGE 00700000 * STATEMENT(POINTED TO BY IHEQCFL) 00720000 * 00740000 * TABLES/WORKAREA 00760000 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 00780000 * 00800000 * ATTRIBUTES READ ONLY AND REENTRANT 00820000 * 00840000 * PRIVATE MACROS 00860000 * IHELIB,IHEPRV,IHESDR 00880000 * 00900000 * ASSEMBLY REQUIREMENTS 00920000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00940000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00960000 * 00980000 * NOTES SEE O/S 360 PL/1 LIBRARY PLM FOR LIBRARY MODULE 01000000 * CONVENTIONS AND STANDARDS 01020000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 01040000 * A PARTICULAR INTERNAL REPRESENTATION OF THE 01060000 * EXTERNAL CHARACTER SET. 01080000 EJECT 01100000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIB001-TSS 01110001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 01120000 PUNCH ' LIBRARY *(IHEDMAA,IHEUPAB,IHEUPBB,IHEVSCA,IHEVSDA,/01140000 IHEVSEA,IHEKCDA) DIB0000A' 01160000 * ----------------------------------------------------DIB001-TSS 01170001 SPACE 01180000 IHEDIB CSECT 01200000 IHELIB 01220000 IHEZLW3 DSECT 01240000 DS 15D 01260000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIB002-TSS 01270001 IHEQCFL DXD 2A 01280000 * ----------------------------------------------------DIB002-TSS 01290001 IHEDIB CSECT 01300000 ENTRY IHEDIBA 01320000 ENTRY IHEDIBB 01340000 USING IHEZLCA,WR 01360000 USING IHEZLW3,DR 01380000 IHEDIBA NOPR 0 A-FORMAT ENTRY POINT 01400000 IHEDIBB STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01420000 BALR RJ,0 SET UP ADDRESSABILITY 01440000 USING *,RJ 01460000 LR RI,DR SAVE ENTRY POINT REFERENCE 01480000 LR RH,RC SAVE FED POINTER 01500000 IHESDR LW3,WR UPDATE SAVE AREA POINTER 01520000 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 01540000 LR RC,RA SET TARGET 01560000 LR RD,RB PARAMETERS 01580000 SIOBT IHEPRV ERR,RE,OP=LA GET ADDRESS OF ERROR CODE 01600000 OI 0(RE),IOBT SET FOR 01620000 LR RF,RH GET POINTER 01640000 TM OFBR+3(RI),X'02' TEST ENTRY POINT 01660000 BZ MVCHR BRANCH IF A FORMAT 01680000 LA RF,1(RF) MOVE POINTER 01700000 MVCHR MVC WSDV+6(2),0(RF) GET LENGTH FROM FED 01720000 SR RF,RF GET W 01740000 AH RF,WSDV+6 FROM SDV 01760000 BNH TSTRG BRANCH IF W ZERO OR MINUS 01780000 L BR,IODG GET FIELD ADDRESS 01800000 BALR LR,BR WITHIN BUFFER 01820000 LTR BR,BR TEST RETURN CODE 01840000 BNZ ABNRM BRANCH IF NOT ZERO 01860000 MVC WOFD(8),WSDV SET ON FIELD DOPE VECTOR 01880000 RETRY L RA,WSDV LOAD SOURCE ADDRESS 01900000 TM OFBR+3(RI),X'02' TEST ENTRY POINT 01920000 BZ NOPIC NOT A PICTURE CHARACTER FORMAT 01940000 LR RB,RH SET FED POINTER 01960000 LA LR,RETRY STORE RETRY ENTRY POINT AND 01980000 STM DR,LR,WCNV SAVE AREA ADDRESS IN LCA. 02000000 L BR,KCDA CALL PICTURE 02020000 BALR LR,BR CHECK 02040000 NOPIC LA RB,CDED SOURCE DED 02060000 LA RA,WSDV SOURCE SDV 02080000 TM 0(RD),STRG TARGET TYPE STRING 02100000 BZ STRNG YES,BRANCH 02120000 L BR,DCNA CALL CHARACTER 02140000 BALR LR,BR TO ARITHMETIC CONVERSION 02160000 ENDRT L BR,IODT TERMINAL CALL 02180000 BALR LR,BR TO FREE ANY VDA. 02200000 FINIS SR RE,RE ZERO REGISTER 02220000 IHEPRV ERR,RE,OP=STH RESET ERROR CODE 02240000 L DR,OFDR(DR) RESET SAVE AREA POINTER 02260000 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 02280000 BR LR EXIT 02300000 ABNRM IHEPRV CFL,BR,OP=LA 02320000 L LR,4(BR) LOAD ADDRESS OF NEXT STATEMENT 02340000 L DR,OFDR(DR) RESET SAVE AREA POINTER 02360000 LM RB,WR,OFRB(DR) RESTORE CALLERS REGISTERS 02380000 BR LR EXIT 02400000 STRNG LA RG,ENDRT SET UP RETURN ADDRESS 02420000 COMON L BR,VSDA SET UP CHARACTER TO BIT 02440000 TM 0(RD),CHAR TEST FOR CHARACTER TARGET 02460000 BZ CALEB 02480000 L BR,VSCA SET UP CHARACTER TO CHARACTER 02500000 TM 0(RD),PICK TEST FOR PICTURE TARGET 02520000 BO CALEB 02540000 L BR,VSEA SET UP CHARCTER TO CHAR PIC 02560000 CALEB BALR LR,BR CALL CONVERSION 02580000 BR RG 02600000 TSTRG TM 0(RD),STRG TEST TARGET TYPE 02620000 BO FINIS BRANCH NOT STRING 02640000 LA RA,NULD SET NULL DOPE VECTOR POINTER 02660000 LA RB,CDED SET FOR CHARACTER STRING 02680000 LA RG,FINIS SET UP RETURN ADDRESS 02700000 B COMON GO TO ASSIGN NULL STRING 02720000 CDED DC X'1C' VARIABLE LENGTH CHAR.STR.DED 02740000 VSDA DC V(IHEVSDA) 02760000 VSEA DC V(IHEVSEA) 02780000 KCDA DC V(IHEKCDA) 02800000 DCNA DC V(IHEDCNA) 02820000 IODG DC V(IHEIODG) 02840000 IODT DC V(IHEIODT) 02860000 VSCA DC V(IHEVSCA) 02880000 NULD DC A(*) 02900000 DC F'0' 02920000 IOBT EQU X'80' 02940000 ZERO EQU X'00' 02960000 STRG EQU X'80' 02980000 PICK EQU X'08' 03000000 CHAR EQU X'04' 03020000 END 03040000 ./ ADD SSI=03011973,SOURCE=1,NAME=IHEDIDA DID TITLE ' IHEDID B FORMAT INPUT DIRECTOR *00020000 O/S 360 PL/1 LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL -0 00100000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DID000-TSS 00106001 * ----------------------------------------------------DID000-TSS 00112001 * 00120000 * SIZE 456 BYTES 00140000 * 00160000 * FUNCTION TO DIRECT THE CONVERSION OF EXTERNAL DATA DESCRIBED BY 00180000 * A 'B' FORMAT ITEM, TO ANY INTERNAL DATA TYPE 00200000 * 00220000 * ENTRY POINTS 00240000 * IHEDIDA 00260000 * RA = A(TARGET/TARGET DOPE VECTOR) 00280000 * RB = A(TARGET DED) 00300000 * RC = A(FED) 00320000 * 00340000 * INPUT N/A 00360000 * 00380000 * OUTPUT N/A 00400000 * 00420000 * EXTERNAL MODULES 00440000 * IHEDMA - ARITHMETIC CONVERSION DIRECTOR 00460000 * IHEIOD - TO GET EXTERNAL DATA ADDRESS 00480000 * IHEUPA - TO ZERO IMAGINARY PART OF CODED 00500000 * COMPLEX TARGET 00520000 * IHEUPB - TO ZERO IMAGINARY PART OF NUMERIC 00540000 * COMPLEX TARGET 00560000 * IHEVSC - CHARACTER STRING ASSIGNMENT ROUTINE 00580000 * IHEVSD - CHARACTER TO BIT CONVERSION 00600000 * IHEVSE - CHARACTER TO PICTURED CHARACTER CONVERSION 00620000 * 00640000 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 00660000 * ABNORMAL - PASS CONTROL TO NEXT LANGUAGE STATEMENT,IF 00680000 * ENDFILE CONDITION WAS RAISED BY IHEIOD. 00700000 * ERROR - CALL EXECUTION ERROR PACKAGE TO RAISE CONVERSION 00720000 * CONDITION IF EXTERNAL DATA CONTAINS CHARACTERS 00740000 * OTHER THAN ONE OR ZERO. 00760000 * 00780000 * TABLES/WORK AREA 00800000 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS). 00820000 * 00840000 * PRIVATE MACROS 00860000 * IHELIB,IHEPRV,IHESDR 00880000 * 00900000 * ASSEMBLY REQUIREMENTS 00920000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00940000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00960000 * 00980000 * NOTE SEE O/S 360 PL/1 LIBRARY PLM FOR LIBRARY MODULE 01000000 * CONVENTIONS AND STANDARDS. 01020000 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 01040000 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 01060000 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 01080000 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 01100000 * CONSTANTS,BY REASSEMBLY,WILL RESULT IN A CORRECT MODULE 01120000 * FOR THE NEW DEFINITIONS. 01140000 * 01160000 * ATTRIBUTES READ ONLY AND REENTRANT 01180000 EJECT 01200000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DID001-TSS 01210001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 01220000 PUNCH ' LIBRARY *(IHEDMAA,IHEUPAB,IHEUPBB,IHEVSCA,IHEVSEA,/01240000 IHEVSDA) DID0000A' 01260000 * ----------------------------------------------------DID001-TSS 01270001 SPACE 01280000 IHEDID CSECT 01300000 IHELIB 01320000 IHEZLW3 DSECT 01340000 DS 15D 01360000 WORK EQU IHEZLW3 01380000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DID002-TSS 01390001 IHEQCFL DXD 2A 01400000 * ----------------------------------------------------DID002-TSS 01410001 IHEDID CSECT 01420000 ENTRY IHEDIDA 01440000 USING IHEZLCA,WR 01460000 USING IHEZLW3,DR 01480000 IHEDIDA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01500000 BALR RJ,0 SET UP ADDRESSABILITY 01520000 USING *,RJ 01540000 LR RH,RC SAVE FED POINTER 01560000 IHESDR LW3,WR UPDATE SAVE AREA POINTER 01580000 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 01600000 LR RC,RA SET TARGET 01620000 LR RD,RB PARAMETERS 01640000 SIOBT IHEPRV ERR,RE,OP=LA GET ADDRESS OF ERROR CODE 01660000 OI 0(RE),IOBT SET FOR 01680000 SR RF,RF GET W 01700000 AH RF,0(RH) FROM FED 01720000 BNH TSTRG BRANCH IF W ZERO OR MINUS 01740000 STH RF,WSDV+6 SET UP FIELD WIDTH 01760000 L BR,IODG GET FIELD ADDRESS 01780000 BALR LR,BR WITHIN BUFFER 01800000 LTR BR,BR TEST RETURN CODE 01820000 BNZ ABNRM BRANCH IF NOT ZERO 01840000 MVC WOFD(8),WSDV SET ON FIELD DOPE VECTOR 01860000 RETRY L RG,WSDV LOAD SOURCE ADDRESS 01880000 LH RF,WSDV+6 GET SOURCE LENGTH 01900000 TESTB CLI 0(RG),C' ' TEST SOURCE 01920000 BE LOOPB BRANCH IF LEADING BLANK 01940000 ST RG,TPDV SAVE STRING START ADDRESS 01960000 CHECK CLI 0(RG),C'0' TEST SOURCE 01980000 ST RG,WOCH SET POSSIBLE ERROR ADDRESS 02000000 BE COUNT BRANCH IF CHARACTER ZERO 02020000 CLI 0(RG),C'1' TEST SOURCE 02040000 BE COUNT BRANCH IF CHARACTER ONE 02060000 CLI 0(RG),C' ' TEST SOURCE 02080000 BE SAVEA BRANCH IF TRAILING BLANK 02100000 BAL RB,ERCAL GO TO ERROR ROUTINE 02120000 B COUNT CONTINUE IF RETURN 02140000 SAVEA ST RG,TPDV+4 SAVE END OF STRING ADDRESS 02160000 B ERRET 02180000 BUMPG LA RG,1(RG) BUMP SCAN ADDRESS 02200000 CLI 0(RG),C' ' TEST SOURCE 02220000 ST RG,WOCH SAVE POSSIBLE ERROR ADDRESS 02240000 BE ERRET BRANCH IFTRAILING BLANK 02260000 BAL RB,ERCAL GO TO ERROR ROUTINE 02280000 ERRET BCT RF,BUMPG TEST FOR END OF STRING AND LOOP 02300000 L RG,TPDV+4 CALCULATE 02320000 STTTT S RG,TPDV LENGTH OF 02340000 STH RG,TPDV+4 STRING AND STORE 02360000 STH RG,TPDV+6 IN DOPE VECTOR 02380000 B SETUP GO CONVERT TO BIT STRING 02400000 LOOPB LA RG,1(RG) BUMP SCAN ADDRESS 02420000 BCT RF,TESTB TEST FOR END OF STRING AND LOOP 02440000 BCTR RG,0 GET END OF STRING ADDRESS 02460000 ST RG,WOCH STORE AS ERROR POINTER 02480000 BAL RB,ERCAL GO TO ERROR ROUTINE 02500000 B ENDRT CONTINUE IF RETURN 02520000 COUNT LA RG,1(RG) BUMP SCAN ADDRESS 02540000 BCT RF,CHECK LOOP IF NOT END OF STRING 02560000 B STTTT 02580000 SETUP LA RB,CDED SET UP SOURCE DED AND 02600000 LA RA,TPDV DOPE VECTOR ADDRESS 02620000 TM 0(RD),STRG TARGET TYPE STRING 02640000 BZ STRNG 02660000 LA RB,BTDD BIT CONSTANT DED 02680000 L RA,TPDV SET UP FIRST 02700000 ST RA,WCN1 AND LAST ADDRESS 02720000 AH RA,TPDV+6 IN WCN1 02740000 BCTR RA,0 02760000 ST RA,WCN1+4 02780000 L BR,DMAA CONVERT 02800000 BALR LR,BR 02820000 TM 0(RD),CPLX ZERO IMAGINARY 02840000 BZ ENDRT PART IF COMPLEX 02860000 L BR,UPAB CAD 02880000 TM 0(RD),PICK 02900000 BO NOPIC OR 02920000 L BR,UPBB PICTURE 02940000 NOPIC BALR LR,BR 02960000 ENDRT L BR,IODT TERMINAL CALL 02980000 BALR LR,BR TO FREE ANY VDA. 03000000 FINIS SR RE,RE ZERO REGISTER 03020000 IHEPRV ERR,RE,OP=STH RESET ERROR CODE 03040000 L DR,OFDR(DR) RESET SAVE AREA POINTER 03060000 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 03080000 BR LR EXIT 03100000 ABNRM IHEPRV CFL,BR,OP=LA 03120000 L LR,4(BR) LOAD ADDRESS OF NEXT STATEMENT 03140000 L DR,OFDR(DR) RESET SAVE AREA POINTER 03160000 LM RB,WR,OFRB(DR) RESTORE CALLERS REGISTERS 03180000 BR LR EXIT 03200000 STRNG LA RI,ENDRT SET UP RETURN ADDRESS 03220000 COMON L BR,VSDA SET UP CHARACTER TO BIT 03240000 TM 0(RD),CHAR TEST FOR CHARACTER TARGET 03260000 BZ CALEB 03280000 L BR,VSCA SET UP CHARACTER TO CHARACTER 03300000 TM 0(RD),PICK TEST FOR PICTURE TARGET 03320000 BO CALEB 03340000 L BR,VSEA SET UP CHARACTER TO CHAR PIC 03360000 CALEB BALR LR,BR 03380000 BR RI 03400000 TSTRG TM 0(RD),STRG TEST TARGET TYPE 03420000 BO FINIS BRANCH NOT STRING 03440000 LA RA,NULD SET NULL DOPE VECTOR POINTER 03460000 LA RB,CDED SET FOR CHARACTER STRING 03480000 LA RI,FINIS SET UP RETURN ADDRESS 03500000 B COMON 03520000 ERCAL OI 0(RE),CONV 03540000 OI 1(RE),FMTB SET UP B-FORMAT SOURCE 03560000 LA LR,RETRY STORE RETRY ENTRY POINT AND 03580000 STM DR,LR,WCNV SAVE AREA ADDRESS IN LCA. 03600000 L BR,ERRB 03620000 BALR LR,BR 03640000 BR RB CONTINUE IF RETURN 03660000 BTDD DC X'7D' 03680000 CDED DC X'1C' VARIABLE LENGTH CHAR.STR.DED 03700000 IODG DC V(IHEIODG) 03720000 IODT DC V(IHEIODT) 03740000 DMAA DC V(IHEDMAA) 03760000 UPAB DC V(IHEUPAB) 03780000 UPBB DC V(IHEUPBB) 03800000 VSCA DC V(IHEVSCA) 03820000 VSEA DC V(IHEVSEA) 03840000 VSDA DC V(IHEVSDA) 03860000 ERRB DC V(IHEERRB) 03880000 NULD DC A(*) 03900000 DC F'0' 03920000 PICK EQU X'08' 03940000 IOBT EQU X'80' 03960000 ZERO EQU X'00' 03980000 STRG EQU X'80' 04000000 CPLX EQU X'01' 04020000 CHAR EQU X'04' 04040000 CONV EQU X'40' 04060000 FMTB EQU X'03' 04080000 TPDV EQU WORK+72 04100000 END 04120000 ./ ADD SSI=02010650,SOURCE=1,NAME=IHEDIEA DIE TITLE ' IHEDIE NUMERIC PICTURE INPUT DIRECTOR *00400013 O/S 360 PL/1 LIBRARY' 00800013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 01200013 * 01600013 * STATUS CHANGE LEVEL - 0 02000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIE000-TSS 02100001 * ----------------------------------------------------DIE000-TSS 02200001 * 02400013 * SIZE 376 BYTES 02800013 * 03200013 * FUNCTION TO DIRECT THE CONVERSION OF EXTERNAL DATA DESCRIBED BY 03600013 * A NUMERIC PICTURE FORMAT TO ANY INTERNAL DATA TYPE. 04000013 * 04400013 * ENTRY POINTS 04800013 * IHEDIEA 05200013 * RA = A(TARGET/TARGET DOPE VECTOR) 05600013 * RB = A(TARGET DED) 06000013 * RC = A(FED) 06400013 * 06800013 * INPUT BIT SET IN SWITCH WSWA IN LIBRARY COMMUNICATION AREA 07200013 * IF CALLED BY C FORMAT DIRECTOR (IHEDIM) 07600013 * 08000013 * OUTPUT N/A 08400013 * 08800013 * EXTERNAL MODULES 09200013 * IHEIOD - TO GET ADDRESS OF EXTERNAL DATA. 09600013 * IHEKCA - TO CHECK DATA AGAINST DECIMAL PICTURE 10000013 * IHEKCB - TO CHECK DATA AGAINST STERLING PICTURE 10400013 * IHEDMA - ARITHMETIC CONVERSION DIRECTOR. 10800013 * IHEDNB - ARITHMETIC TO BIT CONVERSION 11200013 * IHEDNC - ARITHMETIC TO CHARACTER CONVERSION 11600013 * IHEUPA - ZERO IMAG.PART OF CODED COMPLEX TARGET 12000013 * IHEUPB - ZERO IMAG.PART OF NUMERIC COMPLEX TARGET 12400013 * IHEVSD - CHARACTER TO BIT CONVERSION 12800013 * 13200013 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 13600013 * ABNORMAL - AFTER ENDFILE CONDITION HAS BEEN RAISED 14000013 * CONTROL IS PASSED TO THE NEXT LANGUAGE 14400013 * STATEMENT.(POINTED AT BY IHEQCFL). 14800013 * 15200013 * TABLES/WORKAREA 15600013 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 16000013 * 16400013 * ATTRIBUTES READ ONLY AND REENTRANT. 16800013 * 17200013 * PRIVATE MACROS 17600013 * IHELIB,IHEPRV,IHESDR 18000013 * 18400013 * ASSEMBLY REQUIREMENTS 18800013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 19200013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 19600013 * 20000013 * NOTE SEE O/S360 PL/1 LIBRARY PLM FOR LIBRARY MODULE 20400013 * CONVENTIONS AND STANDARDS 20800013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 21200013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 21600013 * EXTERNAL CHARACTER SET 22000013 EJECT 22400013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIE001-TSS 22600001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 22800013 PUNCH ' LIBRARY *(IHEKCAA,IHEKCBA,IHEDMAA,IHEVSDA,IHEVSCA,/23200013 IHEVSEA,IHEUPAB) DIE0000A' 23600013 PUNCH ' LIBRARY *(IHEUPBB) /24000013 DIE0000B' 24400013 * ----------------------------------------------------DIE001-TSS 24600001 SPACE 24800013 IHEDIE CSECT 25200013 IHELIB 25600013 IHEZLW3 DSECT 26000013 DS 15D 26400013 WORK EQU IHEZLW3 26800013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIE002-TSS 27000001 IHEQCFL DXD 2A 27200013 * ----------------------------------------------------DIE002-TSS 27400001 IHEDIE CSECT 27600013 ENTRY IHEDIEA 28000013 USING *,RJ 28400013 USING IHEZLCA,WR 28800013 USING IHEZLW3,DR 29200013 IHEDIEA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 29600013 IHESDR LW3,WR UPDATE SAVE AREA POINTER 30000013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 30400013 LR RJ,BR TRANSFER BASE REGISTER 30800013 IHEPRV ERR,RE,OP=LA GET ADDRESS OF ERROR CODE 31200013 OI 0(RE),IOBT SET FOR 31600013 TM WSWA,X'40' TEST WHO CALLED 32000013 BO TESTC BRANCH IF C FORMAT 32400013 SR RF,RF CLEAR RF 32800013 IC RF,3(RC) WIDTH OF FIELD IN RF 33200013 STH RF,WSDV+6 THEN TO WSDV 33600013 L BR,IODG FOR CALL 34000013 BALR LR,BR TO LIBIOP 34400013 LTR BR,BR TEST RETURN CODE 34800013 BNZ ABNRM BRANCH IF NOT ZERO 35200013 MVC WOFD(8),WSDV SET ON SORCE DOPE VECTOR 35600013 LA LR,RETRY STORE RETRY ENTRY POINT AND 36000013 STM DR,LR,WCNV SAVE AREA ADDRESS IN LCA 36400013 TESTC STM RA,RC,PWRK STORE PARAMETERS 36800013 SR RI,RI ZERO TYPE CODE 37200013 TM 0(RC),BINY TEST FOR BINARY PICTURE 37600013 BO BCODE 38000013 LA RI,4(RI) INCREMENT TYPE CODE 38400013 TM 0(RC),STER TEST FOR STERLING CODE 38800013 BZ BCODE 39200013 LA RI,4(RI) INCREMENT TYPE CODE 39600013 BCODE L BR,KCCA(RI) SET BR TO PICTURE CHECK ROUTINE 40000013 LR RB,RC TRANSFER PIC TO RB 40400013 L RA,WSDV BUFFER ADDRESS IN RA 40800013 BALR LR,BR CALL A PICTURE CHECK 41200013 LM RC,RD,PWRK GET TARGET PARAMETERS 41600013 LTR RI,RI TEST FOR BINARY SOURCE 42000013 BZ BINRY IF SO BRANCH 42400013 BINRT TM 0(RD),STRG TEST TARGET TYPE 42800013 BZ STRNG BRANCH IF STRING 43200013 COMPR CLC 0(1,RD),0(RB) COMPARE FLAG BYTE 43600013 BNE ARITH NO BRANCH 44000013 IC RF,4(RB) LENGTH OF PICTURE 44400013 LA RF,4(RF) IN RF 44800013 EX RF,COMPR LENGTH FOR COMPARE 45200013 BNE ARITH NOT EQUAL BRANCH 45600013 IC RF,3(RB) GET WIDTH FOR MOVE 46000013 BCTR RF,0 MINUS ONE 46400013 EX RF,MOVER MOVE SOURCE TO TARGET 46800013 B CPLEX 47200013 ARITH L BR,DMAA SET TO CALL ARITH CONVERSION 47600013 BALR LR,BR CONVERSION 48000013 CPLEX TM WSWA,CPLX TEST IMAG FORMAT SWITCH 48400013 BO ENDRT BRANCH IF SET 48800013 TM 0(RD),MODE TEST MODE OF TARGET 49200013 BO CALUP BRANCH IF COMPLEX 49600013 ENDRT TM WSWA,X'40' TEST WHO CALLED 50000013 BO FINIS BRANCH IF C FORMAT 50400013 L BR,IODT TERMINAL CALL 50800013 BALR LR,BR TO FREE ANY VDA 51200013 FINIS SR RE,RE RESET 51600013 IHEPRV ERR,RE,OP=STH ERROR CODE 52000013 L DR,OFDR(DR) RESET SAVE AREA POINTER 52400013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 52800013 SR BR,BR SET CODE FOR NORMAL RETURN 53200013 BR LR EXIT 53600013 CALUP LR RA,RC TRANSFER TARGET 54000013 LR RB,RD PARAMETERS 54400013 L BR,UPAB SET FOR CODED TARGET 54800013 TM 0(RB),CODE TEST TARGET TYPE 55200013 BO CALLR BRANCH IF CODED 55600013 L BR,UPBB SET FOR NUMERIC TARGET 56000013 CALLR BALR LR,BR CALL ROUTINE TO ZERO IMAG PART 56400013 B ENDRT GO TO EXIT 56800013 RETRY LM RA,RC,PWRK RESTORE PARAMETER REGISTERS 57200013 B TESTC GO TRY AGAIN 57600013 ABNRM TM WSWA,X'40' TEST C FORMAT SWITCH 58000013 L DR,OFDR(DR) RESET SAVE AREA POINTER 58400013 BO CFRMT BRANCH IF SWITCH SET 58800013 IHEPRV CFL,BR,OP=LA 59200013 L LR,4(BR) LOAD ADDRESS OF NEXT STATEMENT 59600013 LM RB,WR,OFRB(DR) RESTORE CALLERS REGISTERS 60000013 BR LR EXIT 60400013 CFRMT LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 60800013 BR LR EXIT 61200013 BINRY LA RA,WSDV LOAD SOURCE ADDRESS 61600013 LA RB,CDED LOAD SOURCE STRING DED 62000013 LA RH,PWRK+20 CREATE BIT STRING DOPE VECTOR 62400013 ST RH,PWRK+12 IN WORKSPACE WITH ADDRESS OF 62800013 MVC PWRK+16(4),WSDV+4 TEMP AND EXTERNAL LENGTH 63200013 LA RC,PWRK+12 SET DOPE VECTOR POINTER 63600013 LA RD,BDED LOAD TARGET DED 64000013 L BR,VSDA CALLCHARACTER 64400013 BALR LR,BR TO BIT 64800013 LA RA,PWRK+12 SET UP CALL 65200013 L RB,PWRK+8 TO 65600013 LM RC,RD,PWRK DMA 66000013 B BINRT RETURN 66400013 STRNG L BR,DNBA SET TO CALL ARITH TO BIT 66800013 TM 0(RD),CHAR TEST FOR CHARACTER TARGET 67200013 BO CHARY YES BRANCH 67600013 CALEB BALR LR,BR CALL CONVERSION 68000013 B ENDRT RETURN 68400013 CHARY LA RB,CDED 68500015 LA RA,WSDV 68600015 L BR,VSCA 68700015 TM 0(RD),PICT 68800015 BO CALEB 68900015 L BR,VSEA 69000015 B CALEB CHARACTER STRING 69200013 MOVER MVC 0(0,RC),0(RA) 69600013 CDED DC X'0C' 70000013 BDED DC X'08' 70400013 IODG DC V(IHEIODG) 70800013 KCCA DC A(0) FUTURE IHEKCCA 71200013 KCAA DC V(IHEKCAA) 71600013 KCBA DC V(IHEKCBA) 72000013 IODT DC V(IHEIODT) 72400013 DMAA DC V(IHEDMAA) 72800013 VSDA DC V(IHEVSDA) 73200013 DNBA DC V(IHEDNBA) 73600013 DNCA DC V(IHEDNCA) 74000013 UPAB DC V(IHEUPAB) 74400013 UPBB DC V(IHEUPBB) 74800013 VSCA DC V(IHEVSCA) 74900015 VSEA DC V(IHEVSEA) 75000015 PICT EQU X'08' 75200013 CHAR EQU X'04' 75600013 PWRK EQU WORK+72 76000013 ZERO EQU 0 76400013 CPLX EQU X'01' 76800013 MODE EQU X'01' 77200013 CODE EQU X'08' 77600013 IOBT EQU X'80' 78000013 BINY EQU X'04' 78400013 STER EQU X'20' 78800013 STRG EQU X'80' 79200013 END 79600013 ./ ADD SSI=03011700,SOURCE=1,NAME=IHEDILA DIL TITLE ' IHEDIL ILLEGAL FORMAT INPUT DIRECTOR *00020000 O/S 360 PL/1 LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL 0 00100000 * 00120000 * SIZE 48 BYTES 00140000 * 00160000 * FUNCTION TO CALL THE EXECUTION ERROR PACKAGE PASSING AN ERROR 00180000 * CODE TO SIGNAL THAT AN ILLEGAL FORMAT SPECIFICATION 00200000 * HAS BEEN MADE 00220000 * 00240000 * ENTRY POINTS 00260000 * IHEDILA - ILLEGAL A FORMAT SPECIFICATION 00280000 * NO W SPECIFIED ON INPUT 00300000 * IHEDILB - ILLEGAL B FORMAT SPECIFICATION 00320000 * NO W SPECIFIED ON INPUT 00340000 * NO ARGUMENTS FOR EITHER ENTRY 00360000 * 00380000 * INPUT N/A 00400000 * 00420000 * OUTPUT N/A 00440000 * 00460000 * EXTERNAL MODULES 00480000 * IHEERR - EXECUTION ERROR PACKAGE 00500000 * 00520000 * EXITS NORMAL - CALL ERROR PACKAGE WITH ERROR CODE TO SIGNAL 00540000 * INVALID A OR B FORMAT SPECIFICATION 00560000 * 00580000 * TABLES/WORKAREA 00600000 * WORKAREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 00620000 * 00640000 * ATTRIBUTES READ ONLY AND REENTRANT 00660000 * 00680000 * PRIVATE MACROS 00700000 * IHELIB,IHESDR 00720000 * 00740000 * ASSEMBLY REQUIREMENTS 00760000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00780000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00800000 * 00820000 * NOTE SEE O/S360 PL1 LIBRARY PLM FOR DESCRIPTION OF LIBRARY 00840000 * CONVENTIONS AND STANDARDS. 00860000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND ON A 00880000 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL 00900000 * CHARACTER SET. 00920000 IHEDIL CSECT 00940000 IHELIB 00960000 IHEZLW3 DSECT 00980000 DS 15D 01000000 WORK EQU IHEZLW3 01020000 IHEDIL CSECT 01040000 ENTRY IHEDILA 01060000 ENTRY IHEDILB 01080000 USING IHEZLW3,DR 01100000 IHEDILA NOPR 0 A FORMAT ENTRY 01120000 IHEDILB STM LR,WR,OFLR(DR) B FORMAT ENTRY 01140000 BALR RJ,0 SET UP ADDRESSABILITY 01160000 USING *,RJ 01180000 TM OFBR+3(DR),X'02' TEST ENTRY ADDRESS 01200000 IHESDR LW3,WR UPDATE SAVE AREA POINTER 01220000 LA RA,ERORB SET FOR ENTRY POINT B 01240000 BO BFMAT BRANCH IF ENTRY POINT B 01260000 LA RA,ERORA SET FOR ENTRY POINT A 01280000 BFMAT L BR,ERRC CALL EXECUTION 01300000 BALR LR,BR ERROR PACKAGE 01320000 ERORA DC X'0404' 01340000 ERORB DC X'0405' 01360000 ERRC DC V(IHEERRC) 01380000 END 01400000 ./ ADD SSI=02012966,NAME=IHEDIMA,SOURCE=0 DIM TITLE ' IHEDIM C FORMAT INPUT INPUT DIRECTOR *00020000 O/S 360 PL/1 LIBRARY' 00040000 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00060000 * 00080000 * STATUS CHANGE LEVEL - 0 00100000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM000-TSS 00106001 * ----------------------------------------------------DIM000-TSS 00112001 * 00120000 * THIS UPDATE FIXES APAR 40074 - RELEASE SHOWN BY ID#. 00128046 * 012800,* 015200 016000,* 019200 020200,* 041000 045600,* 00136046 * 00144046 * SIZE 552 BYTES 00152046 * 00160000 * FUNCTION TO DIRECT THE CONVERSION OF EXTERNAL CHARACTER DATA 00180000 * DESCRIBED BY A 'C' FORMAT ITEM TO ANY INTERNAL DATA TYPE 00200000 * 00220000 * ENTRY POINTS 00240000 * IHEDIMA 00260000 * RA = A(TARGET/TARGET DOPE VECTOR) 00280000 * RB = A(TARGET DED) 00300000 * RC = A(REAL FORMAT INPUT DIRECTOR) 00320000 * RD = A(REAL FED) 00340000 * RE = A(IMAGINARY FORMAT INPUT DIRECTOR) 00360000 * RF = A(IMAGINARY FED) 00380000 * 00400000 * INPUT N/A 00420000 * 00440000 * OUTPUT N/A 00460000 * 00480000 * EXTERNAL MODULES 00500000 * IHEDIA - F/E FORMAT INPUT DIRECTOR 00520000 * IHEDIE - NUMERIC PICTURE INPUT DIRECTOR 00540000 * IHEIOD - TO GET ADDRESS OF EXTERNAL DATA. 00560000 * IHEKCA - TO CHECK DATA AGAINST PICTURE SPEC. 00580000 * IHEVCA - TO GET BASE,SCALE AND PRECISION OF DATA. 00600000 * IHEVCS - TO CONVERT EXTERNAL REPRESENTATION OF COMPLEX 00620000 * VALVE TO TYPE STRING. 00640000 * 00660000 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 00680000 * ABNORMAL - AFTER ENDFILE CONDITION HAS BEEN RAISED 00700000 * CONTROL IS PASSED TO NEXT LANGUAGE STATEMENT 00720000 * (POINTED TO BY IHEQCFL) 00740000 * 00760000 * TABLES/WORKAREA 00780000 * WORKAREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 00800000 * 00820000 * ATTRIBUTES READ ONLY AND REENTRANT 00840000 * 00860000 * PRIVATE MACROS 00880000 * IHELIB,IHEPRV,IHESDR 00900000 * 00920000 * ASSEMBLY REQUIREMENTS 00940000 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 00960000 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 00980000 * 01000000 * NOTES SEE O/S360 PL/1 LIBRARY PLM FOR DESCRIPTION OF LIBRARY 01020000 * CONVENTIONS AND STANDARDS 01040000 * THE OPERATION OF THIS MODULE DOES NOT DEPEND ON A 01060000 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL 01080000 * CHARACTER SET. 01100000 EJECT 01120000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM001-TSS 01130001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 01140000 PUNCH ' LIBRARY *(IHEDIAA,IHEDIEA,IHEVCAA,IHEVCSA,IHEKCAA)/01160000 DIM0000A' 01180000 * ----------------------------------------------------DIM001-TSS 01190001 SPACE 01200000 IHEDIM CSECT 01220000 IHELIB 01240000 IHEZLW4 DSECT 01260000 DS 16D 01280046 WORK EQU IHEZLW4 01300000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM002-TSS 01310001 IHEQCFL DXD 2A 01320000 * ----------------------------------------------------DIM002-TSS 01330001 IHEDIM CSECT 01340000 ENTRY IHEDIMA 01360000 USING *,RJ 01380000 USING IHEZLCA,WR 01400000 USING IHEZLW4,DR 01420000 IHEDIMA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 01440000 IHESDR LW4,WR UPDATE SAVE AREA POINTER 01460000 IHEPRV ,WR GOT COMMUNICATION AREA ADDRESS 01480000 LR RJ,BR TRANSFER BASE ADDRESS 01500000 LA LR,RETRY STORE RETRY ENTRY POINT AND 01520000 MVI SWIT,X'00' ZERO ALL SWITCHES 01530046 STM DR,LR,WCNV SAVE AREA ADDRESS IN LCA 01540000 AGAIN STM RE,RF,PWRK SAVE IMAG PART PARAMETERS 01560000 MVI WSWA,X'40' INITIALISE C FORMAT SWITCHES 01580000 NI SWIT,X'02' RESET ALL SWTCHS EXC. GET RTN 01600046 STM RA,RB,PLIST+16 PUT TARGET PARAMETERS IN LIST 01620000 LR RF,RC TRANSFER DIRECTOR 01640000 LR RG,RD AND FED POINTERS 01660000 LA RI,2 SET COUNT 01680000 SR RE,RE INITIALISE ACCUMULATOR 01700000 COMPD ST RA,DOPV SAVE LENGTHS OF REAL PART 01720000 STH RA,DOPV IN WORKSPACE 01740000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM990-TSS 01750000 C RF,PMAT TEST FORMAT TYPE 01760000 * ----------------------------------------------------DIM990-TSS 01770000 BE GETWD BRANCH IF PICTURE FORMAT 01780000 LH RA,0(RG) GET FIELD WIDTH FROM DED 01800000 UPDAT AR RE,RA ADD TO TOTAL FIELD WIDTH 01820000 LM RF,RG,PWRK LOAD IMAG PART PARAMETERS 01840000 BCT RI,COMPD BRANCH IF COUNT NOT ZERO 01860000 STH RE,WSDV+6 SET CURRENT LENGTH (W) 01880000 ST RA,DOPV+4 STORE LENGTH OF IMAG PART 01900000 STH RA,DOPV+4 IN WORKSPACE 01920000 TM SWIT,X'02' HAS GET RTN BEEN PROCESSED? 01922046 BO SKPGET YES. 01924046 OI SWIT,X'02' SET GET ROUTINE SW ON. 01926046 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM999-TSS 01930000 L BR,IODG CALL ROUTINE TO GET 01940000 * ----------------------------------------------------DIM999-TSS 01950000 BALR LR,BR ADDRESS OF W BYTES 01960000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM003-TSS 01970021 LTR BR,BR TEST RETURN CODE 01980000 BNZ ABNRM BRANCH IF NOT ZERO 02000000 MVC WSPACE(8),WSDV STORE DOPE VECTOR IN CASE 02010046 * OF RETRY. 02020046 * ----------------------------------------------------DIM003-TSS 02025021 SKPGET MVC WOFD(8),WSDV SET ON SOURCE DOPE VECTOR. 02030046 ST RI,WSDV+4 ZERO FIELD WIDTH 02040000 LA RF,STRNG 02060000 LA RG,SCOMP SET RETURN ADDRESSES 02080000 LM RA,RB,PLIST+16 RESTORE TARGET PARAMETERS 02100000 CALFD TM 0(RB),STRG TEST TARGET TYPE 02120000 BCR 8,RF BRANCH IF STRING 02140000 BAL BR,GBUFF GO GET FIELD ADDRESS 02160000 LR BR,RC LOAD DIRECTOR ADDRESS 02180000 LR RC,RD SET FED POINTET 02200000 BALR LR,BR CALL I/O DIRECTOR 02220000 LTR BR,BR TEST RETURN CODE 02240000 BCR 8,RG BRANCH IF ZERO 02260000 ABNRM MVI WSWA,ZERO RESET C FORMAT SWITCHES 02280000 IHEPRV CFL,BR,OP=LA 02300000 L LR,4(BR) LOAD ADDRESS OF NEXT STATEMENT 02320000 L DR,OFDR(DR) RESET SAVE AREA POINTER 02340000 LM RB,WR,OFRB(DR) RESTORE CALLERS REGISTERS 02360000 BR LR EXIT 02380000 SCOMP TM 0(RB),MODE TEST MODE OF TARGET 02400000 BZ ENDRT BRANCH IF REAL 02420000 OI WSWA,COMP SET COMPLEX FORMAT SWITCH 02440000 LM RC,RD,PWRK RESTORE IMAG PART PARAMETERS 02460000 L RA,WRCD LOAD UPDATED TARGET ADDRESS 02480000 BAL RG,TESFT LOOP AND SET RETURN ADDRES 02500000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM998-TSS 02510000 ENDRT L BR,IODT TERMINAL CALL 02520000 * ----------------------------------------------------DIM998-TSS 02530000 BALR LR,BR TO FREE ANY VDA 02540000 SR RE,RE RESET ERROR CODE 02560000 IHEPRV ERR,RE,OP=STH 02580000 MVI WSWA,ZERO RESET C FORMAT SWITCHES 02600000 L DR,OFDR(DR) RESET SAVE AREA POINTER 02620000 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 02640000 BR LR RETURN 02660000 STRNG SR RG,RG INITIALISE LOOP INDEX 02680000 LOOP1 IHEPRV ERR,RE,OP=LA 02700000 OI 0(RE),IOBT SET FOR I/O ERROR 02720000 BAL BR,GBUFF GO GET FIELD ADDRESS 02740000 LOADL L LR,WSDV LOAD BUFFER ADDRESS 02760000 ST LR,WCN1(RG) STORE IN COMMUNICATION AREA 02780000 AH LR,WSDV+6 CALCULATE DATA 02800000 BCTR LR,0 END ADDRESS 02820000 ST LR,WCN1+4(RG) STORE IN COMMUNICATION AREA 02840000 LA LR,WCN1(RG) GET START/END POINTER 02860000 ST LR,WCNP STORE IN COMMUNICATION AREA 02880000 ST LR,PLIST(RG) AND PARAMETER LIST 02900000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM997-TSS 02910000 C RC,PMAT TEST FORMAT TYPE 02920000 * ----------------------------------------------------DIM997-TSS 02930000 BE PICRT BRANCH IF PICTURED 02940000 LA RA,DEDS(RI) SET DED POINTER 02960000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM996-TSS 02970000 L BR,VCAA CALL ROUTINE TO SCAN DATA TO 02980000 * ----------------------------------------------------DIM996-TSS 02990000 BALR LR,BR DETERMINE TYPE AND PRECISION 03000000 B STAR4(BR) TEST RETURN CODE 03020000 STAR4 B ANYDS BRANCH IF RETURN CODE ZERO 03040000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM995-TSS 03050000 TESTF C RD,FMAT TEST FORMAT TYPE 03060000 * ----------------------------------------------------DIM995-TSS 03070000 BNE SETDD BRANCH IF NOT F FORMAT 03080000 SR RF,RF GET 03100000 LR RG,RF SCALE FACTOR 03120000 IC RF,DEDS+2(RI) FROM CREATED DED 03140000 IC RG,3(RD) GET P SPECIFICATION 03160000 SR RF,RG FROM FED AND COMINE WITH SF. 03180000 AH RF,K128 ADD EXCESS 03200000 STC RF,DEDS+2(RI) STORE COMBINED SF IN DED 03220000 LA RF,FDED SET CREATED DED FIXED TO SHOW 03240000 STC RF,DEDS(RI) F FORMAT FOR CHECKING. 03260000 SETDD LA RF,DEDS(RI) GET CREATED DED POINTER 03280000 ST RF,PLIST+4(RG) STORE IN PARAMETER LIST 03300000 ST RD,PLIST+24(RI) SET UP FED POINTER 03320000 TSWTC TM SWIT,IMAG TEST SWITCH 03340000 BO CALVS BRANCH IF SET 03360000 OI SWIT,IMAG SET SWITCH 03380000 LM RC,RD,PWRK RESTORE IMAG PART PARAMETERS 03400000 LA RG,8(RG) BUMP INDICES 03420000 LA RI,4(RI) FOR PARAMETER LIST AND DEDS 03440000 LA RF,LOOP1 SET BRANCH ADDRESS FOR LOOP 03460000 B TESFT REPEAT FOR IMAG PART 03480000 ANYDS SR RF,RF GET D SPECIFICATION 03500000 IC RF,2(RD) FROM FED 03520000 AH RF,K128 ADD EXCESS 03540000 STC RF,DEDS+2(RI) STORE AS SCALE FACTOR IN DED 03560000 B TESTF GO TEST FORMAT TYPE 03580000 CALVS LA RA,PLIST SET PARAMETER LIST POINTER 03600000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM994-TSS 03610000 L BR,VCSA CALL COMPLEX TO 03620000 * ----------------------------------------------------DIM994-TSS 03630000 BALR LR,BR STRING ROUTINE 03640000 B ENDRT GO TO EXIT ROUTINE 03660000 GETWD SR RA,RA ZERO REGISTER 03680000 IC RA,3(RG) INSERT FIELD WIDTH 03700000 B UPDAT 03720000 GBUFF L LR,WSDV SET 03740000 AH LR,WSDV+4 ADDRESSOF FIELD 03760000 ST LR,WSDV AND STORE 03780000 MVC WSDV+4(4),DOPV INSERT FIELD WIDTH 03800000 MVC DOPV(4),DOPV+4 SET FOR NEXT FIELD 03820000 BR BR RETURN 03840000 PICRT L RA,WSDV SET SOURCE POINTER 03860000 LR RF,RB SAVE TARGET DED POINTER 03880000 LR RB,RD SET SOURCE FED POINTER 03900000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM993-TSS 03910000 L BR,KCAA SET FOR DECIMAL PICTURE 03920000 * ----------------------------------------------------DIM993-TSS 03930000 TM 0(RB),DECM TEST PICTURE TYPE 03940000 BZ CALLS BRANCH IF DECIMAL 03960000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM992-TSS 03970000 L BR,KCCA SET FOR BINARY PICTURE 03980000 * ----------------------------------------------------DIM992-TSS 03990000 CALLS BALR LR,BR CALL PICTURE CHECK ROUTINE 04000000 ST RB,PLIST+4(RG) STORE DED POINTER IN PLIST 04020000 LR RB,RF RESTORE TRUE TARGET DED POINTER 04040000 B TSWTC GO TEST SWITCH. 04060000 RETRY L RA,OFDR(DR) RESTORE ORIGINAL 04080000 LM RA,RF,OFRA(RA) PARAMETERS 04100000 MVC WSDV(8),WSPACE RESTORE ORIGINAL D.V. 04110046 B AGAIN GO TRY AGAIN 04120000 K128 DC H'128' 04140000 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DIM991-TSS 04150000 FMAT DC V(IHEDIAA) 04160000 PMAT DC V(IHEDIEA) 04180000 IODG DC V(IHEIODG) 04200000 IODT DC V(IHEIODT) 04220000 VCAA DC V(IHEVCAA) 04240000 VCSA DC V(IHEVCSA) 04260000 KCAA DC V(IHEKCAA) 04280000 KCCA DC A(0) FUTURE DC V IHEKCCA 04300000 * ----------------------------------------------------DIM991-TSS 04310000 DECM EQU X'04' 04320000 IMAG EQU X'01' 04340000 FDED EQU X'C8' 04360000 COMP EQU X'01' 04380000 CPLX EQU X'FE' 04400000 MODE EQU X'01' 04420000 ZERO EQU X'00' 04440000 STRG EQU X'80' 04460000 DOPV EQU WORK+72 04480000 DEDS EQU DOPV+8 04500000 SWIT EQU DEDS+3 04520000 PWRK EQU DEDS+8 04540000 WSPACE EQU PWRK+8 04550046 PLIST EQU WSPACE+8 04560046 TESFT EQU CALFD 04580000 IOBT EQU X'80' 04600000 END 04620000 ./ ADD SSI=21400053,NAME=IHEDMAA,SOURCE=0 DMA TITLE ' IHEDMA ARITHMETIC CONVERSION DIRECTOR *00500013 O/S 360 PL/1 LIBRARY' 01000013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 01500013 * 02000013 * STATUS CHANGE LEVEL 01 02100056 * 02200056 *C720000 MA 47694 02300056 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA000-TSS 02600001 * ----------------------------------------------------DMA000-TSS 02700001 * 03000013 * SIZE 248 BYTES 03500013 * 04000013 * FUNCTION TO SET UP THE INTERMODULAR FLOW TO EFFECT CONVERSION 04500013 * FROM ONE ARITHMETIC DATA TYPE TO ANOTHER 05000013 * 05500013 * ENTRY POINTS 06000013 * IHEDMAA 06500013 * RA = A(SOURCE) 07000013 * RB = A(SOURCE DED) 07500013 * RC = A(TARGET) 08000013 * RD = A(TARGET DED) 08500013 * 09000013 * INPUT N/A 09500013 * 10000013 * OUTPUT WRB1 - ADDRESS OF 2ND ROUTINE 10500013 * WRB2 - ADDRESS OF 3RD ROUTINE 11000013 * WRCD - CONTENTS OF RC AND RD 11500013 * 12000013 * EXTERNAL MODULES 12500013 * IHEVKB 13000013 * IHEVKC 13500013 * IHEVPE 14000013 * IHEVPF 14500013 * IHEVPG 15000013 * IHEVPH 15500013 * IHEVFD 16000013 * IHEVFE 16500013 * 17000013 * EXIT NORMAL - TRANSFER CONTROL TO ONE OF THE ABOVE MODULES 17500013 * 18000013 * TABLES/WORK AREA 18500013 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 19000013 * 19500013 * ATTRIBUTES READ ONLY AND REENTRANT 20000013 * 20500013 * PRIVATE MACROS 21000013 * IHELIB,IHEPRV,IHESDR 21500013 * 22000013 * ASSEMBLY REQUIREMENTS 22500013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 23000013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 23500013 * 24000013 * NOTES SEE OS/360 PL/1 LIBRARY PLM FOR DESCRIPTION OF LIBRARY 24500013 * CONVENTIONS AND STANDARDS 25000013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 25500013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 26000013 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING 26500013 * HAS BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 27000013 * CONSTANTS,BY REASSEMBLY,WILL RESULT IN A CORRECT MODULE 27500013 * FOR THE NEW DEFINITIONS. 28000013 EJECT 28500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA001-TSS 28700001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 29000013 PUNCH ' LIBRARY *(IHEVPAA,IHEVPBA,IHEVPCA,IHEVPDA,IHEVPEA,/29500013 IHEVPFA,IHEVPGA) DMA0000A' 30000013 PUNCH ' LIBRARY *(IHEVPHA,IHEVFAA,IHEVFBA,IHEVFCA,IHEVFDA,/30500013 IHEVFEA,IHEVKBA) DMA0000B' 31000013 PUNCH ' LIBRARY *(IHEVKCA,IHEVKFA,IHEVKGA) /31500013 DMA0000C' 32000013 * ----------------------------------------------------DMA001-TSS 32200001 SPACE 32500013 IHEDMA CSECT 33000013 IHELIB 33500013 IHEZLW0 DSECT 34000013 DS 15D 34500013 WORK EQU IHEZLW0 35000013 IHEDMA CSECT 35500013 ENTRY IHEDMAA 36000013 USING *,BR 36500013 USING IHEZLCA,WR 37000013 USING IHEZLW0,DR 37500013 IHEDMAA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 38000013 IHESDR LW0,WR UPDATE SAVE AREA POINTER 38500013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 39000013 STM RC,RD,WRCD SAVE TARGET PARAMETERS IN LCA 39500013 DM010 LA RH,4 . SET RH INITIALLY TO 4(D-D). 40000013 SR RJ,RJ 40500013 IC RJ,0(RD) LOAD DED-TARGET FIRST BYTE 41000013 IC RJ,XT01(RJ) GET FUNCTION VALUE FROM TABLE. 41500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA999-TSS 41700000 L RG,AT01(RJ) GET ADDR OF TARGET CONVERSION. 42000013 * ----------------------------------------------------DMA999-TSS 42200000 CH RJ,AC01 IS IT A DECIMAL TARGET.. 42500013 BC 10,DM020 YES RH REMAINS AT 4( -D). 43000013 AR RH,RH NO RH IS NOW 8( -B). 43500013 DM020 IC RJ,0(RB) LOAD DED-SOURCE FIRST BYTE 44000013 IC RJ,XT01(RJ) GET FUNCTION VALUE FROM TABLE. 44500013 CH RJ,AC01 IS IT A DECIMAL SOURCE.. 45000013 BC 10,DM030 YES RH STAYS AT 4(D-D),8(D-B). 45500013 SH RH,DM010+2 NO RH IS NOW 0(B-D),4(B-B). 46000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA993-TSS 46200000 DM030 EX 0,DM110(RH) IF RH=0,8 LOAD RADIX CONVERSION 46500013 * ----------------------------------------------------DMA993-TSS 46700000 * ROUTINE ADDR,=4 NOP. 47000013 EX 0,DM120(RH) IF RH=0,8 STORE RADIX&TARGET 47500013 * ADDRS,=4 STORE TARGET ADDR. 48000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA998-TSS 48200000 DM040 L BR,AT21(RJ) LOAD SOURCE CONVERSION ADDR. 48500013 * ----------------------------------------------------DMA998-TSS 48700000 BCR 15,BR X ENTER SOURCE CONVERSION ROUTINE 49000013 SPACE 4 49500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA997-TSS 49700000 DM110 L RF,AT11 +0 LOAD HEX-FLT TO DEC FLT RTNE 50000013 * ----------------------------------------------------DMA997-TSS 50200000 BCR 0,0 +4 NOPR. 50500013 AC01 DC AL2(AT02-AT01) (CONSTANT FOR DEC/BIN TYPE). 51000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA996-TSS 51200000 L RF,AT12 +8 LOAD DEC-FLT TO HEX-FLT RTNE 51500013 * ----------------------------------------------------DMA996-TSS 51700000 SPACE 52000013 DM120 STM RF,RG,WBR1 +0, STORE RADIX&TARGET CONV.NS. 52500013 ST RG,WBR1 +4, STORE TARGET CONVERSION. 53000013 STM RF,RG,WBR1 +8, STORE RADIX&TARGET CONV.NS. 53500013 SPACE 2 54000013 * ADDRESSES OF TARGET CONVERSION ROUTINES. 54500013 SPACE 55000013 DS 0F FUNCTION CODE. CONVERSION. 55500013 SPACE 56000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA995-TSS 56200000 AT01 DC V(IHEVFBA) FLI TO FXB 56500013 DC V(IHEVFCA) FLI TO FLT 57000013 VKEA DC A(0) FUTURE DC V IHEVKEA 57500013 * INTERMEDIATE CONVERSION ROUTINES 58000013 SPACE 58500013 AT11 DC V(IHEVFAA) FLI TO PDI 59000013 AT12 DC V(IHEVPAA) PDI TO FLI 59500013 SPACE 60000013 AT02 DC V(IHEVKGA) PDI TO NFS 60500013 DC V(IHEVPDA) PDI TO PD 61000013 DC V(IHEVKFA) PDI TO NFD 61500013 DC V(IHEVPBA) PDI TO F 62000013 DC V(IHEVPCA) PDI TO E 62500013 * ----------------------------------------------------DMA995-TSS 62700000 SPACE 2 63000013 XT01 EQU *-124 BASE ADDRESS OF FUNCTION TABLE 63500013 SPACE 2 64000013 ORG XT01+125 64500013 SPACE 65000013 DC X'0C' BIT CONSTANT 65500013 DC X'24' E OUTPUT 66000013 DC X'20' F OUTPUT 66500013 DC 4X'1C' NFD 67000013 DC 4X'08' NFB 67500013 DC 2X'18' FXD 68000013 DC 2X'04' FLT 68500013 DC 2X'00' FXB 69000013 DC 2X'04' FLT 69500013 DS 2C 70000013 DC 2X'1C' NFD 70500013 DS 2C 71000013 DC 2X'08' NFB 71500013 DC 2X'18' FXD 47694 72000056 DC 2X'04' FLT 72500013 DC 2X'00' FXB 73000001 DC 2X'04' FLT 73500013 DC 2X'14' NFS 74000013 SPACE 2 74500013 * ADDRESSES OF SOURCE CONVERSION ROUTINES. 75000013 SPACE 75500013 DS 0F FUNCTION CODE. CONVERSION. 76000013 SPACE 76500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DMA994-TSS 76700000 AT21 DC V(IHEVFDA) FXB TO FLI 77000013 DC V(IHEVFEA) FLT TO FLI 77500013 VKAA DC A(0) FUTURE DC V IHEVKAA 78000013 DC V(IHEVPHA) BITCON TO FLI 78500013 DC V(IHEVPGA) BINCON TO FLI 79000013 DC V(IHEVKCA) NFS TO PDI 79500013 DC V(IHEVPFA) FXD TO PDI 80000013 DC V(IHEVKBA) NFD TO PDI 80500013 DC V(IHEVPEA) F/E TO PDI 81000013 * ----------------------------------------------------DMA994-TSS 81200000 SPACE 81500013 DS 0F FUNCTION BYTES (3) 82000013 SPACE 82500013 DC 4X'20' F/E INPUT 83000013 DC 4X'10' BIN CONST 83500013 DS 10C 84000013 DC 2X'20' LONG DEC FLT INPUT 84500013 DS 2C 85000013 DC 2X'10' LONG BIN FLT CON INPUT 85500013 END 86000013 ./ ADD SSI=05011973,SOURCE=1,NAME=IHEDNBA DNB TITLE ' IHEDNB ARITHMETIC TO BIT STRING DIRECTOR *00700013 O/S 360 PL/1 LIBRARY' 01400013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 02100013 * 02800013 * STATUS CHANGE LEVEL - 0 03500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DNB000-TSS 03700001 * ----------------------------------------------------DNB000-TSS 03900001 * 04200013 * SIZE 216 BYTES 04900013 * 05600013 * FUNCTION TO CONVERT ANY ARITHMETIC DATA TYPE TO A FIXED OR 06300013 * VARYING LENGTH BIT STRING. 07000013 * 07700013 * ENTRY POINTS 08400013 * IHEDNBA 09100013 * RA = A(SOURCE) 09800013 * RB = A(SOURCE DED) 10500013 * RC = A(TARGET DOPE VECTOR) 11200013 * RD = A(TARGET DED) 11900013 * 12600013 * INPUT N/A 13300013 * 14000013 * OUTPUT N/A 14700013 * 15400013 * EXTERNAL MODULES 16100013 * IHEDMA - ARITHMETIC CONVERSION DIRECTOR 16800013 * IHEVSA - BIT STRING ASSIGNMENT MODULE 17500013 * 18200013 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 18900013 * 19600013 * TABLES/WORKAREA 20300013 * WORK AREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 21000013 * ATTRIBUTES,READ ONLY AND REENTRANT 21700013 * 22400013 * PRIVATE MACROS 23100013 * IHELIB,IHEPRV,IHESDR 23800013 * 24500013 * ASSEMBLY REQUIREMENTS 25200013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 25900013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 26600013 * 27300013 * NOTES SEE O/S360 PL/1 LIBRARY PLM FOR LIBRARY MODULE 28000013 * CONVENTIONS AND STANDARDS 28700013 * THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON 29400013 * A PARTICULAR INTERNAL REPRESENTATION OF THE 30100013 * EXTERNAL CHARACTER SET. 30800013 EJECT 31500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DNB001-TSS 31800001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 32200013 PUNCH ' LIBRARY *(IHEDMAA) /32900013 DNB0000A' 33600013 * ----------------------------------------------------DNB001-TSS 33900001 SPACE 34300013 IHEDNB CSECT 35000013 IHELIB 35700013 IHEZLW2 DSECT 36400013 DS 15D 37100013 WORK EQU IHEZLW2 37800013 IHEDNB CSECT 38500013 ENTRY IHEDNBA 39200013 USING *,RJ 39900013 USING IHEZLCA,WR 40600013 USING IHEZLW2,DR 41300013 IHEDNBA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 42000013 IHESDR LW2,WR UPDATE SAVE AREA POINTER 42700013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 43400013 LR RJ,BR TRANSFER BASE REGISTER 44100013 STM RC,RD,PSAVE SAVE TARGET PARAMETERS 44800013 GETPR SR RF,RF GET SOURCE 45500013 IC RF,1(RB) PRECISION 46200013 TM 0(RB),FIXD SOURCE SCALE FIXED 46900013 BZ CALCP YES BRANCH 47600013 TESTB TM 0(RB),BINY SOURCE BASE BINARY 48300013 BZ SETPN NO,BRANCH 49000013 COMPR CH RF,K031 RESULTING PRECISION GREATER 31 49700013 BNH CONVT NO,BRANCH 50400013 LA RF,31 SET PRECISION EQUAL TO 31 51100013 CONVT EQU * 18372 51300017 TM 0(RB),X'C0' IS SOURCE CHAR FORM OF ARITH? 18372 51500017 BNO NOTCHAR NO BRANCH ROUND 18372 51700017 IHEPRV ERR,BR,OP=LA ELSE SET ERROR CODE IN CASE 18372 51900017 OI 1(BR),X'04' OF ERROR 18372 52100017 NOTCHAR EQU * 18372 52300017 BNE MVIFB NO. 52500013 CLI 2(RB),XNIL SOURCE FIXED BINARY INTEGER.. 53200013 BNE MVIFB NO. 53900013 TM 0(RB),HWRD TEST DED FOR HALF WORD 54100001 BO LOADH 54300001 L RG,0(RA) LOAD FULL_WORD SOURCE 54500001 B NODMA 54700001 LOADH LH RG,0(RA) LOAD HALF WORD SOURCE 54900001 B NODMA SKIP OVER CONVERSION. 55300013 MVIFB MVI PSAVE+8,FXBD STORE DED FLAG BYTE. 56000013 STC RF,PSAVE+9 STORE PRECISION 56700013 MVI PSAVE+10,XNIL STORE SCALE FACTOR 57400013 LA RD,PSAVE+8 LOAD ADDRESS OF DED 58100013 LA RC,PSAVE+12 LOAD ADDRESS OF FIELD 58800013 CALLD L BR,DMAA LOAD BRANCH ADDRESS 59500013 BALR LR,BR CALL ARITH CONVERSION DIRECTOR 60200013 L RG,PSAVE+12 LOAD FIXED BINARY RESULT 60900013 NODMA C RG,MXNG COMPARE WITH MAXIMUM NEGATIVE. 61600013 BE NOSET 62300013 LPR RG,RG SET POSITIVE 63000013 NOSET LCR RH,RF COMPLEMENT PRECISION. 63700013 SLL RG,32(RH) LEFT ADJUST P BITS 64400013 ST RG,PSAVE+12 STORE BIT STRING 65100013 LA RG,PSAVE+12 GET ADDRESS OF CREATED BIT STR. 65800013 ST RG,PSAVE+16 STORE ADDRESS IN DOPE VECTOR 66500013 SETPS STH RF,PSAVE+22 STORE CURRENT LENGTH IN DOPE V 67200013 LA RA,PSAVE+16 LOAD ADDRESS OF DOPE VECTOR 67900013 STDED LA RB,BITD LOAD ADDRESS OF BIT STRING DED 68600013 LM RC,RD,PSAVE RESTORE TARGET PARAMETERS 69300013 L BR,VSAA LOAD BRANCH ADDRESS 70000013 BALR LR,BR CALL BIT STRING ASSIGNMENT RTN 70700013 RESET L DR,OFDR(DR) RESET SAVE AREA POINTER 71400013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 72100013 BR LR RETURN 72800013 CALCP SR RG,RG CLEAR REGISTER 73500013 ST RG,PSAVE+20 SET CURRENT LENGTH ZERO 74200013 IC RG,2(RB) GET SCALE FACTOR Q 74900013 SH RG,K128 REMOVE EXCESS 75600013 SR RF,RG CALCULATE (P-Q) 76300013 BP TESTB BRANCH POSITIVE 77000013 LA RG,PSAVE+12 GET ADDRESS OF STRING 77700013 ST RG,PSAVE+16 STORE ADDRESS IN DOPE VECTOR 78400013 LA RA,4(RG) LOAD ADDRESS OF DOPE VECTOR 79100013 B STDED 79800013 SETPN MH RF,K332 MULTIPLY BY 3.32 80500013 SRL RF,8 TAKE CEIL 81200013 LA RF,1(RF) OF RESULT 81900013 B COMPR 82600013 DMAA DC V(IHEDMAA) 83300013 VSAA DC V(IHEVSAA) 84000013 MXNG DC X'80000000' MUST BE ON WORD BOUNDARY. 84700013 K332 DC X'0352' 85400013 K001 DC H'1' 86100013 K031 DC H'31' 86800013 K128 DC H'128' 87500013 BITD DC X'18' 88200013 FDED DC X'7F' 88900013 FXBD EQU X'8C' 89600013 XNIL EQU X'80' 90300013 PSAVE EQU WORK+72 91000013 BINY EQU X'04' 91700013 FIXD EQU X'02' 92400013 HWRD EQU X'10' 92700001 END 93100013 ./ ADD SSI=06012881,SOURCE=1,NAME=IHEDNCA DNC TITLE ' IHEDNC ARITHMETIC TO CHARACTER *00300013 O/S 360 PL/1 LIBRARY' 00600013 * VERSION SECOND VERSION OF F-LEVEL PL/1 COMPILER 00900013 * 01200013 * STATUS CHANGE LEVEL - 0 01500013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DNC000-TSS 01600001 * ----------------------------------------------------DNC000-TSS 01700001 * 01800013 * SIZE 632 BYTES 02100013 * 02400013 * FUNCTION TO CONVERT ANY ARITHMETIC DATA TYPE TO A FIXED OR 02700013 * VARYING LENGTH CHARACTER STRING,OR TO A PICTURED 03000013 * CHARACTER STRING 03300013 * 03600013 * ENTRY POINTS 03900013 * IHEDNCA 04200013 * RA = A(SOURCE) 04500013 * RB = A(SOURCE DED) 04800013 * RC = A(TARGET DOPE VECTOR) 05100013 * RD = A(TARGET DED) 05400013 * 05700013 * INPUT N/A 06000013 * 06300013 * OUTPUT N/A 06600013 * 06900013 * EXTERNAL MODULES 07200013 * IHEDMA - ARITHMETIC CONVERSION DIRECTOR 07500013 * IHEUPA - TO OBTAIN ADDRESS OF IMAGINARY PART OF A 07800013 * CODED COMPLEX VARIABLE 08100013 * IHEVSC - CHARACTER STRING ASSIGNMENT ROUTINE 08400013 * IHEVSE - CHARACTER STRING TO PICTURED CHARACTER STRING. 08700013 * IHEVSB - BIT STRING TO CHARACTER STRING CONVERSION 09000013 * IHEVSF - BIT STRING TO PICTURED CHARACTER STRING. 09300013 * 09600013 * EXITS NORMAL - RETURN TO CALLER VIA LINK REGISTER 09900013 * 10200013 * TABLES/WORKAREA 10500013 * WORKAREA IS OBTAINED FROM DYNAMIC STORAGE (LWS) 10800013 * 11100013 * ATTRIBUTES READ ONLY AND REENTRANT. 11400013 * 11700013 * PRIVATE MACROS 12000013 * IHELIB,IHEPRV,IHESDR 12300013 * 12600013 * ASSEMBLY REQUIREMENTS 12900013 * MUST BE ASSEMBLED BY AN ASSEMBLER WITH PSEUDO-REGISTER 13200013 * SUPPORT E.G. O/S 360 F-ASSEMBLER. 13500013 * 13800013 * NOTE SEE O/S360 PL/1 LIBRARY PLM FOR DESCRIPTION OF MODULE 14100013 * CONVENTIONS AND STANDARDS 14400013 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 14700013 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 15000013 * THE SAME AS THAT USED AT ASSEMBLY TIME. THE CODING HAS 15300013 * BEEN ARRANGED SO THAT REDEFINITION OF ''CHARACTER'' 15600013 * CONSTANTS,BY REASSEMBLY,WILL RESULT IN A CORRECT MODULE 15900013 EJECT 16200013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*DNC001-TSS 16300001 * THE FOLLOWING MODULES MUST BE INCLUDED IF REQUIRED 16500013 PUNCH ' LIBRARY *(IHEDMAA,IHEUPAB,IHEVSCA,IHEVSBA,IHEVSFA,/16800013 IHEVSEB,IHEVQCA) DNC0000A' 17100013 * ----------------------------------------------------DNC001-TSS 17200001 SPACE 17400013 IHEDNC CSECT 17700013 IHELIB 18000013 IHEZLW2 DSECT 18300013 DS 15D 18600013 WORK EQU IHEZLW2 18900013 IHEDNC CSECT 19200013 ENTRY IHEDNCA 19500013 USING *,RJ 19800013 USING IHEZLCA,WR 20100013 USING IHEZLW2,DR 20400013 IHEDNCA STM LR,WR,OFLR(DR) SAVE CALLERS REGISTERS 20700013 IHESDR LW2,WR GET WORKSPACE ADDRESS 21000013 IHEPRV ,WR GET COMMUNICATION AREA ADDRESS 21300013 LR RJ,BR TRANSFER BASE REGISTER 21600013 MVI PSWT,ZERO RESET SWITCHES 21900013 MVI WSWB,0 SET FOR CHARACTER TARGET. 22000015 TM 0(RB),CODE TEST SOURCE TYPE 22200013 BZ TCOMP BRANCH IF NUMERIC 22500013 L BR,VQCA DOES VQC EXIST? 22800013 LTR BR,BR 23100013 BZ QGONE 23400013 LH BR,0(BR) GET TOP TWO BYTES OF VCON. 23420001 CH BR,XFER + IS IT A TRANSFER VECTOR. 23440001 L BR,VQCA GET VCON ONCE AGAIN. 23460001 BNE SHRLIB * NO. MUST BE A(CONV MODULE). 23480001 LR R0,RA SAVE REGISTER ONE. 23500001 LH LR,2(BR) STEP DOWN TRANSFER 23520001 LH RA,6(BR) VECTOR UNTILL THE 23540001 L BR,0(LR,PR) REAL VCON IS 23560001 L BR,0(RA,BR) LOADED INTO BR. 23580001 LR RA,R0 RESTORE REGISTER ONE. 23600001 LTR BR,BR + IS THE MODULE PRESENT. 23620001 BZ QGONE * NO. USE IHEDMA. 23640001 SHRLIB EQU * 23660001 CLI 0(RB),X'88' TEST FOR FIXED DECIMAL. 23700013 BE QCALL 24000013 CLI 0(RB),X'8C' TEST FOR FIXED BINARY. 24300013 BNE QGONE 24600013 CLI 2(RB),X'80' 24900013 BE QCALL 25200013 QGONE EQU * 25270017 STM RC,RD,SAV1 SAVE TARGET PARAMETERS 25340017 TM 0(RB),X'C0' IS SOURCE CHAR FORM OF ARITH? 18372 25410017 BNO NOTCHAR NO BRANCH ROUND 18372 25480017 IHEPRV ERR,BR,OP=LA ELSE SET ERROR CODE IN CASE 18372 25550017 OI 1(BR),X'04' OF ERROR 18372 25620017 NOTCHAR EQU * 18372 25690017 LA RC,WCFD GET ADDRESS OF CREATED FED 25800013 ST RC,WFDT STORE IN TARGET FED POINTER 26100013 LA RC,PWRK SET TEMPORARY STORE ADDRESS. 26400013 SR RF,RF CLEAR 26700013 LR RE,RF REGISTERS 27000013 IC RF,1(RB) GET SOURCE PRECISION 27300013 IC RE,2(RB) GET SOURCE SCALE FACTOR 27600013 SH RE,K128 REMOVE EXCESS 27900013 TM 0(RB),BINY TEST BASE OF SOURCE 28200013 BZ TSCAL BRANCH IF DECIMAL 28500013 LR RG,RF SET MULTIPLICAND 28800013 M RF,K332 PRECISION *1/3.32 29100013 LTR RG,RG TAKE 29400013 BZ TSCLE CEIL 29700013 LA RF,1(RF) OF RESULT 30000013 TSCLE TM 0(RB),FLOT TEST SCALE OF SOURCE 30300013 BO CALLE BRANCH IF FLOAT 30600013 LA RF,1(RF) BUMP PRECISION BY ONE 30900013 LPR RI,RE SET MULTIPLICAND TO ABS SF. 31200013 M RH,K332 CALCULATE CEIL(Q*1/3.32) 31500013 LTR RI,RI EQUIVALENT 31800013 BZ TESTQ OF SOURCE 32100013 LA RH,1(RH) SCALE FACTOR 32400013 TESTQ LTR RE,RE TEST SIGN OF SOURCE SCALE FACTR 32700013 LR RE,RH REPLACE WITH DECM EQUIV OF SF. 33000013 BNL TSCFC BRANCH IF POSITIVE 33300013 LCR RE,RE SET DECIMAL EQUIVALENT NEGATIVE 33600013 TSCFC LTR RE,RE TEST SCALE FACTOR 33900013 BM FTYPE BRANCH IF NEGATIVE 34200013 CR RE,RF COMPARE WITH PRECISION 34500013 BH FTYPE BRANCH IF GREATER THAN PRECISN 34800013 LA RG,3(RF) SET W=P+3 (3 IN CASE P=Q) *** 35100013 STH RG,WCFD STORE IN CREATED FED 35400013 STC RE,WCFD+2 STORE D=SCALE FACTOR 35700013 MVI WCFD+3,NULL ZERO P 36000013 B CALLF GO CALL CONVERSION 36300013 FTYPE STM RA,RB,DOPV SAVE SOURCE PARAMETERS 36600013 TM 0(RB),BINY TEST BASE OF SOURCE 36900013 BO CONBD BRANCH IF BINARY 37200013 SFSWT OI PSWT,FSWT SET F TYPE SWITCH 37500013 LA RG,1(RF) SET W=P+1 37800013 STH RG,WCFD STORE IN CREATED FED 38100013 MVI WCFD+2,ZERO SET D=0 38400013 LR RG,RE ADD EXCESS 38700013 AH RG,K128 TO SOURCE SCALE FACTOR 39000013 STC RG,WCFD+3 STORE IN P 39300013 CALLF LA RD,FDED SET FOR F OUTPUT 39600013 CALLD L BR,DMAA CALL ARITHMETIC 39900013 BALR LR,BR CONVERSION DIRECTOR 40200013 AH RC,WCFD INCREMENT TEMP ADDRESS 40500013 TM PSWT,FSWT TEST F TYPE SWITCH 40800013 BO APNDF BRANCH IF SET 41100013 TCSWT TM PSWT,CSWT TEST COMPLEX SWITCH 41400013 BO APNDI BRANCH IF SET 41700013 TM 0(RB),CPLX TEST MODE OF SOURCE 42000013 BZ ASSGN BRANCH IF REAL 42300013 OI WSWA,UPDO SET UPDATE ONLY SWITCH 42600013 OI PSWT,CSWT SET COMPLEX SWITCH 42900013 L BR,UPAB CALL ROUTINE TO GET 43200013 BALR LR,BR ADDRESS OF IMAGINARY PART 43500013 L RA,WRCD LOAD ADDRESS OF IMAGINARY PART 43800013 ST RC,SAV2 SAVE ADDRESS OF IMAG RESULT 44100013 TSCAL TM 0(RB),FLOT TEST SCALE OF SOURCE 44400013 BZ TSCFC BRANCH IF FIXED 44700013 CALLE STC RF,WCFD+3 SET S=P 45000013 LR RG,RF CALCULATE 45300013 BCTR RG,0 D=P-1 45600013 STC RG,WCFD+2 AND STORE 45900013 LA RG,7(RG) STORE 46200013 STH RG,WCFD W=P+6 46500013 LA RD,EDED SET FOR E OUTPUT 46800013 B CALLD GO CALL CONVERSION 47100013 APNDF MVI 0(RC),C'F' APPEND LETTER F 47400013 ST RA,SAV3 SAVE SOURCE ADDRESS ACROSS EDIT 47700013 LCR RG,RE TURN SCALE FACTOR INTO EXPONENT 48000013 CVD RG,WINT CONVERT TO DECIMAL 48300013 MVC EDIT(4),MASK PREPARE FOR EDIT 48600013 LA RA,EDIT+3 SET SIGNIFICANCE POINTER 48900013 LR LR,RA SAVE JUNIOR DIGIT ADDRESS 49200013 EDMK EDIT(4),WINT+6 EDIT CONVERTED SCALE FACTOR 49500013 BCTR RA,0 GET ADDRESS OF SIGN POSITION 49800013 BNL SGNOK BRANCH IF RESULT NOT NEGATIVE 50100013 MVI 0(RA),C'-' SET SIGN MINUS 50400013 SGNOK SR LR,RA GET LENGTH OF EXPONENT 50700013 EX LR,MVCH MOVE EDITED EXPONENT INTO FIELD 51000013 LA RC,2(RC,LR) INCREMENT TEMP POINTER 51300013 L RA,SAV3 RESTORE SOURCE ADDRESS 51600013 LM RA,RB,DOPV RESTORE SOURCE PARAMETERS 51900013 B TCSWT GO TEST COMPLEX SWITCH 52200013 APNDI MVI 0(RC),C'I' APPEND LETTER I 52500013 L RG,SAV2 RESTORE START ADDRESS OF IMAG. 52800013 LR RI,RC CALCULATE LENGTH 53100013 SR RI,RG OF IMAGINARY PART 53400013 LA RC,1(RC) BUMP TEMP POINTER 53700013 MVI 0(RC),C' ' APPEND BLANK 54000013 CLI 0(RG),C' ' TEST FIRST CHARACTER 54300013 BNE ASSGN BRANCH IF NOT BLANK 54600013 TSIGN CLI 1(RG),C'-' NEXT CHARACTER MINUS SIGN 54900013 BE SHIFT YES,BRANCH 55200013 CLI 1(RG),C' ' NEXT CHARACTER BLANK 55500013 BNE INSRT NO,BRANCH 55800013 EX RI,MVCR REMOVE LEADING BLANK 56100013 B TSIGN LOOP 56400013 INSRT MVI 0(RG),C'+' INSERT PLUS SIGN 56700013 B ASSGN 57000013 MVCR MVC 0(0,RG),1(RG) EXECUTED MOVE CHARACTERS 57300013 SHIFT EX RI,MVCR REMOVE LEADING BLANK 57600013 ASSGN LA RG,PWRK LOAD TEMP START ADDRESS 57900013 ST RG,DOPV STORE IN DOPE VECTOR 58200013 SR RC,RG CALCULATE LENGTH OF TEMP 58500013 ST RC,DOPV+4 STORE IN CURRENT LENGTH 58800013 LM RC,RD,SAV1 RESTORE TARGET PARAMETERS 59100013 PICTG LA RA,DOPV SET DOPE VECTOR POINTER 59400013 LA RB,CDED SET CHAR STRING DED POINTER 59700013 TM 0(RD),PICT TEST TARGET STRING TYPE 60000013 L BR,VSCA SET FOR CHARACTER 60300013 BO CALLS BRANCH IF CHARACTER 60600013 L BR,VSEA SET FOR PICTURED 60900013 CALLS BALR LR,BR CALL ASSIGNMENT ROUTINE 61200013 ENDRT L DR,OFDR(DR) RESET SAVE AREA POINTER 61500013 LM LR,WR,OFLR(DR) RESTORE CALLERS REGISTERS 61800013 BR LR RETURN 62100013 TCOMP SR R0,R0 GET FIELD WIDTH 62400013 IC R0,3(RB) FROM DED 62700013 TM 0(RB),CPLX TEST MODE OF SOURCE 63000013 BZ TBASE BRANCH IF REAL 63300013 AR R0,R0 DOUBLE WIDTH 63600013 TBASE ST R0,DOPV+4 STORE CURRENT LENGTH 63900013 ST RA,DOPV STORE STRING ADDR IN DOPE VECTR 64200013 B PICTG GO TEST TARGET TYPE 64500013 CONBD MVI EDIT,X'88' SET DED FOR 64800013 STC RF,EDIT+1 FIXED DECIMAL 65100013 LR RG,RE EQUIVALENT OF 65400013 AH RG,K128 FIXED BINARY 65700013 STC RG,EDIT+2 SOURCE 66000013 LA RD,EDIT CALL CONVERSION 66300013 L BR,DMAA TO FIXED 66600013 BALR LR,BR DECIMAL 66900013 LR RA,RC REPLACE ORIGINAL 67200013 LR RB,RD SOURCE 67500013 B SFSWT CONTINUE 67800013 SPACE 68100013 QCALL BALR LR,BR CALL VQC. 68500015 B ENDRT 69000013 SPACE