./ ADD SSI=02014038,NAME=IHD00000,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00000 * 00060000 TITLE 'IHD000000 - CONVERT EXT FL-POINT TO INT FL-POINT SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: EXTRACTS ADDRESS,LENGTH & SCALE FACTOR OF EXT FL* 00120000 * POINT NUMBER AND CONVERTS THE NUMBER TO BINARY,THEN TO A DOUBLE * 00140000 * PRECISION INTERNAL FL-POINT NUMBER. * 00160000 *ENTRY POINT: * 00180000 * IHD00001 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00200000 * L 15,CONVER * 00220000 * BALR 14,15 * 00240000 * CONVER DC A(IHD00001) * 00260000 * * 00280000 *INPUT: ADDRESS IN REG 14 AT TIME OF ENTRY CONTAINS ADDRESS OF FIRST * 00300000 * OF THREE LOAD ADDRESS INSTRUCTIONS WHICH WHEN EXECUTED PREPARE THE* 00320000 * ADDRESS,LENGTH AND SCALE FACTOR(IF GIVEN) AND PLACE THEM IN * 00340000 * BUCKETS.(LABELS ARE-ADDRIN - LENGIN - SCALIN). * 00360000 * * 00380000 *OUTPUT: FL-POINT REG 0 WILL CONTAIN RESULTING FL-POINT NUMBER. * 00400000 * * 00420000 *EXTERNAL ROUTINES: * 00440000 * IHD01601 - CONVERT PACKED/ZONED DECIMAL TO BINARY * 00460000 * IHD01502 - CONVERT BINARY TO DOUBLE PRECISION FL-POINT * 00480000 * * 00500000 *EXITS NORMAL: LOADR BR 14 (RETURN TO LINKAGE ADDRESS + 12. * 00520000 *EXITS ERROR: N/A * 00540000 * * 00560000 *TABLES/WORKAREAS: * 00580000 * WORKB=WORKA1 - EXTERNAL MANTISSA PACK AREA * 00600000 * WORKA1=WORKB * 00620000 * AREX - EXTERNAL EXPONENT PACK AREA * 00640000 * SCALIN - SCALE FACTOR IN EXTERNAL FL-POINT PICTURE * 00660000 * ADDRIN - ADDRESS OF EXTERNAL FL-POINT NUMBER TO BE CONVERTED* 00680000 * LENGIN - LENGTH OF EXTERNAL FL-POINT NUMBER TO BE CONVERTED * 00700000 * SAVEAR - REG 13 SAVE AREA(REG 13 HOLDS ADDRESS OF MULTIPLE * 00720000 * REGISTER SAVE AREA). * 00740000 * L1 - LINKAGE REGISTER * 00760000 * * 00780000 *ATTRIBUTES: * 00800000 * SERIALLY REUSABLE * 00820000 *********************************************************************** 00840000 * 00860000 * 00880000 IHD00000 START 0 FFONV 00900000 ENTRY IHD00001 CONVER 00920000 EXTRN IHD01601 PKDBIN 00940000 EXTRN IHD01502 BINFSC 00960000 USING *,15 00980000 * 01000000 IHD00001 STM 14,12,12(13) 01020000 ST 13,SAVEAR 01040000 XC WB(18),WB 01060000 EX 0,0(L1) GET ADDRESS INPUT 01080000 CLI 0(L1),X'58' LOOK FOR GENERATED LOAD INSTRUCTION 01100000 LA L1,4(L1) INIT TO CHECK NEXT INSTRUCTION 01120000 BE *-12 LOOP TIL LOAD IS BYPASSED AND LOAD ADDR IS FOUND 01140000 ST C2,ADDRIN SAVE INPUT ADDRESS 01160000 EX 0,0(L1) GET LENGTH OF INPUT 01180000 CLI 0(L1),X'58' LOOK FOR GENERATED LOAD INSTRUCTION 01200000 LA L1,4(L1) INIT TO CHECK NEXT INSTRUCTION 01220000 BE *-12 LOOP TIL LOAD IS BYPASSED AND LOAD ADDR IS FOUND 01240000 ST C2,LENGIN SAVE LENGTH 01260000 EX 0,0(L1) GET SCALE FACTOR ADDRESS 01280000 CLI 0(L1),X'58' LOOK FOR GENERATED LOAD INSTRUCTION 01300000 LA L1,4(L1) INIT TO CHECK NEXT INSTRUCTION 01320000 BE *-12 LOOP TIL LOAD IS BYPASSED AND LOAD ADDR IS FOUND 01340000 L W1,ADDRIN 0451 01360000 A W1,LENGIN 0501 01380000 SH W1,CONST2 0551 01400000 MVC WB+18(2),0(W1) MOVE EXPONENT 01420000 SH C2,CON100 01440000 BM IMPLID 01460000 B CONT0 01480000 IMPLID AH C2,CON100 01500000 ST C2,SCALIN 01520000 LA W2,WB 01540000 L W3,LENGIN 01560000 LA W2,23(W2) 01580000 SH W3,CONST5 01600000 B LOAD 01620000 CONT0 ST C2,SCALIN 01640000 L W1,ADDRIN LOAD ADDRESS OF FP NUMBER 0751 01660000 A W1,LENGIN ADD LENGTH 0801 01680000 S W1,SCALIN SUBTRACT SCALE 0851 01700000 SH W1,CONST5 SUBTRACT FIVE 0901 01720000 CLI 0(W1),C'.' VERIFY '.' 0951 01740000 BNE LOADR 01760000 L W3,SCALIN LOAD SCALE 1351 01780000 LTR W3,W3 01800000 BZ EXEC+4 01820000 SH W3,ONE 1061 01840000 LA W1,1(W1) INCREASE ADDRESS BY ONE 1011 01860000 LA W2,WB LOAD AREA ADDRESS 1021 01880000 S W2,SCALIN SUBTRACT SCALE 1031 01900000 LA W2,18(W2) INCREASE ADDRESS BY 18 01920000 EXEC EX W3,INST 01940000 LA W2,WB LOAD AREA ADDRESS 1151 01960000 LA W2,24(W2) ADD 24 TO ABOVE 01980000 L W3,LENGIN LOAD LENGTH 1301 02000000 S W3,SCALIN ADD SCALE 1401 02020000 SH W3,CONS6 SUBTRACT SIX 1451 02040000 LOAD L W1,ADDRIN 02060000 LA W1,1(W1) ADD ADDRESS BY ONE 1101 02080000 S W2,LENGIN SUBTRACT LENGTH 1201 02100000 SH W3,ONE SUBTRACT ONE 1351 02120000 BM MOVE3 02140000 EX W3,INST MOVE INTEGERS 0002 02160000 MOVEZ MVZ WB+19(1),ONEPOS 02180000 MVZ WB+17(1),ONEPOS MOVE PLUS ZONE 02200000 MOVE3 L W1,ADDRIN LOAD ADDRESS 0602 02220000 A W1,LENGIN ADD LENGTH 0652 02240000 SH W1,CONST3 SUBTACT THREE 0702 02260000 CLI 0(W1),C'-' COMPARE NEGATIVE SIGN 0752 02280000 BNE OUT IF POSITIVE OUT 0802 02300000 MVZ WB+19(1),ONENEG MOVE ZONE IF NEGATIVE 02320000 OUT L W1,ADDRIN 02340000 CLI 0(W1),C'-' 02360000 BNE CONT 02380000 MVZ WB+17(1),ONENEG MOVE NEGATIVE SIGN 02400000 CONT PACK WORKB(3,3),WB(4) PACK MANTISSA IN WORKB 02420000 PACK WORKB+2(8,3),WB+3(15) 02440000 PMANT L 15,ADER1 02460000 BALR RTREG,15 02480000 BALR 15,0 02500000 USING *,15 02520000 MVC AREX+6(2),WB+18 02540000 PACK AREX(8),AREX(8) 02560000 CVB W2,AREX 02580000 S W2,SCALIN SUBTRACT SCALE 02600000 L 15,ADER2 02620000 BALR RTREG,15 02640000 LOADR BALR 15,0 02660000 USING *,15 02680000 L 13,SAVEAR 02700000 LM 14,12,12(13) 02720000 BR 14 02740000 ADER1 DC A(IHD01601) 02760000 ADER2 DC A(IHD01502) 02780000 WORKA1 EQU 56 02800000 AREX DC D'0' 02820000 SCALIN DS F 02840000 ADDRIN DS F 02860000 LENGIN DS F 02880000 SAVEAR DS F 02900000 CONST2 DC H'2' 02920000 CON100 DC XL2'0100' 02940000 CONST5 DC H'5' 02960000 CONS6 DC H'6' 02980000 CONST4 DC H'4' 03000000 INST MVC 0(0,W2),0(W1) 03020000 ONE DC H'1' 03040000 CONST3 DC H'3' 03060000 ONEPOS DC Z'+1' 03080000 ONENEG DC Z'-1' 03100000 WB DC 20C'0' 03120000 W1 EQU 10 03140000 W2 EQU 2 03160000 W3 EQU 12 03180000 C1 EQU 1 03200000 C2 EQU 2 03220000 C3 EQU 13 03240000 C0 EQU 0 03260000 WORKB EQU WORKA1 03280000 RTREG EQU 14 03300000 L1 EQU 14 03320000 END 03340000 ./ ADD SSI=01014038,NAME=IHD00100,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00100 * 00060000 TITLE 'IHD00100 - FL-POINT EXPONENTIAL--NON INTEGER POWER SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: COMPUTES FL-POINT EXPONENT * 00120000 *ENTRY POINTS: * 00140000 * IHD00101 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00160000 * L 15,DEXP * 00180000 * BALR 14,15 * 00200000 * DEXP DC A(IHD00101) * 00220000 * * 00240000 *INPUT: GENERAL REGISTER 1 CONTAINS ADDRESS OF ARGUMENT-WORD BOUNDARY* 00260000 * * 00280000 *OUTPUT: FL-POINT REG. CONTAINS RESULTING NORMALIZED NUMBER * 00300000 * * 00320000 *EXTERNAL ROUTINES: N/A * 00340000 *EXITS NORMAL: EXIT- RESTORE REGISTERS AND BR 14. * 00360000 *EXITS ERROR: N/A * 00380000 *TABLES/WORKAREAS: * 00400000 * MCONST - TABLE OF FRACTIONS (2**(-1/16) THRU 2**(-15/16)) * 00420000 * * 00440000 *ATTRIBUTES: * 00460000 * SERIALLY REUSABLE * 00480000 * * 00500000 *NOTES: * 00520000 * EXPONENTIAL FUNCTION (LONG) * 00540000 * Y=X*LOG2(E)=4A-B-C/16-D, WHERE A,B AND C ARE INTEGERS, * 00560000 * B BETWEEN 0 AND 3, C BETWEEN 0 AND 15. * 00580000 * D IS A FRACTION BETWEEN 0 AND 1/16. * 00600000 * THEN E**X=2**Y=(16**A)(2**-B)(2**-C/16)(2**-D) * 00620000 * * 00640000 *********************************************************************** 00660000 * 00680000 * 00700000 IHD00100 START 0 LEXP 00720000 ENTRY IHD00101 DEXP 00740000 ********************************************* 00760000 *** FLOATING POINT EXPONENTIAL SUBROUTINE *** 00780000 ********************************************* 00800000 * EXPONENTIAL FUNCTION (LONG) 00820000 * Y=X*LOG2(E)=4A-B-C/16-D, WHERE A,B, AND C ARE INTEGERS, 00840000 * B BETWEEN 0 AND 3, C BETWEEN 0 AND 15. 00860000 * D IS A FRACTION BETWEEN 0 AND 1/16. 00880000 * THEN E**X=2**Y=(16**A)(2**-B)(2**-C/16)(2**-D) 00900000 GR0 EQU 0 SCRATCH REGISTER 00920000 GR1 EQU 1 00940000 GR2 EQU 2 00960000 GR3 EQU 3 00980000 GRA EQU 1 ARGUMENT REGISTER 01000000 GRS EQU 13 SAVE AREA POINTER 01020000 GRR EQU 14 RETURN REGISTER 01040000 GRL EQU 15 LINK REGISTER 01060000 FR0 EQU 0 ANSWER REGISTER 01080000 FR2 EQU 2 SCRATCH REGISTER 01100000 DC CL5'DEXP' 01120000 DC X'04' 01140000 USING *,GRL 01160000 IHD00101 STM GRR,GR3,12(GRS) SAVE REGISTERS 01180000 L GR1,0(GRA) OBTAIN ARGUMENT 01200000 LD FR0,0(GR1) 01220000 CE FR0,MIN MIN=-65*LOG16=-180.21867 01240000 BC 12,SMALL IF ARG LESS THAN THIS, GIVE ANS=0 01260000 DD FR0,LOGE2 Y=X*LOG2(E) BY ACCURATE DIVISION 01280000 STE FR0,SIGN SAVE SIGN OF Y 01300000 LER FR2,FR0 DECOMPOSE Y=(-4A'-B'-C'/16)-D' 01320000 AU FR2,SCALER BY FORCING CHARACTERISTIC OF X'45' 01340000 STE FR2,FIELDS -4A'-B'-C'/16 IN FIELDS,UNNORMALIZED 01360000 SDR FR2,FR2 01380000 AE FR2,FIELDS NORMALIZE THIS AND SUBTRACT IT 01400000 SDR FR0,FR2 FROM Y TO OBTAIN -D' IN FR0 01420000 L GR2,FIELDS 01440000 TM SIGN,X'80' IF Y NEGATIVE SKIP 01460000 BC 1,READY IF Y NON-NEGATIVE, 01480000 SD FR0,ONO16 -D= /D'/-1/16 01500000 LA GR2,1(GR2) -4A-B-C/16=-(-4A'-B'-(C'+1)/16) 01520000 LCR GR2,GR2 NOW IN ANY CASE B, C, AND D ARE + 01540000 READY SR GR3,GR3 01560000 SRDL GR2,4 C IN HIGH GR3 01580000 SRL GR3,25 01600000 SRDL GR2,2 B IN HIGH GR3, C IN LOW GR3 01620000 SLL GR2,24 01640000 LCR GR0,GR2 A (IN SCALE B7) IN GR0, CHAR MODIFIER 01660000 SR GR2,GR2 01680000 SLDL GR2,2 B IN GR2, 8*C IN GR3 01700000 LDR FR2,FR0 COMPUTE 2**-D BY USE OF 01720000 ME FR0,C6 CHEBYSHEV INTERPOLATION 01740000 AD FR0,C5 POLYNOMIAL OF DEGREE 6 01760000 MDR FR0,FR2 01780000 AD FR0,C4 01800000 MDR FR0,FR2 01820000 AD FR0,C3 01840000 MDR FR0,FR2 01860000 AD FR0,C2 01880000 MDR FR0,FR2 01900000 AD FR0,C1 01920000 MDR FR0,FR2 01940000 AD FR0,C0A ADD C0 = 1 IN TWO STEPS 01960000 AD FR0,C0A TO PROTECT LAST DIGIT 01980000 LTR GR3,GR3 MULTIPLY 2**(-C/16) 02000000 BC 8,SKIP2 IN DOING SO AVOID 02020000 CE FR0,ONE MULTIPLICATION BY 1. 02040000 BC 4,SKIP1 02060000 LD FR0,MCONST-8(GR3) 02080000 BC 15,SKIP2 02100000 SKIP1 MD FR0,MCONST-8(GR3) 02120000 SKIP2 LTR GR2,GR2 MULTIPLY 2**(-B) 02140000 BC 8,SKIP3 BY HALVING B TIMES. 02160000 HDR FR0,FR0 02180000 BCT GR2,*-2 02200000 SKIP3 STD FR0,SIGN ADD A TO CHARACTERISTIC 02220000 A GR0,SIGN 02240000 ST GR0,SIGN 02260000 SDR FR0,FR0 NORMALIZE THE ANSWER JUST IN CASE 02280000 AD FR0,SIGN 02300000 EXIT LM GR2,GR3,28(GRS) RETURN 02320000 MVI 12(GRS),X'FF' 02340000 BCR 15,GRR 02360000 SMALL SDR FR0,FR0 IF X IS VERY LARGE NEGATIVE, 02380000 BC 15,EXIT GIVE 0 AS ANSWER 02400000 SIGN DS D 02420000 FIELDS EQU SIGN+4 02440000 LOGE2 DC X'40B17217F7D1CF79' LOG 2(BE) TRUNCATED 02460000 ONO16 DC X'4010000000000000' 02480000 ONE DC X'41100000' 02500000 C6 DC X'3D9E0F1E' .1507368551403575E-3 02520000 C5 DC X'3E575D42BB7276D4' .1333073417706260E-2 02540000 C4 DC X'3F276553A5F9BC94' .9618117095313700E-2 02560000 C3 DC X'3FE35846A61AEE7A' .5550410840231345E-1 02580000 C2 DC X'403D7F7BFF0289DE' .2402265069563678 02600000 C1 DC X'40B17217F7D1CC79' .6931471805599346 02620000 C0A DC X'4080000000000000' .5 C0/2 02640000 MCONST DC X'40F5257D152486CC' 2**(-1/16) 02660000 DC X'40EAC0C6E7DD2439' 2**(-2/16) 02680000 DC X'40E0CCDEEC2A94E1' 2**(-3/16) 02700000 DC X'40D744FCCAD69D6B' 2**(-1/16) 02720000 DC X'40CE248C151F8481' 2**(-5/16) 02740000 DC X'40C5672A115506DB' 2**(-6/16) 02760000 DC X'40BD08A39F580C37' 2**(-7/16) 02780000 DC X'40B504F333F9DE65' 2**(-8/16) 02800000 DC X'40AD583EEA42A14B' 2**(-9/16) 02820000 DC X'40A5FED6A9B15139' 2**(-10/16) 02840000 DC X'409EF5326091A112' 2**(-11/16) 02860000 DC X'409837F0518DB8A9' 2**(-12/16) 02880000 DC X'4091C3D373AB11C3' 2**(-13/16) 02900000 DC X'408B95C1E3EA8BD7' 2**(-14/16) 02920000 DC X'4085AAC367CC487B' 2**(-15/16) 02940000 SCALER DC X'45000000' 02960000 MAX DC X'42AEAC4E' 174.6731 02980000 MIN DC X'C2B437DF' -180.2187 03000000 END 03020000 ./ ADD SSI=01014040,NAME=IHD00200,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00200 * 00060000 TITLE 'IHD00200 - PACKED DIVIDE SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: DIVIDES A 16 BYTE 30 CHARACTER DIVIDEND BY A 16 * 00120000 * BYTE 30 CHARACTER DIVISOR AND PRODUCES A 16 BYTE 30 CHARACTER * 00140000 * QUOTIENT. * 00160000 * * 00180000 *ENTRY POINTS: * 00200000 * IHD00201 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00220000 * L 15,ADDIV * 00240000 * BALR RTREG,15 * 00260000 * ADDIV DC A(IHD00201) * 00280000 * RTREG EQU 14 * 00300000 * * 00320000 *INPUT: PACKED NUMBERS IN BUCKETS LABELED - DOR(DIVISOR) AND * 00340000 * DEND(DIVIDEND) * 00360000 *OUTPUT: PACKED QUOTIENT IN BUCKET LABELED - QUOT * 00380000 * * 00400000 *EXTERNAL ROUTINES: N/A * 00420000 *EXITS NORMAL: BCR 1,RTREG UPON COMPLETION * 00440000 * BCR 8,RTREG WHEN DIVISOR ZERO * 00460000 *EXITS ERROR : N/A * 00480000 *TABLES/WORKAREA: * 00500000 * GLOBE - PHONY GLOBOL TABLE * 00520000 * DEND - DIVIDEND * 00540000 * DOR - DIVISOR * 00560000 * NUMBER- INTERMEDIATE RESULT * 00580000 * QUOT - RESULT QUOTIENT * 00600000 * FLDX - SIGN BYTE * 00620000 * * 00640000 *ATTRIBUTES: * 00660000 * SERIALLY REUSABLE * 00680000 * * 00700000 *NOTES: * 00720000 * THIS ROUTINE DIVIDES A 16 BYTE 30 CHARACTER DIVIDEND BY A 16 BYTE * 00740000 * 30 CHARACTER DIVISOR AND PRODUCES A 16 BYTE 30 CHARACTER QUOTIENT.* 00760000 * THE DIVIDEND IS TO LOAD INTO A 16 BYTE FIELD DEND, THE DIVISOR IS * 00780000 * TO LOAD INTO A 16 BYTE FIELD DOR ,AND THE QUOTIENT APPEARS IN A 16* 00800000 * BYTE FIELD QUOT. NO REGISTERS ARE USED. MAXIMUM EXECUTION TIME ON * 00820000 * MODEL 30 IN CASE (10**30-1)/1 IS 0.184 SECONDS. * 00840000 *********************************************************************** 00860000 * 00880000 * 00900000 IHD00200 START 0 DIV 00920000 ENTRY IHD00201 DI60C 00940000 ******************************** 00960000 *** PACKED DIVIDE SUBROUTINE *** 00980000 ******************************** 01000000 * THIS ROUTINE DIVIDES A 16 BYTE 30 CHAR.DIVIDEND BY A 16 BYTE 30 CHAR. 01020000 * DIVISOR AND PRODUCES A 16 BYTE 30 CHAR. QUOTIENT. THE DIVIDEND IS TO 01040000 * LOAD INTO 16 BYTE FIELD DEND, DIVISOR IS TO LOAD INTO 16 BYTE FIELD 01060000 * DOR,QOUTIENT APPEARS IN 16 BYTE FIEL QUOT. NO REG. ARE USED 01080000 * MAX EXEQ. TIME ON MODEL 30 IN CASE (10**30-1)/1 IS 0.184 SEC. 01100000 * ROUTINE IS TO CALL BY BAL RTREG,DI60C 01120000 *********************************************************************** 01140000 RTREG EQU 14 RETURN REGISTER 01160000 USING *,15,3 SPECIFY BASE REGISTER 01180000 IHD00201 ZAP QUOT(16),DEND(16) 01200000 ZAP DOR(16),DOR(16) 01220000 BCR 8,RTREG EXIT FOR DIVISOR ZERO 01240000 XC NUMBER(15),NUMBER 01260000 MVI NUMBER+15,X'1C' 01280000 MVI DOR+16,X'0C' 01300000 MVC FLDX(1),QUOT+15 01320000 SP QUOT(16),QUOT(16) 01340000 XC FLDX(1),DOR+15 01360000 NI FLDX,X'0F' 01380000 NI DEND+15,X'FC' 01400000 HEAFC NI DOR+15,X'F0' 01420000 MVN NUMBER+15(2),DOR+15 01440000 MVO NUMBER+1(16),NUMBER(16) 01460000 MVO DOR+1(16),DOR(16) 01480000 MVC NUMBER(33),NUMBER+1 01500000 CP DEND(16),DOR(16) 01520000 BC 10,HEAFC 01540000 OC NUMBER+15(1),FLDX 01560000 LOOP TM NUMBER+15,X'10' 01580000 BCR 1,RTREG 01600000 MVO DOR(16),DOR(15) 01620000 MVO NUMBER(16),NUMBER(15) 01640000 LOOP1 CP DEND(16),DOR(16) 01660000 BC 4,LOOP 01680000 AP QUOT(16),NUMBER(16) 01700000 SP DEND(16),DOR(16) 01720000 BC 15,LOOP1 01740000 GLOBE EQU IHD00201+4096 PHONY GLOBAL TABLE 01760000 DEND EQU GLOBE+96 DIVIDEND 01780000 NUMBER EQU DEND+16 INTERMEDIATE RESULT 01800000 DOR EQU DEND+33 DIVISOR 01820000 QUOT EQU DEND+50 QUOTIENT 01840000 FLDX EQU DEND+66 SIGN BYTE 01860000 END 01880000 ./ ADD SSI=01014040,NAME=IHD00300,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00300 * 00060000 TITLE 'IHD00300 - PACKED MULTIPLY SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: MULTIPLIES AN 8 BYTE 15 CHARACTER MULTIPLICAND * 00120000 * BY AN 8 BYTE 15 CHARACTER MULTIPLIER TO PRODUCE A 16 BYTE 31 * 00140000 * CHARACTER PRODUCT. * 00160000 * * 00180000 *ENTRY POINT: * 00200000 * IHD00301 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00220000 * L 15,ADMLP * 00240000 * BALR RTREG,15 * 00260000 * ADMLP DC A(IHD00301) * 00280000 * RTREG EQU 14 * 00300000 * * 00320000 *INPUT: WORKA CONTAINS NUMBERS TO BE MULTIPLIED. * 00340000 * * 00360000 *OUTPUT: WORKA HOLDS PACKED PRODUCT * 00380000 * * 00400000 *EXTERNAL ROUTINES: N/A * 00420000 *EXITS NORMAL: BCR 15,RTREG * 00440000 *EXITS ERROR: N/A * 00460000 *TABLES/WORKAREA: * 00480000 * GLOBE - PHONY GLOBAL TABLE * 00500000 * WORKA - INPUT,WORKAREA AND FINAL RESULT * 00520000 * FIELDX- SIGN AREA * 00540000 * * 00560000 *ATTRIBUTES: * 00580000 * SERIALLY REUSABLE * 00600000 *********************************************************************** 00620000 * 00640000 * 00660000 IHD00300 START 0 MLP 00680000 ENTRY IHD00301 MLP60C 00700000 ********************************** 00720000 *** PACKED MULTIPLY SUBROUTINE *** 00740000 ********************************** 00760000 RTREG EQU 14 RETURN REGISTER 00780000 USING *,15,3 SPECIFY BASE REGISTER 00800000 IHD00301 MVN FIELDX(1),WORKA+31 SAVE MCAND SIGN 00820000 XC FIELDX(1),WORKA+15 EXCLUSIVE OR MILIER SIGN 00840000 NI FIELDX,X'0F' LIKE SIGNS 0000, UNLIKE 0001 00860000 ZAP WORKA+25(8),WORKA+24(8) CREATE MACAND-RIGHT 00880000 MVI WORKA+24,X'0C' PLUS SIGN FOR MCAND-LEFT 00900000 MVO WORKA+17(8),WORKA+16(8) CREATE MCAND-LEFT 00920000 ZAP WORKA+9(8),WORKA+8(8) CREATE MLIER-RIGHT 00940000 MVI WORKA+8,X'0C' PLUS SIGN FOR MLIER-LEFT 00960000 MVO WORKA+1(8),WORKA(8) CREATE MLIER-LEFT 00980000 NI WORKA+16,X'FC' FORCE MLIER PLUS 01000000 NI WORKA+32,X'FC' FORCE MCAND PLUS 01020000 ZAP WORKA+49(16),WORKA+25(8) MOVE MCAND-RIGHT 01040000 MP WORKA+49(16),WORKA+9(8) PROD1 IS MLIER-R TIMES MCAND-R 01060000 MVI WORKA+40,X'0C' PLUS SIGN FOR PROD1-L 01080000 MVO WORKA+33(8),WORKA+49(8) SAVE PROD1-L 01100000 ZAP WORKA+41(16),WORKA+25(8) MOVE MCAND-RIGHT 01120000 MP WORKA+41(16),WORKA+1(8) PROD2 IS MLIER-L TIMES MCAND-R 01140000 AP WORKA+41(16),WORKA+33(8) ADD PROD1-L TO PROD2 01160000 ZAP WORKA+25(16),WORKA+17(08) MOVE MCAND-LEFT 01180000 MP WORKA+25(16),WORKA+09(08) PROD3 IS MLIER-R TIMES MCAND-L 01200000 AP WORKA+25(16),WORKA+41(16) ADD PROD2 TO PROD3 01220000 MVO WORKA+48(09),WORKA+33(08) MOVE PROD3-R TO FINAL POSITION 01240000 MVO WORKA+32(09),WORKA+25(08) PUT SIGN ON PROD3-L 01260000 ZAP WORKA+1(16),WORKA+1(8) MOVE MLIER-LEFT 01280000 MP WORKA+01(16),WORKA+17(08) PROD4 IS MLIER-L TIMES MCAND-L 01300000 AP WORKA+1(16),WORKA+32(9) ADD PROD3-L TO PROD4 01320000 MVO WORKA+2(16),WORKA+1(16) SHIFT PROD4 HALF BYTE RIGHT 01340000 MVC WORKA+56(08),WORKA+57 MOVE PROD1-R TO FINAL POSITION 01360000 MVO WORKA+33(16),WORKA+02(15) MOVE PROD4 TO FINAL POSITIONS 01380000 OC WORKA+63(1),FIELDX TACK ON CORRECT ALGEBRAIC SIGN 01400000 BCR 15,RTREG EXIT 01420000 GLOBE EQU IHD00301+4096 PHONY GLOBAL TABLE 01440000 WORKA EQU GLOBE+96 WORK AREA 01460000 FIELDX EQU WORKA+66 SIGN AREA 01480000 END 01500000 ./ ADD SSI=04011242,NAME=IHD00400,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00400 * 00060000 TITLE 'IHD00400 - COBOL OBJECT TIME ERROR MESSAGES SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: PRINT DIAGNOSTIC MESSAGES FOR ERRORS ENCOUNTERED* 00120000 * AT OBJECT TIME. * 00140000 * * 00160000 *ENTRY POINTS: * 00180000 * IHD00401 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00200000 * L 15,ADERR * 00220000 * BALR 1,15 * 00240000 * ADERR DC A(IHD00401) * 00260000 * * 00280000 *INPUT: GENERAL REGISTER 1 POINTS TO MESSAGE DISPLACEMENT BUCKET * 00300000 *OUTPUT: WRITTEN MESSAGE * 00320000 *EXTERNAL ROUTINES: N/A * 00340000 * * 00360000 *EXITS NORMAL: LEAVE - RESTORE ALL REGISTERS AND BR 14. * 00380000 *EXITS ERROR: N/A * 00400000 * * 00420000 *TABLES/WORKAREAS: * 00440000 * MESS1 THRU MESS7 ARE MESSAGES TO BE PRINTED AT OBJECT TIME * 00460000 * ADDRSS - ADDRESSES OF MESSAGES TABLE * 00480000 * SAVEAR - THIS SUBROUTINES REGISTER STORAGE AREA * 00500000 * * 00520000 *ATTRIBUTES: * 00540000 * SERIALLY REUSABLE * 00560000 *********************************************************************** 00580000 IHD00400 START 0 00600000 ENTRY IHD00401 00620000 GR1 EQU 1 GENERAL REGISTER 1 00640000 GR2 EQU 2 GENERAL REGISTER 2 00660000 GR5 EQU 5 GENERAL REGISTER 5 00680000 GR12 EQU 12 GENERAL REGISTER 12 00700000 GR13 EQU 13 GENERAL REGISTER 13 00720000 GR14 EQU 14 GENERAL REGISTER 14 00740000 GR15 EQU 15 GENERAL REGISTER 15 00760000 IHD00401 STM GR14,GR12,12(GR13) STORE ALL REGS IN USER SAVE 00780000 BALR GR5,0 00800000 USING *,GR5 INFORM ASSEMBLER OF BASE REGIS 00820000 LA GR14,SAVEAR POINT TO THIS SAVE 00840000 ST GR13,4(0,GR14) SAVE USER SAVE POINTER 00860000 LR GR13,GR14 POINT TO THIS SAVE 00880000 LA GR2,ADDRSS POINT TO INCREMENT TABLE 00900000 MVC PARAM+1(1),1(GR1) PICKUP ERROR NUMBER 00920000 AH GR2,PARAM ADD IT AS AN INCREMENT 00940000 LA GR1,MESS1 POINT TO MESSAGES START 00960000 AH GR1,0(0,GR2) POINT TO PARTICULAR MESSAGE 00980000 SVC 35 TYPE ERROR MESSAGE ON CONSOLE 01000000 L GR13,4(0,GR13) POINT TO CALLERS SAVE 01020000 LM GR14,GR12,12(GR13) RESTORE REG 12-14 01040000 BR GR14 RETURN 01060000 DC 0H'0' HALFWORD BOUNDARY PLEASE 01080000 ADDRSS DC AL2(MESS1-MESS1) MESSAGE 1 INCREMENT 01100000 DC AL2(MESS2-MESS1) MESSAGE 2 INCREMENT 01120000 DC AL2(MESS3-MESS1) MESSAGE 3 INCREMENT 01140000 DC AL2(MESS4-MESS1) MESSAGE 4 INCREMENT 01160000 DC AL2(MESS5-MESS1) MESSAGE 5 INCREMENT 01180000 DC AL2(MESS6-MESS1) MESSAGE 6 INCREMENT 01200000 DC AL2(MESS7-MESS1) MESSAGE 7 INCREMENT 01220000 DC 0F'0' FULL WORD BOUNDARY 01240000 MESS1 DC X'00500000' MESSAGE 1 CARD 0 01260000 DC C'IHD999I MINUS BASE M' MESSAGE 1 CARD 1 01280000 DC C'ADE POSITIVE AND FLO' MESSAGE 1 CARD 2 01300000 DC C'ATING POINT EXPONENT' MESSAGE 1 CARD 3 01320000 DC C'IATION CONTINUED' MESSAGE 1 CARD 4 01340000 DC 0F'0' FULL WORD BOUNDARY 01360000 MESS2 DC X'00500000' MESSAGE 2 CARD 0 01380000 DC C'IHD998I ZERO BASE WI' MESSAGE 2 CARD 1 01400000 DC C'TH A POSITIVE EXPONE' MESSAGE 2 CARD 2 01420000 DC C'NT - FLOATING POINT ' MESSAGE 2 CARD 3 01440000 DC C'ANSWER MADE ZERO' MESSAGE 2 CARD 4 01460000 DC 0F'0' FULL WORD BOUNDARY 01480000 MESS3 DC X'00500000' MESSAGE 3 CARD 0 01500000 DC C'IHD997I ZERO BASE TO' MESSAGE 3 CARD 1 01520000 DC C' MINUS EXPONENT-FLOA' MESSAGE 3 CARD 2 01540000 DC C'TING POINT ANSWER IS' MESSAGE 3 CARD 3 01560000 DC C' MAX F.P. NUMBER' MESSAGE 3 CARD 4 01580000 DC 0F'0' FULL WORD BOUNDARY 01600000 MESS4 DC X'00500000' MESSAGE 4 CARD 0 01620000 DC C'IHD996I RESULT TOO B' MESSAGE 4 CARD 1 01640000 DC C'IG-FLOATING POINT EX' MESSAGE 4 CARD 2 01660000 DC C'PONENTIATION ANSWER ' MESSAGE 4 CARD 3 01680000 DC C'IS MAX FP NUMBER' MESSAGE 4 CARD 4 01700000 DC 0F'0' FULL WORD BOUNDARY 01720000 MESS5 DC 0C'0' 01740000 MESS6 DC 0C'0' 01760000 MESS7 DC X'00500000' MESSAGE 7 CARD 0 01780000 DC C'IHD993I ZERO BASE-MI' MESSAGE 7 CARD 1 01800000 DC C'NUS EXPONENT-PACKED ' MESSAGE 7 CARD 2 01820000 DC C'EXPONENTIATION RESUL' MESSAGE 7 CARD 3 01840000 DC C'T MADE ALL NINES' MESSAGE 7 CARD 4 01860000 DC 0F'0' FULL WORD BOUNDARY 01880000 SAVEAR DC 18F'0' THIS PROGRAMS SAVE AREA 01900000 PARAM DC H'0' ERROR NUMBER-INCREMENT 01920000 END 01940000 ./ ADD SSI=01014041,NAME=IHD00500,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00500 * 00060000 TITLE 'IHD00500 - PACKED EXPONENTIATION SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: DEVELOPES EXPONENT IN PACKED FORMAT * 00120000 * * 00140000 *ENTRY POINTS: * 00160000 * IHD00501 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00180000 * L 15,WITH ADDRES* 00200000 * OF IHD00501 * 00220000 * BALR 14,15 * 00240000 * * 00260000 *INPUT: REG 14 POINTS TO PARAMETERS OF 10 BYTES * 00280000 *OUTPUT: RESULT WILL BE IN GLOBAL TABLE * 00300000 * * 00320000 *EXTERNAL ROUTINES: * 00340000 * IHD00401 - ADERR - ERROR MESSAGE SUBROUTINE * 00360000 * IHD00301 - ADMLP - PACKED MULTIPLY SUBROUTINE * 00380000 * IHD00201 - ADDIV - PACKED DIVIDE SUBROUTINE * 00400000 * * 00420000 *EXITS NORMAL: X0110 - RESTORE REGISTERS AND BR 14 * 00440000 *EXITS ERROR: X0120 - RESULT ZERO - CALL ERROR MESSAGE SUBROUTINE * 00460000 *TABLES/WORKAREAS: N/A * 00480000 *ATTRIBUTES: * 00500000 * SERIALLY REUSABLE * 00520000 *********************************************************************** 00540000 * 00560000 * 00580000 IHD00500 START 0 XPWR 00600000 ENTRY IHD00501 XPOWER 00620000 EXTRN IHD00401 COBERR 00640000 EXTRN IHD00301 MLP60C 00660000 EXTRN IHD00201 DI63C 00680000 **************************************** 00700000 *** PACKED EXPONENTIATION SUBROUTINE *** 00720000 **************************************** 00740000 XRX EQU 1 EXPONENT VALUE REGISTER 00760000 XRY EQU 2 TIMES-MULTIPLIED COUNT REGISTER 00780000 XRG EQU 3 GLOBAL TABLE POINTER REGISTER 00800000 XRP EQU 4 PARAMETER POINTER 00820000 XRF EQU 5 BASE REGISTER 00840000 XRT EQU 12 GENERAL REGISTER 12 00860000 XRS EQU 13 SAVE AREA POINTER 00880000 XRL EQU 14 LINK REGISTER 00900000 XRZ EQU 15 SUBROUTINE POINTER 00920000 XW EQU 96 BEGINNING OF MULT-DIV AREA 00940000 XW0 EQU 0 MULTIPLIER SAVE AREA 00960000 XW1 EQU XW MULTIPLIER 00980000 XW2 EQU XW+16 MULTIPLICAND 01000000 XW2S EQU XW+31 MULTIPLICAND+15 SIGN 01020000 XW2T EQU XW+25 MULTIPLICAND+9 01040000 XW3 EQU XW+33 PRODUCT 01060000 XW3S EQU XW+63 PRODUCT+30 SIGN 01080000 XW3T EQU XW+48 PRODUCT+15 01100000 XW4 EQU XW+33 DIVISOR 01120000 XW5 EQU XW DIVIDEND 01140000 XW5S EQU XW+15 DIVIDEND+15 SIGN 01160000 XW6 EQU XW+50 QUOTIENT 01180000 XW6S EQU XW+65 QUOTIENT+15 SIGN 01200000 IHD00501 STM XRL,XRT,12(XRS) REGS 14-12 TO CALLERS SAVE 01220000 BALR XRF,0 LOAD BASE REGISTER 01240000 USING *,XRF SPECIFY BASE REGISTER 01260000 LR XRP,XRL LOAD PARAMETER POINTER REGISTER 01280000 LA XRL,XSAVE POINT TO THIS PROGRAMS SAVE 01300000 ST XRS,4(0,XRL) THIS SAVE POINTER TO CALLERSAVE 01320000 LR XRS,XRL POINT 13 TO THIS SAVE AREA 01340000 LPR XRY,XRX GET EXPONENT POSITIVE FOR SURE 01360000 BC 9,X0010 EXPONENT 0 - GIVE ANSWER 1 01380000 MVC XW2(16,XRG),XW0(XRG) MULTIPLIER TO MULTIPLICAND 01400000 BCT XRY,X0020 IF EXP NOT 1 GO MULTIPLY 01420000 B X0080 EXP IS 1-GIVE ANSWER IS BASE 01440000 X0020 MVC XW1(16,XRG),XW0(XRG) LOAD MULTIPLIER 01460000 L XRZ,ADMLP POINT TO MULTIPLY SUBROUTINE 01480000 BALR XRL,XRZ GO MULTIPLY PACKED 01500000 XC XW2(16,XRG),XW2(XRG) CLEAR MULTIPLICAND 01520000 TM 0(XRP),X'A0' IS SCALE BELOW ZERO AND ODD 01540000 BO X0030 GO DO INSTRUCTIONS 4 + 5 01560000 TM 0(XRP),X'80' IS SCALE BELOW ZERO 01580000 BO X0040 GO DO INSTRUCTIONS 2 + 3 01600000 TM 0(XRP),X'20' IS SCALE ODD 01620000 BO X0050 GO DO INSTRUCTION1 01640000 MVC XIN0+5(1),1(XRP) PAR1 TO INST0 01660000 XIN0 MVC XW2(16,XRG),XW3(XRG) PRODUCT TO MULTIPLICAND 01680000 X0070 NI XW2(XRG),X'0F' ZERO 31ST DIGIT 01700000 MVN XW2S(1,XRG),XW3S(XRG) PROD SIGN TO MCAND SIGN 01720000 BCT XRY,X0020 GO MULTIPLY SOME MORE 01740000 X0080 LTR XRX,XRX TEST SIGNED EXPONENT 01760000 BC 11,X0110 EXP NOT NEG-DONT DIVIDE INTO 1 01780000 MVC XW4(16,XRG),XW2(XRG) MCAND TO DIVISOR 01800000 XC XW5(16,XRG),XW5(XRG) ZERO DIVIDEND 01820000 MVI XW5S(XRG),X'0C' MAKE 1 PLUS 01840000 CP XW4(16,XRG),XW5(16,XRG) IS RESULT ZERO 01860000 BE X0120 GO GIVE RESULT ALL NINES 01880000 MVI XW5(XRG),X'01' CONSTANT 1 TO DIVIDEND 01900000 L XRZ,ADDIV POINT TO DIVIDE SUBROUTINE 01920000 BALR XRL,XRZ GO DIVIDE PACKED 01940000 XC XW2(16,XRG),XW2(XRG) CLEAR MULTIPLICAND 01960000 TM 0(XRP),X'80' IS SCALE BELOW ZERO 01980000 BO X0090 ANSWER IS ZERO 02000000 MVC XIN6+3(1),6(XRP) PAR6 TO INST6 02020000 MVC XIN7+3(1),7(XRP) PAR7 TO INST7 02040000 XIN6 PACK XW2(1,XRG),XW6S(1,XRG) LO QUOTIENT DIGIT TO MULTIPLCND 02060000 XIN7 MVO XW2(15,XRG),XW6(15,XRG) REST OF QUOT TO MULTIPLICAND 02080000 X0090 NI XW2(XRG),X'0F' ZERO 31ST DIGIT 02100000 MVN XW2S(1,XRG),XW6S(XRG) QUOT SIGN TO MCAND 02120000 X0110 L XRS,4(0,XRS) POINT TO CALLERS SAVE 02140000 LM XRL,XRT,12(XRS) RESTORE REGS 14-12 02160000 LA XRL,10(0,XRL) UP LINK REG AROUND PARAMETERS 02180000 BR XRL 02200000 X0010 XC XW2(16,XRG),XW2(XRG) CLEAR MULTIPLICAND 02220000 MVC XIN8+3(1),8(XRP) PAR8 TO INST8 02240000 XIN8 MVC XW2(1,XRG),9(XRP) MOVE 1 TO MULTIPLICAND 02260000 OI XW2S(XRG),X'0C' MAKE SIGN PLUS 02280000 B X0110 GO EXIT 02300000 X0030 MVC XIN4+3(1),2(XRP) PAR2 TO INST4 02320000 MVC XIN5+1(1),5(XRP) PAR5 TO INST5 02340000 XIN4 PACK XW2(1,XRG),XW3S(1,XRG) LO PRODUCT DIGIT TO MULTIPLCND 02360000 XIN5 MVO XW2(0,XRG),XW3T(15,XRG) REST OF PRODUCT TO MULTIPLICAND 02380000 B X0070 GO GET SIGN 02400000 X0040 MVC XIN2+3(1),2(XRP) PAR2 TO INST2 02420000 MVC XIN3+1(1),3(XRP) PAR3 TO INST3 02440000 MVC XIN3+5(1),4(XRP) PAR4 TO INST3 02460000 XIN2 MVZ XW2(1,XRG),XW3S(XRG) LO PRODUCT DIGIT TO MCAND 02480000 XIN3 MVC XW2(0,XRG),XW3(XRG) REST OF PRODUCT TO MCAND 02500000 B X0070 GO GET SIGN 02520000 X0050 MVC XIN1+5(1),1(XRP) PAR1 TO INST1 02540000 XIN1 MVO XW2(16,XRG),XW3(16,XRG) PRODUCT TO MULTIPLICAND 02560000 B X0070 GO GET SIGN 02580000 X0120 MVI XW2(XRG),X'99' NINES TO ANSWER 02600000 MVC XW2+1(15,XRG),XW2(XRG) FLOOD NINES IN ANSWER 02620000 MVN XW2S(1,XRG),XW4+15(XRG) PRODUCT SIGN TO ANSWER 02640000 NI XW2(XRG),X'0F' ZERO HI DIGIT 02660000 LA XRL,XRET1 LOAD RETURN REGISTER 02680000 L XRZ,ADERR POINT TO ERROR SUBROUTINE 02700000 BALR XRX,XRZ TYPE ERROR MESSAGE 02720000 DC X'000C' ERROR NUMBER 12 02740000 XRET1 B X0110 GO EXIT 02760000 XSAVE DC 18F'0' THIS PROGRAMS SAVE AREA 02780000 ADERR DC A(IHD00401) ERROR SUBROUTINE 02800000 ADMLP DC A(IHD00301) MULTIPLY PACKED SUBROUTINE 02820000 ADDIV DC A(IHD00201) DIVIDE PACKED SUBROUTINE 02840000 END 02860000 ./ ADD SSI=01014042,NAME=IHD00600,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00600 * 00060000 TITLE 'IHD00600 - FLOATING POINT LOGARITHM SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: COMPUTES FLOATING POINT NATURAL LOGARITHM * 00120000 * * 00140000 *ENTRY POINTS: * 00160000 * IHD00602 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00180000 * L 15,ADDLOG * 00200000 * BALR 14,15 * 00220000 * ADDLOG DC A(IHD00601) * 00240000 * * 00260000 * * 00280000 * * 00300000 *INPUT: GEN. REG. 1 HAS ADDRESS OF ARGUMENT TABLE * 00320000 *OUTPUT: FL-POINT REG. 0 CONTAINS RESULT * 00340000 *EXTERNAL ROUTINES: N/A * 00360000 *EXITS NORMAL: RESTORE REGISTERS AND BCR 15,14 * 00380000 *EXITS ERROR: N/A * 00400000 *TABLES/WORKAREAS: C1 THRU C7 ARE LOG TABLES * 00420000 *ATTRIBUTES: * 00440000 * SERIALLY REUSABLE * 00460000 * * 00480000 *NOTES: * 00500000 * LOGARITHM FUNCTION (LONG) * 00520000 * WRITE X=(16**P)*(2**-Q)*M Q IS BETWEEN 0 AND 3 AND M BETWEEN * 00540000 * 1/2 AND 1. DEFINE A=1,B=0 IF M IS GREATER THAN SQ RT 2/2,OTHERWISE* 00560000 * A=1/2,B=1. * 00580000 * WRITE Z=(M-A)/(M+A),THEN * 00600000 * LOG(X)=(4P-Q-B)*LOG(2)+LOG((1+Z)/(1-Z)) * 00620000 *********************************************************************** 00640000 * 00660000 * 00680000 IHD00600 START 0 LLOG 00700000 ENTRY IHD00601 DLOG 00720000 ENTRY IHD00602 DLOG10 00740000 ******************************************* 00760000 *** FLOATING POINT LOGARITHM SUBROUTINE *** 00780000 ******************************************* 00800000 * LOGARITMIC FUNCTION (LONG) 00820000 * WRITE X=(16**P)*(2**-Q)*M,Q BETWEEN 0 AND 3, AND 00840000 * M BETWEEN 1/2 AND 1. DEFINE A=1, B=0 IF M IS GREATER 00860000 * THAN SQRT2/2, OTHERWISE A=1/2, B=1. 00880000 * WRITE Z=(M-A)/(M+A), THEN 00900000 * LOG(X)=(4P-Q-B)*LOG(2)+LOG((1+Z)/(1-Z)) 00920000 GR0 EQU 0 00940000 GR1 EQU 1 00960000 GR2 EQU 2 00980000 GR3 EQU 3 01000000 GRA EQU 1 ARGUMENT POINTER 01020000 GRS EQU 13 SAVE AREA POINTER 01040000 GRR EQU 14 RETURN REGISTER 01060000 GRL EQU 15 LINK REGISTER 01080000 FR0 EQU 0 ANSWER REGISTER 01100000 FR2 EQU 2 SCRATCH REGISTER 01120000 DC CL7'DLOG10' 01140000 DC X'06' 01160000 USING *,GRL 01180000 IHD00602 STM GRR,GR3,12(GRS) COMMON LOG ENTRY 01200000 MVI FLAG,1 SAVE REGISTERS, SET FLAG 01220000 LA GRL,IHD00601-IHD00602(GRL) ADJUST BASE REGISTER 01240000 USING IHD00601,GRL AND JOIN MAIN CIRCUIT 01260000 BC 15,MERGE 01280000 DC CL5'DLOG' 01300000 DC X'04' 01320000 IHD00601 STM GRR,GR3,12(GRS) NATURAL LOG ENTRY 01340000 MVI FLAG,0 SAVE REGISTERS, RESET FLAG 01360000 MERGE L GR1,0(GRA) OBTAIN ARGUMENT IN GR0,GR1 01380000 LM GR0,GR1,0(GR1) 01400000 LTR GR2,GR0 01420000 SRDL GR2,24 CHAR IN LOW GR2,1ST DIGIT IN HIGH GR3 01440000 SLL GR2,2 01460000 STH GR2,IPART+2 FLOAT 4*CHAR AND SAVE IT 01480000 SR GR2,GR2 01500000 SLDL GR2,4 1ST DIGIT IN GR2 01520000 IC GR2,TABLE(GR2) NUMBER OF LEADING ZEROS (=Q) IN GR2 01540000 SLDL GR0,0(GR2) 01560000 STM GR0,GR1,BUFF 01580000 MVI BUFF,X'40' M=FRACTION*2**Q IN CELL BUFF 01600000 LA GR1,8 01620000 LD FR0,BUFF PICK UP M IN FR0 01640000 CE FR0,LIMIT IF M GREATER THAN SQRT2/2,GR1=8. 01660000 BC 2,READY 01680000 SR GR1,GR1 IF M LESS THAN SQRT2/2,GR1=0 01700000 LA GR2,1(GR2) AND CRANK GR2 BY 1. Q+B IN GR2. 01720000 READY LDR FR2,FR0 COMPUTE Z=(M-A)(M+A),A=1 OR 1/2 01740000 SD FR0,HALF SUBTRACT A IN 2 STEPS TO PROTECT 01760000 SD FR0,ZERO(GR1) THE LAST DIGIT. 01780000 AD FR2,HALF(GR1) M+A HAS ONLY 53 BITS. NOT SERIOUS 01800000 DDR FR0,FR2 01820000 STD FR0,BUFF 01840000 MDR FR0,FR0 COMPUTE LOG((1+Z)/(1-Z)) 01860000 LDR FR2,FR0 BY CHEBYSHEV INTERPOLATION 01880000 MD FR2,C7 POLYNOMIAL (IN ZSQ) OF DEGREE 7 01900000 AD FR2,C6 01920000 MDR FR2,FR0 01940000 AD FR2,C5 01960000 MDR FR2,FR0 01980000 AD FR2,C4 02000000 MDR FR2,FR0 02020000 AD FR2,C3 02040000 MDR FR2,FR0 02060000 AD FR2,C2 02080000 MDR FR2,FR0 02100000 AD FR2,C1 02120000 MDR FR2,FR0 F=ZSQ*(C1+ZSQ*(C2+...ZSQ*C7..) 02140000 LD FR0,BUFF LOG((1+Z)/(1-Z))=Z*(2+F) 02160000 MDR FR2,FR0 =Z+Z+Z*F 02180000 ADR FR2,FR0 TO GAIN ACCURACY 02200000 ADR FR2,FR0 02220000 LD FR0,IPART 1*CHARACTERISTIC IN FR0 02240000 LA GR2,256(GR2) ADD 4*(BASE CHARAC=64) TO Q+B, 02260000 STH GR2,IPART+2 FLOAT THIS AND SUBTRACT FROM FR0 02280000 SE FR0,IPART TO OBTAIN 4P-Q-B 02300000 MD FR0,LOGE2 MULTIPLY LOG(2) BASE E 02320000 ADR FR0,FR2 AND ADD TO LOG ((1+Z)/(1-Z)) 02340000 TM FLAG,X'1' 02360000 BC 8,*+8 IF DLOG10 ENTRY, 02380000 MD FR0,LOGTE MULTIPLY BY LOG(E) BASE 10 02400000 LM GR2,GR3,28(GRS) 02420000 MVI 12(GRS),X'FF' 02440000 BCR 15,GRR RETURN 02460000 FLAG DC C'0' 02480000 BUFF DS D 02500000 IPART DC X'4600000000000000' 02520000 TABLE DC X'0303020201010101' THESE 4 02540000 ZERO DC X'0000000000000000' CONSTANTS 02560000 HALF DC X'4080000000000000' MUST BE 02580000 DC X'4110000000000000' TOGETHER 02600000 C7 DC X'4025E9B17CA9B973' .1480971268990510 02620000 C6 DC X'40273337E26DBA7F' .1531252792171731 02640000 C5 DC X'402E8CD32A425C06' .1818363168880382 02660000 C4 DC X'4038E38A00083F68' .2222219705656678 02680000 C3 DC X'4049249251450212' .2857142876064318 02700000 C2 DC X'40666666665EBAA3' .3999999999930233 02720000 C1 DC X'40AAAAAAAAAAAD6C' .6666666666666764 02740000 LOGE2 DC X'40B17217F7D1CF7B' LOG2 (BE)+1 IN LAST DIGIT 02760000 LOGTE DC X'406F2DEC549B943A' LOE (B10)+1 IN LAST DIGIT 02780000 LIMIT DC X'40B504F3' 1/SQRT2 02800000 END 02820000 ./ ADD SSI=01014049,NAME=IHD00700,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00700 * 00060000 TITLE 'IHD00700 - FLOATING POINT EXPONENTIAL SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: RAISES FL-POINT NUMBERS TO POWERS OF THEIR * 00120000 * EXPONENTS USING NATURAL LOG RTNE IHD00600 AND EXPONENTIAL * 00140000 * RTNE IHD00100. * 00160000 * * 00180000 *ENTRY POINTS: * 00200000 * IHD00701 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00220000 * L 15,ADDRESS OF * 00240000 * IHD00701 * 00260000 * BALR 14,15 * 00280000 *INPUT: REG. 1 POINTS TO ARGUMENT * 00300000 *OUTPUT: FL-POINT REG. 0 CONTAINS RESULT * 00320000 *EXTERNAL ROUTINES: * 00340000 * IHD00401 - ERROR MESSAGE SUBROUTINE * 00360000 * IHD00601 - NATURAL LOGARITHM SUBROUTINE * 00380000 * IHD00101 - EXPONENTIAL SUBROUTINE * 00400000 * * 00420000 *EXITS NORMAL: RESTORE REGISTERS AND BR 14 * 00440000 *EXITS ERROR: POINT TO ADERR(IHD00401) BY L 15,ADERR AND BALR 14,15* 00460000 *TABLES/WORKAREAS: WORK1 THRU WORK3 ARE SECTIONS DEFINED IN GLOBAL * 00480000 * TABLE. * 00500000 *ATTRIBUTES: * 00520000 * SERIALLY REUSABLE * 00540000 *********************************************************************** 00560000 * 00580000 * 00600000 IHD00700 START 0 FPWR 00620000 ENTRY IHD00701 FPOWER 00640000 EXTRN IHD00601 DLOG 00660000 EXTRN IHD00101 DEXP 00680000 EXTRN IHD00401 COBERR 00700000 ************************************************ 00720000 *** FLOATING POINT EXPONENTIATION SUBROUTINE *** 00740000 ************************************************ 00760000 GR1 EQU 1 GENERAL REGISTER 1 00780000 GR3 EQU 3 GENERAL REGISTER 3 00800000 GR5 EQU 5 GENERAL REGISTER 5 00820000 GR12 EQU 12 GENERAL REGISTER 12 00840000 GR13 EQU 13 GENERAL REGISTER 13 00860000 GR14 EQU 14 GENERAL REGISTER 14 00880000 GR15 EQU 15 GENERAL REGISTER 15 00900000 FR0 EQU 0 FLOATING POINT REGISTER 0 00920000 WORK1 EQU 96 WORK AREA 1 IN GLOBAL TABLE 00940000 WORK2 EQU 104 WORK AREA 2 IN GLOBAL TABLE 00960000 WORK3 EQU 112 WORK AREA 3 IN GLOBAL TABLE 00980000 IHD00701 STM GR14,GR12,12(GR13) REGS 14-12 TO CALLERS SAVE AREA 01000000 BALR GR5,0 LOAD BASE REGISTER 01020000 USING *,GR5 SPECIFY BASE REGISTER 01040000 LA GR14,FPSAVE POINT TO THIS PROGRAMS SAVE 01060000 ST GR13,4(0,GR14) SAVE POINTER TO CALLERS SAVE 01080000 LR GR13,GR14 POINT 13 TO THIS SAVE AREA 01100000 LD FR0,WORK1(0,GR3) GET BASE 01120000 LTDR FR0,FR0 TEST BASE 01140000 BM FP001 GO MAKE BASE POSITIVE 01160000 BZ FP002 GO SEE IF EXOONENT PLUS OR MINS 01180000 FP005 LA GR1,WORK1(0,GR3) ADDRESS OF BASE TO GR1 01200000 ST GR1,WORK3(0,GR3) STORE ADDRESS OF BASE IN WORK 3 01220000 LA GR1,WORK3(0,GR3) POINT TO ADDRESS OF BASE 01240000 L GR15,ADDLOG POINT TO NATURAL LOG SUBROUTINE 01260000 BALR GR14,GR15 GO TAKE LOG OF BASE 01280000 MD FR0,WORK2(0,GR3) MULTIPLY PRODUCG TIMES EXPONENT 01300000 CE FR0,FPMAX IS PROD BIGGER THAN 174.6731 01320000 BH FP004 GO MAKE ANS MAX FP NUMBER 01340000 STD FR0,WORK1(0,GR3) PRODUCT TO WORK1 01360000 LA GR1,WORK3(0,GR3) POINT TO ADDRESS OF PRODUCT 01380000 L GR15,ADDEXP POINT TO SUBROUTINE 01400000 BALR GR14,GR15 RAISE E TO PRODUCT POWER 01420000 FP006 L GR13,4(0,GR13) GET POINTER TO CALLERS SAVE 01440000 LM GR14,GR12,12(GR13) RESTORE REGISTERS 14-12 01460000 BR 14 RETURN TO CALLER 01480000 FP001 NI WORK1(GR3),X'7F' MAKE BASE POSITIVE 01500000 LA GR14,FPRET1 LOAD RETURN REGISTER 01520000 L GR15,ADERR POINT TO ERROR SUBROUTINE 01540000 BALR GR1,GR15 GO TYPE ERROR MESSAGE 01560000 DC X'0000' ERROR NUMBER 0 01580000 FPRET1 B FP005 GO CONTINUE EXPONENTIATION 01600000 FP002 TM WORK2(GR3),X'80' IS EXPONENT POSITIVE 01620000 BZ FP003 GO MAKE ANSWER ZERO 01640000 LD FR0,FPBIG MAKE ANS LARGEST FP NUMBER 01660000 LA GR14,FPRET2 LOAD RETURN REGISTER 01680000 L GR15,ADERR POINT TO ERROR SUBROUTINE 01700000 BALR GR1,GR15 GO TYPE ERROR MESSAGE 01720000 DC X'0004' ERROR NUMBER 4 01740000 FPRET2 B FP006 GO EXIT 01760000 FP003 LD FR0,FPZERO MAKE ANSWER ZERO 01780000 LA GR14,FPRET3 LOAD RETURN REGISTER 01800000 L GR15,ADERR POINT TO ERROR SUBROUTINE 01820000 BALR GR1,GR15 GO TYPE ERROR MESSAGE 01840000 DC X'0002' ERROR NUMBER 2 01860000 FPRET3 B FP006 GO EXIT 01880000 FP004 LD FR0,FPBIG MAKE ANS LARGEST FP NUMBER 01900000 LA GR14,FPRET4 LOAD RETURN REGISTER 01920000 L GR15,ADERR POINT TO ERROR SUBROUTINE 01940000 BALR GR1,GR15 GO TYPE ERROR MESSAGE 01960000 DC X'0006' ERROR NUMBER 6 01980000 FPRET4 B FP006 GO EXIT 02000000 DS 0D DOUBLE WORD BOUNDARY 02020000 FPZERO DC X'0000000000000000' ZERO 02040000 FPBIG DC X'7FFFFFFFFFFFFFFF' MAXIMUM FLOATING POINT NUMBER 02060000 FPMAX DC X'42AEAC4E' 174.6731 02080000 ADERR DC A(IHD00401) ERROR MESSAGE SUBROUTINE 02100000 ADDLOG DC A(IHD00601) NATURAL LOG SUBROUTINE 02120000 ADDEXP DC A(IHD00101) EXPONENTIAL SUBROUTINE 02140000 FPSAVE DC 18F'0' THIS PROGRAMS SAVE AREA 02160000 END 02180000 ./ ADD SSI=01014044,NAME=IHD00800,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00800 * 00060000 TITLE 'IHD00800 - CONVERT PACKED DECIMAL TO FL-POINT SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: INITIALIZES TO CONVERT PACKED DECIMAL TO BINARY * 00120000 * THEN TO DOUBLE PRECISION FL-POINT NUMBER * 00140000 *ENTRY POINTS: * 00160000 * IHD00802 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00180000 * L 15,ADDRESS OF * 00200000 * IHD00802 * 00220000 * BALR 14,15 * 00240000 *INPUT: WORKB CONTAINS NUMBER TO BE CONVERTED * 00260000 *OUTPUT: FL-POINT REG. 0 AFTER ENTRY TO IHD01502. * 00280000 *EXTERNAL ROUTINES: * 00300000 * IHD01601 - PACKED OR ZONED TO BINARY SUBROUTINE * 00320000 * IHD01502 - BINARY TO DOUBLE PRECISION FL-POINT * 00340000 * * 00360000 *EXITS NORMAL: FOR ZONED OR PACKED TO BINARY A TEMPORARY EXIT IS * 00380000 * MADE TO IHD01601. AFTER CONVERSION A PERMANENT EXIT IS MADE TO * 00400000 * IHD01502 FOR CONVERSION TO FL-POINT, * 00420000 *EXITS ERROR: N/A * 00440000 *TABLES/WORKAREAS: N/A * 00460000 *ATTRIBUTES: * 00480000 * SERIALLY REUSABLE * 00500000 *********************************************************************** 00520000 * 00540000 * 00560000 IHD00800 START 0 PKDFL 00580000 ENTRY IHD00801 PKDFLP 00600000 ENTRY IHD00802 PKDFLL 00620000 EXTRN IHD01502 BINFSC 00640000 EXTRN IHD01601 PKDBIN 00660000 WORKB EQU 56 00680000 USING *,15 00700000 IHD00802 LA 1,6 00720000 LABEL1 CLI WORKB(3),X'00' 00740000 BC 7,LABEL2 00760000 MVC WORKB(15,3),WORKB+1(3) 00780000 BCT 1,LABEL1 00800000 LABEL2 SR 2,1 00820000 SR 2,1 00840000 LABEL3 MVN WORKB+9(1,3),WORKB+15(3) 00860000 BALR 15,0 00880000 USING *,15 00900000 IHD00801 ST 14,SAVE 00920000 L 15,ADCON1 00940000 BALR 14,15 00960000 BALR 15,0 00980000 USING *,15 01000000 L 14,SAVE 01020000 L 15,ADCON2 01040000 BCR 15,15 01060000 ADCON1 DC A(IHD01601) 01080000 ADCON2 DC A(IHD01502) 01100000 SAVE DS F 01120000 END 01140000 ./ ADD SSI=01014045,NAME=IHD00900,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD00900 * 00060000 TITLE 'IHD00900 - CONVERT FL-POINT TO ZONED DECIMAL SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: CONVERT FL-POINT TO ZONED DECIMAL * 00120000 * * 00140000 *ENTRY POINTS: * 00160000 * IHD00901 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00180000 * L 15,ADDRESS OF * 00200000 * IHD00901 * 00220000 * BALR 14,15 * 00240000 *INPUT: REG.14 POINTS TO NUMBER TO BE CONVERTED * 00260000 *OUTPUT: WORKA WILL HOLD OUTPUT * 00280000 *EXTERNAL ROUTINES: * 00300000 * IHD01102 - CONVERT EXTERNAL FL-POINT TO BINARY SUBROUTINE * 00320000 * IHD01802 - CONVERT BINARY TO ZONED DECIMAL SUBROUTINE * 00340000 * * 00360000 *EXITS NORMAL: RESTORE REGISTERS AND BC 15,8(14) * 00380000 *EXITS ERROR: N/A * 00400000 *TABLES/WORKAREAS: WORKA - HOLDS NUMBER AFTER CONVERSION * 00420000 *ATTRIBUTES: * 00440000 * SERIALLY REUSABLE * 00460000 *NOTES: * 00480000 * CONVERT INTERNAL FLOATING POINT TO ZONED DECIMAL. A FL. PT. CONST.* 00500000 * HAS TO BE PASSED. THIS CONSTANT IS 10**(SCALE OF DEST. FIELD). THE* 00520000 * CONSTANT HAS TO FOLLOW THE BRANCH TO SUBROUTINE INSTRUCTION. * 00540000 *********************************************************************** 00560000 * 00580000 * 00600000 IHD00900 START 0 FLPZND 00620000 ENTRY IHD00901 FLPZND 00640000 EXTRN IHD01102 FLTBIN 00660000 EXTRN IHD01802 BINZND 00680000 USING *,5 00700000 * CONVERT INTERAL FLOATING POINT TO ZONED DECIMAL.A FL.PT.CONST.HAS TO 00720000 * BE PASSED.THESE CONSTANT IS 10 ** (SCALE OF DEST.FIELD).THE CONSTANT 00740000 * HAS TO FOLLOW THE BRANCH TO SUBROUTINE INSTRUCTION 00760000 WORKA EQU 32 00780000 IHD00901 STM 14,12,12(13) SAVE REG.CALLING PROGR. 00800000 LR 5,15 LOAD BASE REGISTER 00820000 ST 13,SAVE SAVE ADDR.SAVE AREA CALLING PRG 00840000 MVC WORKA(8,3),0(14) GET SCALE DEST.FIELD 00860000 LD 2,32(3) LOAD SCALE FOR CONVERSION 00880000 L 15,ADCON1 LOAD ADDR. CONV.FL.PT.TO BINARY 00900000 BALR 14,15 CONVERT FL.POINT TO BINARY 00920000 L 15,ADCON2 LOAD ADDR. CONV.BINARY TO ZONED 00940000 BALR 14,15 CONVERT BINARY TO ZONED 00960000 L 13,SAVE RESTORE ADDR.SAVE AREA CALL.PRG 00980000 LM 14,12,12(13) RESTORE REG.CALLING PROGRAM 01000000 BC 15,8(14) GO TO INSTR.AFTER CONSTANT 01020000 ADCON1 DC A(IHD01102) 01040000 ADCON2 DC A(IHD01802) 01060000 SAVE DS F 01080000 END 01100000 ./ ADD SSI=01014046,NAME=IHD01000,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01000 * 00060000 TITLE 'IHD01000 - CONVERT BINARY TO PACKED DECIMAL SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: CONVERTS A BINARY NUMBER TO THE PACKED DECIMAL * 00120000 * FORMAT. * 00140000 *ENTRY POINT: * 00160000 * IHD01001 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00180000 * L 15,ADDRESS OF * 00200000 * IHD01001 * 00220000 * BALR 14,15 * 00240000 *INPUT: REGISTER 0 WILL CONTAIN CONVERTIBLE NUMBER * 00260000 * * 00280000 *OUTPUT: WORKA1 - CONVERTED RESULT * 00300000 *EXTERNAL ROUTINES: N/A * 00320000 *EXITS NORMAL: RESTORE REGISTERS AND BR 14. * 00340000 *EXITS ERROR: N/A * 00360000 *TABLES/WORKAREAS: * 00380000 * WORKA3 - FIRST HALF OF CONVERTIBLE NUMBER * 00400000 * WORKA2 - SECOND HALF OF CONVERTIBLE NUMBER * 00420000 * WORKA1 - CONVERTED RESULT * 00440000 *ATTRIBUTES: * 00460000 * SERIALLY REUSABLE * 00480000 *********************************************************************** 00500000 * 00520000 * 00540000 IHD01000 START 0 BINPK 00560000 ENTRY IHD01001 BINPKS 00580000 ENTRY IHD01002 BINPKD 00600000 * CONVERT BINARY TO PACKED 00620000 WORKA1 EQU 32 00640000 WORKA2 EQU 40 00660000 WORKA3 EQU 48 00680000 IHD01001 SRDA 0,32 EXPAND TO DBL-WRD BINARY 00700000 BALR 15,0 POINT BASE TO NEXT INSTRUCTION 00720000 USING *,15 INFORM ASSEMBLER OF BASE 00740000 IHD01002 MVI SIGN,X'0C' MAKE SIGN POSITIVE 00760000 LTR 0,0 TEST SIGN 00780000 BC 11,BINPK1 NOT MINUS-LEAVE SIGN PLUS 00800000 MVI SIGN,X'0D' MAKE SIGN MINUS 00820000 BINPK1 D 0,248(3) SEPARATE TO 2 CONVERTIBLE NOS 00840000 CVD 1,WORKA3(3) CONVERT FIRST PART 00860000 CVD 0,WORKA2(3) CONVERT SECOND PART 00880000 MVO WORKA1(6,3),WORKA3(8,3) LEFT JUSTIFY DIGITS 10 TO 18 00900000 MVC WORKA1+5(5,3),WORKA2+3(3) SHIFT IN DIGITS 1 TO 9 00920000 MVN WORKA1+9(1,3),SIGN TACK ON ORIGINAL SIGN 00940000 BR 14 RETURN TO CALLER 00960000 SIGN DC X'00' ORIGINAL SIGN SAVE 00980000 END 01000000 ./ ADD SSI=02012002,NAME=IHD01100,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01100 * 00060000 TITLE 'IHD01100 - CONVERT EXTERNAL FL-POINT TO BINARY SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * AT OBJECT TIME CONVERTS FL-POINT TO BINARY. * 00140000 *ENTRY POINTS: * 00160000 * IHD01102 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00180000 * L 15,ADCON2 * 00200000 * BALR 14,15 * 00220000 * FROM IHD01301 AND IHD00901 ADCON2 DC A(IHD01102) * 00240000 * IHD01101 SUBROUTINE ENTRY POINT L 15,ADCON2 * 00260000 * BALR 14,15 * 00280000 * FROM IHD01901 ADCON2 DC A(IHD01101) * 00300000 *INPUT: * 00320000 * FL-POINT REG. 0 CONTAINS NUMBER TO BE CONVERTED * 00340000 *OUTPUT: * 00360000 * WORKA-CONTAINS RESULT * 00380000 *EXTERNAL ROUTINES: N/A * 00400000 *EXITS NORMAL: * 00420000 * BR 14 WHEN CONVERSION COMPLETED * 00440000 *EXITS ERROR: N/A * 00460000 *TABLES/WORKAREAS: * 00480000 * WORKA - CONTAINS RESULT * 00500000 *ATTRIBUTES: * 00520000 * SERIALLY REUSABLE * 00540000 *********************************************************************** 00560000 IHD01100 START 0 FRFLPT 00580000 ENTRY IHD01101 FPEBIN 00600000 ENTRY IHD01102 FLTBIN 00620000 * CONVERT FROM FLOATING POINT TO BINARY 00640000 WORKA EQU 32 00660000 USING *,15 00680000 IHD01102 BAL 15,XLTBIN 00700000 USING *,15 00720000 IHD01101 STE 0,SGNSAV 00740000 LPDR 0,0 00760000 LD 6,FLTEN 00780000 LDR 2,4 00800000 DDR 2,6 00820000 SR 2,2 00840000 LTDR 0,0 IF INPUT IS ZERO, 00860000 BC 7,WHIT RESET GENERAL REGISTERS 0,1 & 2, 00880000 TOOBIG SR 0,0 00900000 SR 1,1 00920000 BR 14 00940000 WHIT CDR 0,4 00960000 BC 10,WHITLE 00980000 BOOST CDR 0,2 01000000 BC 10,LOENUF 01020000 MDR 0,6 01040000 BCT 2,BOOST 01060000 WHITLE DDR 0,6 01080000 LA 2,1(2) 01100000 BC 15,WHIT 01120000 * START FLTBIN 01140000 XLTBIN STE 0,SGNSAV 01160000 LPDR 0,0 01180000 LD 6,TENP36 01200000 CDR 0,6 01220000 BC 10,TOOBIG 01240000 MDR 0,2 01260000 CDR 0,6 01280000 BC 10,TOOBIG 01300000 XLTBI1 DD 6,FLTEN 01320000 XLTBI2 CDR 0,6 01340000 BC 4,XLTBI3 01360000 SDR 0,6 01380000 MVI ALLFS,X'FF' DUMMY INST TO AVOID INTERRUPT. 01400000 BC 15,XLTBI2 01420000 XLTBI3 CD 6,FLTN18 01440000 BC 2,XLTBI1 01460000 LOENUF AW 0,UNFLT 01480000 STD 0,WORKA(3) 01500000 LM 0,1,WORKA(3) 01520000 N 0,EXPMSK 01540000 TM WORKA(3),X'01' 01560000 BZ *+8 01580000 SLDL 0,4(0) 01600000 TM SGNSAV,X'80' 01620000 BCR 8,14 01640000 COMP X 0,ALLFS 01660000 X 1,ALLFS 01680000 AL 1,ONE 01700000 BCR 12,14 01720000 AL 0,ONE 01740000 BCR 15,14 01760000 ONE DC F'1' 01780000 SGNSAV DS F 01800000 FLTEN DC D'10' 01820000 FLTN18 DC D'1E18' 01840000 TENP36 DC D'1E36' 01860000 UNFLT DC X'4E00000000000000' 01880000 EXPMSK DC X'00FFFFFF' 01900000 ALLFS DC X'FFFFFFFF' 01920000 END 01940000 ./ ADD SSI=01014047,NAME=IHD01200,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01200 * 00060000 TITLE 'IHD01200 - CONVERT ZONED DECIMAL TO FL-POINT SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * CALLS IHD01602 TO CONVERT ZONED DEC. TO A BINARY INTEGER THEN CALL* 00140000 * IHD01502 TO CONVERT BINARY TO DOUBLE PRECISION FL-POINT NUMBER. * 00160000 *ENTRY POINTS: * 00180000 * IHD01201 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00200000 * L 15,ADDRESS * 00220000 * OF IHD01201 * 00240000 * BALR 14,15 * 00260000 *INPUT: * 00280000 * ZONED NUMBER LOCATED IN WORKA1 AND WORKA2 * 00300000 *OUTPUT: N/A * 00320000 *EXTERNAL ROUTINES: * 00340000 * IHD01602 - CONVERT ZONEDECIMAL TO BINARY. PLACE BINARY * 00360000 * INTEGER IN REG. 0 AND 1 AND EXPONENT IN REG. 2 * 00380000 * IHD01502 - CONVERT BINARY TO FL-POINT. RESULT IN FP-REG 0 * 00400000 *EXITS NORMAL: * 00420000 * INITIALIZE REG. 15 WITH ADDRESS OF IHD01602 AND BALR 14,15 TO IT.* 00440000 * INITIALIZE REG. 14 WITH ORIGINAL LINK ADDRESS AND REG.15 WITH * 00460000 * ADDRESS OF IHD01502 AND BCR 15,15 TO IT. * 00480000 *EXITS ERROR: N/A * 00500000 *TABLES/WORKAREAS: N/A * 00520000 *ATTRIBUTES: * 00540000 * SERIALLY REUSABLE * 00560000 *********************************************************************** 00580000 * 00600000 * 00620000 IHD01200 START 0 ZNDFLP 00640000 ENTRY IHD01201 ZNDFLP 00660000 EXTRN IHD01502 BINFSC 00680000 EXTRN IHD01602 ZNDBIN 00700000 USING *,15 00720000 IHD01201 ST 14,SAVE 00740000 L 15,ADCON1 00760000 BALR 14,15 00780000 BALR 15,0 00800000 USING *,15 00820000 L 14,SAVE 00840000 L 15,ADCON2 00860000 BCR 15,15 00880000 ADCON1 DC A(IHD01602) 00900000 ADCON2 DC A(IHD01502) 00920000 SAVE DS F 00940000 END 00960000 ./ ADD SSI=01014048,NAME=IHD01300,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01300 * 00060000 TITLE 'IHD01300 - CONVERT FL-POINT TO PACKED DECIMAL SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * LOADS NUMBER TO CONVERT FROM LINK ADDRESS INTO FP-REG. 2,THEN * 00140000 * CALLS IHD01102 TO CONVERT NUMBER TO BINARY THEN CALLS IHD01002 TO * 00160000 * CONVERT NUMBER TO PACKED DECIMAL. * 00180000 *ENTRY POINTS: * 00200000 * IHD01301 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00220000 * L 15,ADDRESS OF* 00240000 * IHD01301 * 00260000 * BALR 14,15 * 00280000 *INPUT: * 00300000 * REG. 14 POINTS TO NUMBER TO BE CONVERTED. * 00320000 *OUTPUT: * 00340000 * WORKA CONTAINS CONVERTED RESULT. * 00360000 *EXTERNAL ROUTINES: * 00380000 * IHD01102 - CONVERT FP NUMBER TO BINARY - RESULT IN REG. 0 * 00400000 * IHD01002 - CONVERT BIN NUMBER TO PACKED DEC. - RESULT IN * 00420000 * WORKA. * 00440000 *EXITS NORMAL: * 00460000 * AFTER CONVERSION RETURN TO ENTRY ADDRESS+ 8. BC 15,8(14) * 00480000 *EXITS ERROR: N/A * 00500000 *TABLES/WORKAREAS: * 00520000 * WORKA - ALLIGNS NUMBER TO BE CONVERTED TO DBL WORD BOUNDARY * 00540000 *ATTRIBUTES: * 00560000 * SERIALLY REUSABLE * 00580000 *NOTES: * 00600000 * A FL-POINT NUMBER 10**(SCALE OF DEST. FIELD) HAS TO BE PASSED * 00620000 * FOLLOWING THE BAL INSTRUCTION. * 00640000 *********************************************************************** 00660000 * 00680000 * 00700000 IHD01300 START 0 FLPPKD 00720000 ENTRY IHD01301 FLPPKD 00740000 EXTRN IHD01002 BINPKD 00760000 EXTRN IHD01102 FLTBIN 00780000 * CONVERT INTERNAL FLOATING POINT TO PACKED DECIMAL 00800000 * A FL.PT.CONSTANT 10 ** (SCALE OF DEST.FIELD) HAS TO BE PASSED 00820000 * FOLLOWING THE BAL INSTRUCTION 00840000 WORKA EQU 32 00860000 USING *,5 00880000 IHD01301 STM 14,12,12(13) SAVE REG CALLING PROGR. 00900000 LR 5,15 LOAD BASE REG 00920000 ST 13,SAVE SAVE ADDR.SAVE AREA IN CALL. PR 00940000 MVC WORKA(8,3),0(14) GET SCALE DEST.FIELD 00960000 LD 2,32(3) 00980000 L 15,ADCON2 LOAD ADDR.CONV.TO BINARY 01000000 BALR 14,15 CONVERT TO BINARY 01020000 L 15,ADCON1 LOAD ADDR CONV.TO PACKED 01040000 BALR 14,15 CONVERT BINARY TO PACKED 01060000 L 13,SAVE LOAD ADDR SAVE AREA CALL.PROGR. 01080000 LM 14,12,12(13) RESTORE REG.CALLING PROGRAM 01100000 BC 15,8(14) RETURN 01120000 ADCON1 DC A(IHD01002) 01140000 ADCON2 DC A(IHD01102) 01160000 SAVE DS F 01180000 END 01200000 ./ ADD SSI=01014049,NAME=IHD01400,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01400 * 00060000 TITLE 'IHD01400 - CONVERT FL-POINT TO BINARY SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * LOADS NUMBER TO CONVERT FROM LINK ADDRESS INTO FP REG. 2 THEN * 00140000 * CALLS IHD01102 TO CONVERT NUMBER TO BINARY. * 00160000 *ENTRY POINTS: * 00180000 * IHD01401 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00200000 * L 15,ADDRESS OF * 00220000 * IHD01401 * 00240000 * BALR 14,15 * 00260000 *INPUT: * 00280000 * REG. 14 POINTS TO NUMBER TO BE CONVERTED. * 00300000 *OUTPUT: * 00320000 * REG. 0 CONTAINS BINARY RESULT * 00340000 *EXTERNAL ROUTINES: * 00360000 * IHD01102 - CONVERT FP NUMBER TO BINARY - RESULT IN REG. 0 * 00380000 *EXITS NORMAL: * 00400000 * AFTER CONVERSION RETURN TO ENTRY ADDRESS + 8. BC 15,8(14) * 00420000 *EXITS ERROR: N/A * 00440000 *TABLES/WORKAREAS * 00460000 * WORKA - ALLIGNS NUMBER TO BE CONVERTED ON A DBL WORD BOUNDARY * 00480000 *ATTRIBUTES: * 00500000 * SERIALLY REUSABLE * 00520000 *NOTES: * 00540000 * THE FL-POINT NUMBER 10**(SCALE DEST. FIELD) HAS TO BE PASSED * 00560000 * FOLLOWING THE BAL INSTRUCTION. * 00580000 *********************************************************************** 00600000 * 00620000 * 00640000 IHD01400 START 0 FLPBIN 00660000 ENTRY IHD01401 FLPBIN 00680000 EXTRN IHD01102 FLTBIN 00700000 * CONVERT INTERAL FLOATING POINT TO BINARY 00720000 * THE FL.PT CONSTANT 10 ** (SCALE DEST.FIELD) HAS TO BE PASSED 00740000 * FOLLOWING BAL INSTRUCTION 00760000 WORKA EQU 32 00780000 USING *,5 00800000 IHD01401 STM 14,12,12(13) SAVE REG.CALLING PROGRAM 00820000 LR 5,15 LOAD BASE REG 00840000 ST 13,SAVE SAVE ADDR.SAVE AREA CALLING PRG 00860000 MVC WORKA(8,3),0(14) GET SCALE DEST.FIELD 00880000 LD 2,32(3) LOAD SCALE DEST.FIELD 00900000 L 15,ADCON1 00920000 BALR 14,15 GO TO CONVERT TO FL.POINT 00940000 L 13,SAVE RESTORE POINTER TO SAVE AREA 00960000 LM 14,15,12(13) RESTORE SAVED REGISTERS. 00980000 LM 2,12,28(13) RESULT IS IN REG. 1 & 2. 01000000 BC 15,8(14) RETURN 01020000 SAVE DS F 01040000 ADCON1 DC A(IHD01102) 01060000 END 01080000 ./ ADD SSI=01014050,NAME=IHD01500,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01500 * 00060000 TITLE 'IHD01500 - CONVERT BINARY TO DBL PREC. FL-POINT SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * CONVERTS A BINARY INTEGER INTO A DOUBLE PRECISION FLOATING POINT * 00140000 * NUMBER. * 00160000 *ENTRY POINTS: * 00180000 * IHD01502 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00200000 * L 15,ADCON2 * 00220000 * L 14,SAVE * 00240000 * BCR 15,15 * 00260000 * SAVE DC RETURN TO * 00280000 * CALLER ADDRES* 00300000 * ADCON2 DC A(IHD01502) * 00320000 *INPUT: * 00340000 * GEN. REG. 0 AND 1 CONTAIN THE NUMBER TO BE CONVERTED. * 00360000 *OUTPUT: * 00380000 * CONVERTED RESULT WILL BE IN FP-REG. 0 * 00400000 *EXTERNAL ROUTINES: N/A * 00420000 *EXITS NORMAL: * 00440000 * WHEN RESULT OF CONVERSION IS ZERO,OR IF MANTISSA NOT NEGATIVE,OR * 00460000 * WHEN CONVERSION IS COMPLETED, A BRANCH TO ADDRESS IN REG. 14 IS * 00480000 * EXECUTED. * 00500000 *EXITS ERROR: N/A * 00520000 *TABLES/WORKAREAS: * 00540000 * TABLE1 - SINGLE PRECISION FP NUMBER TABLE. * 00560000 * TABLE2 - DOUBLE PRECISION FP NUMBER TABLE. * 00580000 *ATTRIBUTES: * 00600000 * SERIALLY REUSABLE * 00620000 *********************************************************************** 00640000 * 00660000 * 00680000 IHD01500 START 0 BINFL 00700000 ENTRY IHD01501 BINFLP 00720000 ENTRY IHD01502 BINFSC 00740000 ENTRY IHD01504 BINFLS 00760000 * THIS ROUTINE CONVERTS A BINARY NUMBER INTO DOUBLE PRECISION FL.POINT 00780000 * THE BINARY NUMBER HAS TO BE AN INTEGER AND MUST BE LOADED IN GEN.REG 00800000 * REGN + REGNP1 THE EXPONENT HAS TO BE LOADED IN GEN.REG. REGEX 00820000 * AFTER CONVERSION THE FL.PT.NUMBER APPEARS IN FL.PT. REG. 0 00840000 IHD01504 LR 0,1 00860000 SRDA 0,32 00880000 BALR 15,0 00900000 IHD01502 EQU * 00920000 IHD01501 EQU * 00940000 USING *,15 00960000 REGEX EQU 2 00980000 REGNP1 EQU 1 01000000 REGN EQU 0 01020000 RTREG EQU 14 01040000 WORKA EQU 32 01060000 REGFL EQU 0 01080000 MVI CHAR,X'4E' SET EXPONENT TO ZERO 01100000 MVI CHAR1,X'00' SET SWITCH MANTISSA POSITIVE 01120000 LTR REGN,REGN TEST FOR POSITIVE MANTISSA 01140000 BC 10,REGNP IF YES DO NOT INVERT MANTISSA 01160000 X REGN,ALLFFS INVERT MANTISSA 01180000 X REGNP1,ALLFFS INVERT MANTISSA 01200000 AL REGNP1,ONEF INVERT MANTISSA 01220000 BC 12,*+8 INVERT MANTISSA 01240000 AL REGN,ONEF INVERT MANTISSA 01260000 MVI CHAR1,X'FF' SET SWITCH TO MANTISSA NEGATI 01280000 REGNP CL REGN,BIT7 TEST FOR EXPONENT AREA OCCUP. 01300000 BL *+12 IF NOT SKIP SHIFT MANTISSA 01320000 SRDL REGN,4 SHIFT MANTISA RIGTH 4 BYTES 01340000 OI CHAR,X'01' SET EXPONENT TO ONE 01360000 ENSN STM REGN,REGNP1,WORKA(3) COMBINE EXPONENT AND MANTISSA 01380000 MVC WORKA(1,3),CHAR 01400000 LD REGFL,WORKA(3) LOAD COMB.NUMBER IN FL.PT.REG 01420000 MD REGFL,FLTONE NORMALIZE 01440000 LTDR REGFL,REGFL TEST FOR ZERO 01460000 BCR 8,RTREG RETURN IF RESULT ZERO 01480000 MVI INSTR,X'6C' SET INSTR.TO MULT FOR POS.EXP 01500000 LA REGNP1,TABLE1+4 01520000 MVI INSTR1+1,X'2E' 01540000 SLL REGEX,24 01560000 SRA REGEX,24 01580000 LTR REGN,REGEX 01600000 BC 10,EXPOS SKIP HANDLE EXPON.NEGAT. 01620000 LA REGNP1,TABLE1 01640000 MVI INSTR1+1,X'4E' 01660000 LCR REGN,REGN 01680000 MVI INSTR,X'6D' 01700000 EXPOS LA REGEX,TABEL 01720000 SLL REGN,25 01740000 LOOP1 ALR REGN,REGN 01760000 BC 12,NOMOD IF NOT NO MODIFICATION 01780000 CE REGFL,0(REGNP1) 01800000 EX 0,INSTR1 BRANCH ON ILLEGAL 01820000 EX 0,INSTR MODIF.FLOATING POINT NUMBER 01840000 NOMOD C REGEX,ADCON 01860000 BC 8,END 01880000 LA REGEX,8(REGEX) 01900000 LA REGNP1,8(REGNP1) 01920000 B LOOP1 IF NOT LOOP 01940000 END CLI CHAR1,X'00' TEST FOR NEGATIVE MANTISSA 01960000 BCR 8,RTREG IF NOT GO TO CALLING ROUTINE 01980000 LNDR REGFL,REGFL INVERT FL.PT.NUMBER 02000000 BCR 15,RTREG GO TO CALLING ROUTINE 02020000 INSTR MD REGFL,0(REGEX) 02040000 INSTR1 BC 0,0(RTREG) 02060000 BIT7 DC F'16777216' 02080000 ADCON DC A(TABEL+56) 02100000 ONEF DC F'1' 02120000 ALLFFS DC F'-1' 02140000 TABLE1 DC E'2.4E-14' 02160000 DC E'7.2E+11' 02180000 DC E'2.4E-46' 02200000 DC E'7.2E+43' 02220000 DC E'2.4E-62' 02240000 DC E'7.2E+59' 02260000 DC E'2.4E-70' 02280000 DC E'7.2E+67' 02300000 DC E'2.4E-74' 02320000 DC E'7.2E+71' 02340000 DC E'2.4E-76' 02360000 DC E'7.2E+73' 02380000 DC X'012C76D3' E'2.4E-77' 02400000 DC E'7.2E+74' 02420000 FLTONE DC D'1' 02440000 TABEL DC D'1E64' 02460000 DC D'1E32' 02480000 DC D'1E16' 02500000 DC D'1E08' 02520000 DC D'1E04' 02540000 DC D'1E02' 02560000 DC D'1E01' 02580000 CHAR DS C 02600000 CHAR1 DS C 02620000 END 02640000 ./ ADD SSI=01014051,NAME=IHD01600,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01600 * 00060000 TITLE 'IHD01600 - CONVERT PACKED OR ZONED DECIMAL TO BINARY SUBRTNE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * PACKS A ZONED NUMBER AND CONVERTS PACKED NUMBERS TO BINARY * 00140000 *ENTRY POINTS: * 00160000 * IHD01601 SUBROUTINE ENTRY POINT-PACKED CALLING SEQUENCE: * 00180000 * L 15,ADCON1 * 00200000 * BALR 14,15 * 00220000 * FROM IND00800 ADCON1 DC A(IHD01601) * 00240000 * IHD01602 SUBROUTINE ENTRY POINT-ZONED L 15,ADCON1 * 00260000 * BALR 14,15 * 00280000 * FROM IHD01200 ADCON1 DC A(IHD01602) * 00300000 *INPUT: * 00320000 * WORKA1 WILL CONTAIN ZONED OR PACKED NUMBER * 00340000 *OUTPUT: * 00360000 * REG. 2 WILL HOLD RESULTANT BINARY NUMBER * 00380000 *EXTERNAL ROUTINES: N/A * 00400000 *EXITS NORMAL: * 00420000 * AFTER CONVERSION RETURN TO CALLER VIA BCR 15,14 * 00440000 *EXITS ERROR: N/A * 00460000 *TABLES/WORKAREAS: * 00480000 * WORKA1 - INPUT AREA * 00500000 * WORKA2 - COMPLETED NUMBER BUCKET * 00520000 * WORKA3 - INTERMEDIATE WORKAREA * 00540000 *ATTRIBUTES: * 00560000 * SERIALLY REUSABLE * 00580000 *********************************************************************** 00600000 * 00620000 * 00640000 IHD01600 START 0 TOBIN 00660000 ENTRY IHD01601 PKDBIN 00680000 ENTRY IHD01602 ZNDBIN 00700000 * CONVERT PACKED OR ZONED TO BINARY 00720000 WORKA1 EQU 56 00740000 WORKA2 EQU 64 00760000 WORKA3 EQU 72 00780000 USING *,15 00800000 IHD01601 ZAP WORKA3(8,3),WORKA1+5(5,3) 00820000 NI WORKA1(3),X'0F' 00840000 MVC WORKA2+7(1,3),WORKA1+9(3) 00860000 MVO WORKA2(8,3),WORKA1(5,3) 00880000 BAL 15,ZDB1 00900000 USING *,15 00920000 IHD01602 PACK WORKA3(8,3),WORKA2+1(9,3) 00940000 PACK WORKA2(8,3),WORKA1(9,3) 00960000 MVN WORKA2+7(1,3),WORKA3+7(3) 00980000 ZDB1 CVB 1,WORKA2(3) 01000000 ST 2,WORKA2(3) 01020000 CVB 2,WORKA3(3) 01040000 M 0,248(3) 01060000 ALR 1,2 01080000 BC 12,*+8 01100000 AH 0,214(3) 01120000 LTR 2,2 01140000 L 2,WORKA2(3) 01160000 BCR 10,14 01180000 SH 0,214(3) 01200000 BCR 15,14 01220000 END 01240000 ./ ADD SSI=02012501,NAME=IHD01700,SOURCE=0 *( 00005017 *1015009600 8982 00010017 *) 00015017 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01700 * 00060000 TITLE 'IHD01700 - COMPARE 2 ALPHABETIC FIELDS OF UNEQUAL LENGTHS' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: 00120000 * COMPARES SEND FIELD WITH DESTINATION FIELD CHARACTER BY CHARACTER.* 00140000 * ISSUES A FINAL COMPARE TO SET CONDITION CODE FOR CALLER. PROVIDES * 00160000 * FOR FIELDS LONGER THAN 256 BYTES. * 00180000 *ENTRY POINTS: * 00200000 * IHD01701 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00220000 * L 15,ADDRESS OF * 00240000 * IHD01701 * 00260000 * BALR 14,15 * 00280000 *INPUT: * 00300000 * LENGTH OF FIELDA IN UPPER HALF OF REG 0 * 00320000 * LENGTH OF FIELDB IN LOWER HALF OF REG 0 * 00340000 * ADDRESS OF FIELDA IN REG 1 * 00360000 * ADDRESS OF FIELDB IN REG 2 * 00380000 *OUTPUT: * 00400000 * CONDITION CODE SET FOR CALLER * 00420000 *EXTERNAL ROUTINES: N/A * 00440000 *EXITS NORMAL: * 00460000 * RETUR - RESTORE REGISTERS AND BCR 15,14 * 00480000 *EXITS ERROR: N/A * 00500000 *TABLES/WORKAREAS: N/A * 00520000 *ATTRIBUTES: * 00540000 * SERIALLY REUSABLE * 00560000 *********************************************************************** 00580000 * 00600000 * 00620000 IHD01700 START 0 RCMPA 00640000 ENTRY IHD01701 RCMPA 00660000 USING *,15,3 00680000 RAA EQU 1 00700000 RAB EQU 2 00720000 RLA EQU 4 00740000 RLB EQU 5 00760000 IHD01701 STM 14,12,12(13) 00780000 MVI WORKA,X'40' TO BLANK WORKA 00800000 MVC WORKA+1,WORKA 00820000 LR RLA,0 00840000 SRL RLA,16 LENGTH OF A IN RLA 00860000 LR RLB,0 00880000 SLL RLB,16 00900000 SRL RLB,16 LENGTH OB B IN RLB 00920000 SR 9,9 00940000 IC 9,=X'01' 8982 00960017 RSB50 CH RLA,RCH256 SYSTEMATICALLY COMPARE CHARACTER 00980000 BL RSB51 TO CHARACTER 01000000 CH RLB,RCH256 01020000 BL RSB52 01040000 CLC 0(256,RAA),0(RAB) COMPARE SENDFD WITH DESTFD 01060000 BNE RETUR 01080000 LA RAA,256(RAA) 01100000 LA RAB,256(RAB) 01120000 SH RLB,RCH256 01140000 SH RLA,RCH256 01160000 B RSB50 01180000 RSB51 CR RLA,RLB 01200000 BH RSB52 01220000 BE RSB53 01240000 BL RSB54 01260000 RSB52 EX RLB,RS5EX 01280000 BNE RETUR 01300000 LA RAB,1(RAA,RLB) 01320000 SR RLA,RLB 01340000 LR RLB,RLA 01360000 BCT RLB,RSB57 01380000 RSB53 EX RLB,RS5EX 01400000 B RETUR 01420000 RSB54 EX RLA,RS5EX 01440000 BNE RETUR 01460000 LA RAB,1(RLA,RAB) 01480000 BCTR RLB,0 01500000 SR RLB,RLA 01520000 LNR RLA,RLB 01540000 RSB57 CH RLB,RCH16 01560000 BNH RSB58 01580000 OC WORKA(16),0(RAB) 01600000 SH RLB,RCH16 01620000 LA RAB,16(RAB) 01640000 B RSB57 01660000 RSB58 EX RLB,RS5X1 01680000 CLI WORKA,C' ' 01700000 BE RETUR 01720000 CR RLA,RLB 01740000 RETUR LM 14,12,12(13) 01760000 BCR 15,14 01780000 RCH16 DC X'0010' 01800000 RCH256 DC X'0100' 01820000 RS54F DS D 01840000 RS5EX CLC 0(0,RAA),0(RAB) 01860000 RS5X1 OC WORKA(0),0(RAB) 01880000 GLOBTB EQU IHD01701+4096 01900000 WORKA EQU GLOBTB+32 01920000 END 01940000 ./ ADD SSI=01014053,NAME=IHD01800,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01800 * 00060000 TITLE 'IHD01800 - CONVERT BINARY TO ZONED DECIMAL SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * EXTRACTS CONTENTS OF REG. 0,EXPANDS IT TO A DOUBLE WORD,AND * 00140000 * CONVERTS BOTH WORDS TO A ZONED DECIMAL NUMBER. * 00160000 *ENTRY POINTS: * 00180000 * IHD01801 SUBROUTINE ENTRY POINT CALLING SEQUENCE: * 00200000 * BAL 14,BINZNS * 00220000 * IHD01802 SUBROUTINE ENTRY POINT L 15,ADCON2 * 00240000 * BALR 14,15 * 00260000 * FROM IHD00900 ADCON2 DC A(IHD01802) * 00280000 *INPUT: * 00300000 * REG.0 CONTAINS BINARY NUMBER TO CONVERT * 00320000 *OUTPUT: * 00340000 * WORKA1 CONTAINS CONVERTED NUMBER * 00360000 *EXTERNAL ROUTINES: N/A * 00380000 *EXITS NORMAL: * 00400000 * AFTER CONVERSION BCR 15,14 * 00420000 *EXITS ERROR: N/A * 00440000 *TABLES/WORKAREAS: * 00460000 * WORKA1 - OUTPUT * 00480000 * WORKA2 - FIRST HALF OF NUMBER WORKAREA * 00500000 * WORKA3 - SECOND HALF OF NUMBER WORKAREA * 00520000 *ATTRIBUTES: * 00540000 * SERIALLY REUSABLE * 00560000 *********************************************************************** 00580000 * 00600000 * 00620000 IHD01800 START 0 BINZN 00640000 ENTRY IHD01801 BINZNS 00660000 ENTRY IHD01802 BINZND 00680000 * CONVERT BINARY TO ZONED 00700000 WORKA1 EQU 32 00720000 WORKA2 EQU 40 00740000 WORKA3 EQU 48 00760000 IHD01801 SRDA 0,32 EXPAND TO DBL-WRD BINARY 00780000 BALR 15,0 POINT BASE TO NEXT INSTRUCTION 00800000 USING *,15 INFORM ASSEMBLER OF BASE 00820000 IHD01802 MVI SIGN,X'C0' MAKE SIGN POSITIVE 00840000 LTR 0,0 TEST SIGN 00860000 BC 11,BINZN1 NOT NEG-LEAVE SIGN PLUS 00880000 MVI SIGN,X'D0' MAKE SIGN NEGATIVE 00900000 BINZN1 D 0,248(3) SEPARATE TO 2 CONVERTIBLE NOS 00920000 CVD 1,WORKA2(3) CONVERT FIRST HALF 00940000 CVD 0,WORKA3(3) CONVERT SECOND HALF 00960000 UNPK WORKA1(9,3),WORKA2+3(5,3) UNPACK FIRST HALF 00980000 UNPK WORKA1+9(9,3),WORKA3+3(5,3) 01000000 OI WORKA1+8(3),X'F0' MAKE SIGN OF FIRST PART 'F' 01020000 OC WORKA1+17(1,3),SIGN TACK ON ORIGINAL SIGN 01040000 BCR 15,14 01060000 SIGN DC X'00' ORIGINAL SIGN SAVE 01080000 END 01100000 ./ ADD SSI=04012501,NAME=IHD01900,SOURCE=0 *( 00005017 *3018042800-043400,044000,047200,049800 8686 00010017 *) 00015017 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD01900 * 00060000 TITLE 'IHD01900 - CONVERT MISC. FIELDS TO EXT. FLOATING POINT' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * CONVERSION SUBROUTINE FOR ED,ID,BI,FC AND IF INTO EXTERNAL * 00140000 * FLOATING POINT. * 00160000 *ENTRY POINTS: * 00180000 * IHD01901 SUBROUTINE ENTRY POINT - ED CALLING SEQUENCE: * 00200000 * IHD01902 SUBROUTINE ENTRY POINT - BI L 15,ADDRESS OF* 00220000 * IHD01904 SUBROUTINE ENTRY POINT - FC APPROPRIATE * 00240000 * IHD01908 SUBROUTINE ENTRY POINT - IF ENTRY POINT. * 00260000 *INPUT: BALR 14,15 * 00280000 * REG. 14 POINTS TO NUMBER TO BE CONVERTED * 00300000 *OUTPUT: * 00320000 * WORKB HOLDS RESULT * 00340000 *EXTERNAL ROUTINES: * 00360000 * IHD01802 - BINARY TO ZONED DECIMAL * 00380000 * IHD01101 - EXT. FP TO BINARY * 00400000 *EXITS NORMAL: * 00420000 * EEF17 BRANCH TO 12(14) IF FL-POINT * 00440000 * BRANCH TO 6(14) IF NOT FL-POINT * 00460000 *EXITS ERROR: N/A * 00480000 *TABLES/WORKAREAS: * 00500000 * WORKA AND WORKX - CONVERSION WORKAREAS * 00520000 * WORKB - RESULT AREA * 00540000 *ATTRIBUTES: * 00560000 * SERIALLY REUSABLE * 00580000 *********************************************************************** 00600000 IHD01900 START 0 EIJSUB 00620000 ENTRY IHD01901 EDEFP 00640000 ENTRY IHD01902 BIEFPL 00660000 ENTRY IHD01904 FCEFP 00680000 ENTRY IHD01908 IFPEFP 00700000 EXTRN IHD01802 BINZND 00720000 EXTRN IHD01101 FPEBIN 00740000 * * * 00760000 * CONVERSION SUBROUTINE FOR ED,ID,BI,FC AND IFINTO 00780000 * EXTERNAL FLOAYING POINT 00800000 * * * 00820000 * RESULT IS STORED IN WORKB 00840000 * * * 00860000 * ZONED DECIMAL TO EXTERNAL FLOATING POINT CONVERSION 00880000 * ALSO ENTRY FOR ID-EF AND BI-SHORT TO EF 00900000 * * * 00920000 USING *,15 00940000 IHD01901 STM 14,12,12(13) RESERVE REGISTERS. 00960000 LA 10,ESTART-IHD01901(15) STORE DIFFERENCE FROM ACTUAL 00980000 USING ESTART,10,3 ENTRY POINT OF THE SUBROUTINE 01000000 B ENTED IN REG-15. 01020000 IHD01902 STM 14,12,12(13) RESERVE REGISTERS. 01040000 LA 10,ESTART-IHD01902(15) STORE DIFFERENCE FROM ACTUAL 01060000 USING ESTART,10 ENTRY POINT OF THE SUBROUTINE 01080000 B ENTBEI IN REG-15. 01100000 IHD01904 STM 14,12,12(13) RESERVE REGISTERS. 01120000 LA 10,ESTART-IHD01904(15) STORE DIFFERENCE FROM ACTUAL 01140000 USING ESTART,10 ENTRY POINT OF THE SUBROUTINE 01160000 B ENTFC IN REG-15. 01180000 IHD01908 STM 14,12,12(13) RESERVE REGISTERS. 01200000 LA 10,ESTART-IHD01908(15) STORE DIFFERENCE FROM ACTUAL 01220000 USING ESTART,10 ENTRY POINT OF THE SUBROUTINE 01240000 B ENTIFP IN REG-15. 01260000 ESTART DS 0D 01280000 ENTED BAL ERC,EFCOM PREPARE FOR CONVERSION. 01300000 EFCOM1 LH ER2,MANSCL CALCULATE FOLLOWING AND STORE 01320000 SH ER2,MLENG IN REG2 01340000 AH ER2,ALPHA --- ALPHA-MLENG+MANSCL ---. 01360000 B EEXFP GO TO FINISH-UP ROUTINE. 01380000 * * * 01400000 * BINARY TO EXTERNAL FLOATING POINT POINT CONVERSION 01420000 * * * 01440000 ENTBEI BAL ERC,EFCOM 01460000 LH ER2,ALPHA SET EXPONENT MAGNITUDE AND 01480000 SH ER2,MLENG GO TO EF-CONVERSION THRU BIED. 01500000 B EEF01 01520000 * * * 01540000 * MOVE FIGCON ZERO TO EXTERNAL FLOATING POINT 01560000 * * * 01580000 ENTFC BAL ERC,EFCOM 01600000 MVI WORKA,X'F0' FILL UP WORKA WITH 'F0' 01620000 MVC WORKA+1(21),WORKA AND GO TO ED-EF CONVERSION. 01640000 B EFCOM1 01660000 * * * 01680000 * INTERNAL FLOATING POINT TO EXTERNAL FLOATING POINT CONVERSION 01700000 * * * 01720000 ENTIFP BAL ERC,EFCOM GET NECESSARY DATA. 01740000 OI IFSW,X'40' SET IFP-SW ON. 01760000 MVC ALENG(2),MLENG SET ALENG = MLENG. 01780000 MVC WORKA(8),3(RTREG) PREPARE FOR IF-BI CONVERSION. 01800000 LD EFR4,WORKA EFR4 CONTAINS UPPER LIMIT 01820000 L 15,ADCON2 01840000 BALR 14,15 01860000 CLI MLENG+1,9 CHECK MANTISSA LENGTH. 01880000 BH EEF01 01900000 CVD ER1,WORKX IF SMALLER THAN 10, 01920000 UNPK WORKA+9(9),WORKX(8) CONVERT INTO BINARY DIRECTLY. 01940000 B EEF02 01960000 EEF01 L 15,ADCON1 01980000 BALR 14,15 02000000 EEF02 LH ERF,MLENG CALL SUBROUTINE. 02020000 BCTR ERF,0 EEF01 IS ENTRY FOR BI-LONG. 02040000 STC ERF,EEF03+1 02060000 LA ERD,WORKA 02080000 SH ERD,ALENG LEFT-ALIGN CONVERTED DATA 02100000 EEF03 MVC WORKA(0),18(ERD) IN WORKA. LENGTH = MLENG. 02120000 AH ER2,MANSCL ADJUST EXPONENT OF IF AND BI-LONG. 02140000 BAL ERE,EROUND GO TO CHECK ROUNDING. 02160000 * ENTRY POINT FOR ED,ID,FIGCON AND BI-SHORT 02180000 EEXFP LA ERD,WORKA FINISH-UP COMMON ROUTINE. 02200000 AH ERD,ALENG ERD SHOWS WORKA+ALENG. ( FOR IF 02220000 EEF04 MVI 0(ERD),X'F0' AND BI-LONG, WORKA+MLENG.) 02240000 MVC 1(17,ERD),0(ERD) FILL UP WORKA LOW-ORDER WITH 'F0'. 02260000 BCTR ERD,0 ERD POINTS WORKA+ALENG-1. 02280000 TM 0(ERD),X'30' TEST MANTISSA VALUE SIGN. 02300000 BC 9,EEF05 IF VALUE NEGATIVE, 02320000 OI IFSW,X'80' SET MANTISSA-NEGATIVE-SW ON. 02340000 EEF05 OI 0(ERD),X'F0' DELETE MANTISSA SIGN. 02360000 CLI ALENG+1,X'00' SKIP LOOP FOR FIGCON. 02380000 BE EEF21 02400000 LH ERF,ALENG NORMALIZATION. 02420000 EEF19 CLI WORKA,X'F0' CHECK IF LEADING BYTE ZERO. 02440000 BNE EEF20 NO --- GO OUT. 02460000 MVC WORKA(30),WORKA+1 SHIFT OUT LEADING ZERO. 02480000 BCTR ER2,0 REDUCE 1 FROM EXPONENT. 02500000 BCT ERF,EEF19 TAKE NEXT BYTE AND CONTINUE. 02520000 EEF21 SR ER2,ER2 IF TRUE ZERO, SET EXPONENT TO ZERO 02540000 EEF20 TM IFSW,1 TEST DECIMAL POINT REAL OR IMPLD. 02560000 BO EEF06 02580000 LH ERF,MLENG 02600000 BCTR ERF,0 02620000 EX ERF,EEF07 02640000 B EEF08 02660000 EEF07 MVC WORKB+1(0),WORKA IMPLIED. STORE WHOLE MANTISSA. 02680000 EEF06 CLI MINTG+1,0 REAL DECIMAL POINT. 02700000 BE EEF09 TEST INTEGER LENGTH. 02720000 LH ERF,MINTG 02740000 BCTR ERF,0 02760000 STC ERF,EEF10+1 02780000 EEF10 MVC WORKB+1(0),WORKA INTEGER NOT 0. STORE INTEGER. 02800000 EEF09 LA ERC,WORKB ERC SHOWS WORKB+MINTG. 02820000 AH ERC,MINTG 02840000 CLI MANSCL+1,0 02860000 BE EEF18 02880000 LH ERF,MANSCL 02900000 BCTR ERF,0 02920000 STC ERF,EEF11+1 02940000 LA ERD,WORKA 02960000 AH ERD,MINTG ERD SHOWS WORKA+MINTG. 02980000 EEF11 MVC 2(0,ERC),0(ERD) STORE SCALING PORTION. 03000000 EEF18 MVI 1(ERC),X'4B' INSERT DECIMAL POINT. 03020000 EEF08 LA ERF,WORKB 03040000 AH ERF,WLENG 03060000 SH ERF,EH05 ERF SHOWS WORKB+WLENG-5. 03080000 MVI 1(ERF),X'C5' INSERT 'E'. 03100000 CVD ER2,WORKX CONVERT EXPONENT INTO ZONED. 03120000 UNPK 3(2,ERF),WORKX(8) 03140000 * SIGN HANDLING ROUTINE 03160000 TM IFSW,X'80' TEST MANTISSA SIGN. 03180000 BO EEF12 03200000 TM IFSW,4 OFF -- MANTISSA VALUE PLUS. 03220000 BO EEF13 TEST PICTURE MANTISSA SIGN. 03240000 MVI WORKB,X'40' BOTH SIGN +. SET BLANK AS 03260000 B EEF14 MANTISSA SIGN. 03280000 EEF12 MVI WORKB,X'60' VALUE NEGATIVE. SET '-' UNCONDI- 03300000 B EEF14 TIONALLY. 03320000 EEF13 MVI WORKB,X'4E' PICTURE M-SIGN - AND VALUE PLUS. 03340000 EEF14 TM 4(ERF),X'30' TEST EXPONENT VALUE. 03360000 BM EEF15 03380000 TM IFSW,2 IF OFF, TEST PICTCURE EXPONENT 03400000 BO EEF16 SIGN. 03420000 MVI 2(ERF),X'40' INSERT BLANK AS EXPONENT SIGN. 03440000 B EEF17 03460000 EEF15 MVI 2(ERF),X'60' EXPONENT NEGATIVE. STORE '-'. 03480000 B EEF17 03500000 EEF16 MVI 2(ERF),X'4E' PICTURE EXPONENT SIGN -. 03520000 EEF17 OI 4(ERF),X'F0' DELETE EXPONENT SIGN. 03540000 TM IFSW,X'40' TEST IFP-SW. 03560000 LM 14,12,12(13) 03580000 BO 12(RTREG) IF ON, BUMP UP 13 BYTES TO GET 03600000 B 6(RTREG) RETURN ADDRESS. 03620000 * 03640000 * COMMON LINKAGE PORTION FOR SUBSTITUTION AND CONVERSION SUBROUTINE 03660000 * 03680000 EFCOM SR ERF,ERF RESET ERF. 03700000 IC ERF,0(RTREG) GET SCALE LENGTH IN ERF, 03720000 STH ERF,MANSCL AND STORE. 03740000 IC ERF,1(RTREG) GET DECIMAL POINT AND SIGN 03760000 STC ERF,IFSW INDICATORS. 03780000 IC ERF,2(RTREG) GET WHOLE EF LENGTH, 03800000 STH ERF,WLENG AND STORE. 03820000 SH ERF,EH05 SUBTRACT 5 FROM WLENG TO HAVE 03840000 TM IFSW,1 REAL MANTISSA LENGTH. 03860000 BZ ECM01 03880000 BCTR ERF,0 IF REAL DECIMAL POINT, SUBTRACT 03900000 ECM01 STH ERF,MLENG ONE MORE. 03920000 SH ERF,MANSCL GET INTEGER LENGTH OF MANTISSA. 03940000 STH ERF,MINTG 03960000 IC ERF,3(RTREG) GET A-FIELD LENGTH. 03980000 STH ERF,ALENG 04000000 IC ERF,4(RTREG) GET ALPHA. 04020000 SLL ERF,24 04040000 SRA ERF,24 EXPAND SIGN AND STORE. 04060000 STH ERF,ALPHA 04080000 TM IFSW,8 IS ROUNDING SW ON ? 04100000 BCR 8,ERC NO --- RETURN TO MAIN. 04120000 LH ERF,MLENG YES --- 04140000 AH ERF,EH01 INCREASE MLENG BY 1, 04160000 STH ERF,MLENG AND STORE BACK. 04180000 BR ERC 04200000 * * * EXTERNAL FLOATING POINT ROUNDING ROUTINE 04220000 EROUND TM IFSW,8 IS ROUNDING SW ON ? 04240000 BCR 8,ERE NO---RETURN. 04260000 CLI MLENG+1,X'10' MORE THAN 16 BYTES 8686 04268017 BNH LOAD 8686 04276017 LH ERF,X15 GET MAX.LENGTH FOR PACK INST8686 04284017 EX ERF,EINST1 8686 04292017 MVO WORKX(16),WORKX(16) PREPARE PACK OF LAST BYTE 8686 04300017 PACK WORKX+15(1),WORKA+16(1) 8686 04308017 B INCR 8686 04316017 LOAD LH ERF,MLENG YES,TAKE ROUNDING PROCEDURE 8686 04324017 BCTR ERF,0 SUBTRACT 1 LENGTH OF EX INST8686 04332017 EX ERF,EINST1 EXECUTE PACK INSTRUCTION 8686 04340017 INCR AH ER2,EH01 ADD 1 TO EXPONENT 8686 04348017 ERND02 MVN ERND5(1),WORKX+15 ROUNDING IS DONE TO ABSOLUTE VALUE 04360000 AP WORKX(16),ERND5(1) ADD + OR -5 TO LEAST SIG. POS. 04380000 CLI MLENG+1,X'10' MORE THAN 16 BYTES 8686 04382017 BL SETLGT NO 8686 04384017 UNPK WORKA+2(16),WORKX(16) UNPACK 16 BYTES 8686 04386017 IC ERF,WORKX+7 UNPACK 17TH BYTE 8686 04388017 SRL ERF,4 8686 04390017 STC ERF,WORKA+1 8686 04392017 OI WORKA+1,X'F0' 8686 04394017 CLI WORKX+6,X'00' OVERFLOW ON 17TH BYTE 8686 04396017 BNE MOVE YES 8686 04398017 MVC WORKA(17),WORKA+1 8686 04400017 CLI WORKA,X'F0' 8686 04402017 BE ERND07 8686 04404017 LH ERF,MLENG 8686 04406017 B ERND06 8686 04408017 SETLGT AH ERF,EH01 SET LENGTH TO MLENG 8686 04410017 SLL ERF,4 SHIFT 4 BITS FOR OP1 LENGTH. 04420000 EX ERF,EINST2 EXECUTE UNPK INSTRUCTION. 04440000 ERND07 LH ERF,MLENG LOAD MLENG FOR MODIFICATION. 04460000 CLI WORKA,X'F0' IF TOP POS. OF WORKA NOT 0, 04480000 BNE ERND05 THERE WAS OVERFLOW BY ROUNDING. 04500000 MVC WORKA(18),WORKA+1 ELSE SHIFT OUT THE TOP 0, 04520000 B ERND06 AND DO NOT INCREASE EXPONENT. 04540000 ERND05 AH ER2,EH01 IF OVERFLOW, ADD 1 TO EXPONENT 04560000 AH ERF,EH01 AND TO ALENG. 04580000 STH ERF,ALENG ALENG = MLENG + 2. 04600000 BCTR ERF,0 SUBTRACT 1 FROM ERF FOR MLENG. 04620000 ERND06 BCTR ERF,0 GET REAL MANTISSA LENGTH. 04640000 STH ERF,MLENG STORE BACK. 04660000 BR ERE RETURN TO MAIN. 04680000 EINST1 PACK WORKX(16),WORKA(0) PACK MANTISSA FOR ROUNDING 04700000 EINST2 UNPK WORKA(0),WORKX(16) UNPACK IN 1 POS. LARGER FIELD. 04720000 MOVE MVC WORKA(1),WORKX+6 UNPACK OVERFLOW BYTE 8686 04725017 OI WORKA,X'F0' 8686 04730017 B ERND07 8686 04735017 * 04740000 * DECLARATIVE PORTION 04760000 * 04780000 EH05 DC H'5' 04800000 EH256 DC H'256' * 04820000 EH01 DC H'1' * 04840000 MANSCL DS H 04860000 WLENG DS H * 04880000 ALENG DS H 04900000 ALPHA DS H 04920000 MINTG DS H 04940000 MLENG DS H 04960000 ERND5 DC X'5F' 5 FOR ROUNDING 04980000 X15 DC H'15' 8686 04990017 IFSW DS C 05000000 ER1 EQU 1 * 05020000 ER2 EQU 2 * 05040000 EFR4 EQU 4 * * * 05060000 ERC EQU 8 * 05080000 ERD EQU 9 * 05100000 RTREG EQU 14 * 05120000 RETREG EQU 14 05140000 ERE EQU 14 * 05160000 ERF EQU 5 * 05180000 ADCON1 DC A(IHD01802) 05200000 ADCON2 DC A(IHD01101) 05220000 GLTAB EQU ESTART+4096 05240000 WORKA EQU GLTAB+32 05260000 WORKX EQU GLTAB+16 05280000 WORKB EQU GLTAB+56 05300000 END 05320000 ./ ADD SSI=03012501,NAME=IHD02000,SOURCE=0 *( 00005017 *2016016200,030800 8349 00010017 *) 00015017 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02000 * 00060000 TITLE 'IHD02000 - MOVE GROUP ITEMS LONGER THAN 256 BYTES' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * MOVES ALPHA OR NUMERIC FIELDS LONGER THAN 256 BYTES. PERFORMS * 00140000 * MOVES OF 256 AT A TIME UNTIL WHOLE FIELD HAS BEEN MOVED. * 00160000 *ENTRY POINTS: * 00180000 * IHD02001 SUBROUTINE ENTRY POINT - MVGRP CALLING SEQUENCE: * 00200000 * IHD02002 SUBROUTINE ENTRY POINT - FGCGRP L 15,WITHAPPROP-* 00220000 * RIATE ADDR.* 00240000 * BALR 14,15 * 00260000 *INPUT: * 00280000 * ADDRESS IN REG. 14 + 2 BYTES IS LOCATION OF SEND FIELD. * 00300000 * ADDRESS IN REG. 14 + 4 BYTES IS LOCATION OF DEST. FIELD. * 00320000 *OUTPUT: N/A * 00340000 *EXTERNAL ROUTINES: N/A * 00360000 *EXITS NORMAL: * 00380000 * RETURN TO CALLER VIA REG. 14 * 00400000 *EXITS ERROR: N/A * 00420000 *TABLES/WORKAREAS: N/A * 00440000 *ATTRIBUTES: * 00460000 * SERIALLY REUSABLE * 00480000 *********************************************************************** 00500000 * 00520000 * 00540000 IHD02000 START 0 MOVGRP 00560000 ENTRY IHD02001 MVGRP 00580000 ENTRY IHD02002 FGCGRP 00600000 * * * 00620000 * SUBROUTINE FOR MOVE TO GROUP, ALPHABETICOR ALPHANUMERIC 00640000 * GREATER THAN 256 00660000 * * * 00680000 USING *,15 00700000 IHD02001 STM 14,12,12(13) RESERVE REGISTERS. 00720000 LA 10,EMSTRT-IHD02001(15) STORE DIFFERENCE FROM ACTUAL 00740000 USING EMSTRT,10 ENTRY POINT OF THE SUBROUTINE 00760000 B ENTMVG IN REG-15. 00780000 IHD02002 STM 14,12,12(13) RESERVE REGISTERS. 00800000 LA 10,EMSTRT-IHD02002(15) STORE DIFFERENCE FROM ACTUAL 00820000 USING EMSTRT,10 ENTRY POINT OF THE SUBROUTINE 00840000 B ENTFGC IN REG-15. 00860000 EMSTRT DS 0C 00880000 ENTMVG LR ERC,RX ERC AND ERD ARE USED INSTEAD OF 00900000 LR ERD,RY RX AND RY FOR GENERALISATION. 00920000 LH RA,2(RTREG) PICK UP SENDFD LENGTH IN REG A. 00940000 LH RB,4(RTREG) PICK UP DESTFD LENGTH. 00960000 CLI 0(RTREG),0 TEST RIGHT-ALIGNMENT REQUIRED. 00980000 BNE EALGN 01000000 * 01020000 * NORMAL --- LEFT-ALIGNMENT --- MOVE-LONG 01040000 * 01060000 CR RA,RB TEST IF A BIGGER THAN B. 01080000 BH EMV03 IF YES, GO TO CASE-3. 01100000 * A SMALLER THAN B AND BIGGER THAN 256 01120000 EMV01 CH RA,EH256 01140000 BNH EMV02 IF A SMALLER B, GO TO FINISH-UP. 01160000 BAL ERE,EMOVE1 MOVE 256-POSITIONS AND UPDATE 01180000 B EMV01 REGISTERS. 01200000 * A SMALLER THAN 256 01220000 EMV02 SR RB,RA RB SHOWS TRAILING POSITIONS 01240000 BCTR RA,0 TO BE FILLED WITH 'F0'. 01260000 STC RA,EMV1+1 MOVE FINAL DATA IN REMAINING 01280000 EMV1 MVC 0(0,ERD),0(ERC) B-FIELD. 01300000 AR ERD,RA ERD POINTS TOP POSITION OF 01320000 AH ERD,EH01 TRAILING ZERO PORTION. 01340000 EMVCM CH RB,EH01 COMMON ROUTINE TO FILL UP 01360000 BH EMVAA REMAINING B-FIELD WITH ZERO. 01380000 BL EMVRT B=A. 01400000 MVI 0(ERD),X'40' B=A+1. 01420000 B EMVRT 01440000 EMVAA CH RB,EH256 B BIGGER THAN A+1. 01460000 BNH EMVBB 01480000 MVI 0(ERD),X'40' STORE A BLANK, 01500000 EMOVE2 MVC 1(255,ERD),0(ERD) AND EXPAND. 01520000 SH RB,EH256 01540000 AH ERD,EH256 FILL REMAING B-FIELD WITH 'F0' 01560000 B EMVAA TILL B SMALLER THAN 257. 01580000 EMVBB MVI 0(ERD),X'40' REMAINING B SMALLER THAN 257. 01600000 BCTR RB,0 01620000 CH RB,EH00 8349 01626017 BNH EMVRT 8349 01632017 BCTR RB,0 01640000 STC RB,EMV2+1 01660000 EMV2 MVC 1(0,ERD),0(ERD) FILL UP WITH BLANK, 01680000 B EMVRT AND RETURN. 01700000 * A BIGGER THAN B 01720000 EMV03 BAL ERE,EMOVE1 MOVE 256-BYTES FROM A TO B, 01740000 CH RB,EH256 AND UPDATE REGISTERS. 01760000 BNH EMVCC IF B STILL BIGGER THAN 256, 01780000 B EMV03 CONTINUE IT TILL B SMALLER 01800000 EMVCC BCTR RB,0 THAN 257. 01820000 STC RB,EMV3+1 01840000 EMV3 MVC 0(0,ERD),0(ERC) FILL UP WHOLE REMAINING POSITIONS, 01860000 EMVRT LM 14,12,12(13) RESTORE REGISTERS 01880000 B 6(RTREG) AND BRANCH BACK. 01900000 * 01920000 * MOVE TO ALPHABETIC OR ALPHANUMERIC ITEM WITH RIGHT-ALIGNMENT 01940000 * 01960000 EALGN AR ERC,RA FOR GENERALISING WITH 01980000 AR ERD,RB NORMAL MOVE GROUP. 02000000 EAL01 CH RA,EH256 IF 02020000 BNH EAL02 02040000 EALAA BAL ERE,EMVAL IF RA BIGGER THAN 256, 02060000 SH ERC,EH256 SUBTRACT 256 FROM RA,RB,ERC AND 02080000 SH ERD,EH256 ERD,AND 02100000 EX 0,EMOVE1 MOVE 256-BYTES FROM A TO B. 02120000 CR RA,RB TEST IF A BIGGER THAN B. 02140000 BNH EAL01 IF NO, CONTINUE TILL RA SMALLER 02160000 * A BIGGER THAN B THAN 256. 02180000 CH RB,EH256 IF YES, FILL-UP-WITH-ZERO ROUTINE 02200000 BH EALAA IS SKIPPED. 02220000 SR ERC,RB 02240000 SR ERD,RB REPEAT 256-BYTE-MOVE PROCEDURE. 02260000 B EMVCC WHEN RB SMALLER THAN 256, GO TO 02280000 * A SMALLER THAN 256 FINAL MOVE AND RETURN. 02300000 EAL02 SR ERC,RA ERC POINTS TOP POSITION OF A-FIELD 02320000 SR ERD,RA 02340000 SR RB,RA RB CONTAINS REMAINING B-FIELD TOP 02360000 BCTR RA,0 POSITIONS TO BE FILLED 02380000 STC RA,EMV4+1 WITH BLANKS. 02400000 EMV4 MVC 0(0,ERD),0(ERC) MOVE FINAL A-FIELD DATA, 02420000 LR ERD,RY MAKE ERD POINT TOP POSITION OF 02440000 B EMVCM B-FIELD AND GO TO FILL-UP 0. 02460000 * 02480000 * COMMON MOVE AND UPDATING REGISTERS 02500000 * 02520000 EMOVE1 MVC 0(256,ERD),0(ERC) MOVE 256-BYTES FROM A-FIELD TO B. 02540000 AH ERC,EH256 02560000 AH ERD,EH256 02580000 EMVAL SH RA,EH256 THESE 2 SH INSTRUCTIONS ARE USED 02600000 SH RB,EH256 IN RIGHT-ALIGNMENT RTN, TOO. 02620000 BR ERE 02640000 * * * 02660000 * SUBROUTINE FOR MOVE FIGURATIVE CONSTANT TO GROUP ITEM 02680000 * LONGER THAN 256 BYTES 02700000 * * * 02720000 ENTFGC LH RB,0(RTREG) PICK UP DESTFD LENGTH. 02740000 BCTR RB,0 1-BYTE FIGCON IS STORED IN DESTFD. 02760000 EFCGR1 CH RB,EH256 CHECK B-FIELD LENGTH. 02780000 BNH EFCGR2 02800000 MVC 1(256,RY),0(RY) IF LONGER THAN 256, EXPAND FIGCON 02820000 AH RY,EH256 INTO 256 BYTES MORE, AND 02840000 SH RB,EH256 ADJUST REGISTERS. 02860000 B EFCGR1 LOOP TILL LENGTH IS LESS THAN 256. 02880000 EFCGR2 BCTR RB,0 FINISH-UP. 02900000 EX RB,EFCGR3 FILL UP REMAINING POSITIONS 02920000 LM 14,12,12(13) RESTORE REGISTERS 02940000 B 2(RTREG) RETURN. 02960000 EFCGR3 MVC 1(0,RY),0(RY) RETURN. 02980000 * 03000000 * DECLARATIVE SECTION 03020000 * 03040000 EH01 DC H'1' 03060000 EH256 DC H'256' 03080000 EH00 DC H'0' 8349 03090017 RX EQU 0 03100000 RY EQU 2 03120000 RA EQU 1 03140000 RB EQU 5 03160000 ER1 EQU 1 03180000 ER2 EQU 2 03200000 ERC EQU 8 03220000 ERD EQU 9 03240000 RTREG EQU 14 03260000 RETREG EQU 14 03280000 ERE EQU 14 03300000 ERF EQU 5 03320000 END 03340000 ./ ADD SSI=01014057,NAME=IHD02100,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02100 * 00060000 TITLE 'IHD02100 - CLASS TEST SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE PERFORMS THE CLASS TEST ON ALPHANUMERIC FIELDS. * 00140000 * WHEN A CLASS TEST IS SPECIFIED THIS SUBROUTINE DETERMINES IF THE * 00160000 * ITEM CONSISTS OF ALL NUMERIC OR ALL ALPHABETIC CHARACTERS. * 00180000 * THE STATEMENTS: * 00200000 * ALPHABETIC * 00220000 * DATA-NAME IS ---------- * 00240000 * NUMERIC * 00260000 * ------- * 00280000 * WILL ACTIVATE THIS SUBROUTINE * 00300000 * * 00320000 *ENTRY POINTS: * 00340000 * IHD02101 ENTRY POINT CALLING SEQUENCE: * 00360000 * LA 1, ADDRESS-OF-FIELD * 00380000 * LA 0,LENGTH-OF-FIELD * 00400000 * LA 15,IHD02101 * 00420000 * BALR 14,15 * 00440000 * * 00460000 *INPUT: * 00480000 * REGISTER 0 CONTAINS THE LENGTH OF THE FIELD TO BE CHECKED * 00500000 * REGISTER 1 CONTAINS THE ADDRESS OF THE FIELD TO BE CHECKED * 00520000 * * 00540000 *OUTPUT: * 00560000 * THE CONDITION CODE RESULTING FROM THE COMPARE WITH THE APPROPRIA-* 00580000 * TE MASK IS PASSED TO THE MAIN PROGRAM * 00600000 * * 00620000 *EXTERNAL ROUTINES: N/A * 00640000 * * 00660000 *EXITS NORMAL: * 00680000 * NORMAL RETURN TO MAIN PROGRAM: BCR 15,14 * 00700000 * * 00720000 *EXITS ERROR: N/A * 00740000 * * 00760000 *TABLE/WORK AREAS: * 00780000 * WORKA IS A FULL WORD FIELD USED AS WORK AREA * 00800000 * * 00820000 *ATTRIBUTES: * 00840000 * SERIALLY REUSABLE * 00860000 * * 00880000 *NOTES: * 00900000 * THE NEXT SEQUENTIAL INSTRUCTION IN THE MAIN PROGRAM IS A BRANCH ON* 00920000 * CONDITION WITH A PRESET MASK FOR NUMEIC OR ALPHABETIC TEST * 00940000 * 00960000 * 00980000 IHD02100 START 0 RCLST 01000000 ENTRY IHD02101 RCLST 01020000 USING *,15 01040000 RY EQU 0 01060000 RX EQU 1 01080000 IHD02101 STH RY,WORKA+2 01100000 XC WORKA(2),WORKA 01120000 RCLS00 CLI 0(RX),X'40' 01140000 BC 8,RCLS01 01160000 MVN WORKA+1(1),0(RX) 01180000 CLI WORKA+1,X'09' 01200000 BC 2,RCLS05 01220000 CLI 0(RX),X'F0' 01240000 BC 10,RCLS08 01260000 CLI 0(RX),X'E0' 01280000 BC 10,RCLS12 01300000 CLI 0(RX),X'C0' 01320000 BC 4,RCLS05 01340000 CLC WORKA+2(2),ONE 01360000 BC 8,RCLS15 01380000 CH RY,ONE 01400000 BC 8,RCLS20 01420000 CLI WORKA+1,X'00' 01440000 BC 8,RCLS05 01460000 RCLS01 OI WORKA,X'10' 01480000 RCLS02 CLI WORKA,X'11' 01500000 BC 8,RCLS03 01520000 LA RX,1(RX) 01540000 BCT RY,RCLS00 01560000 RCLS03 CLI WORKA,X'10' 01580000 BCR 15,14 01600000 RCLS05 OI WORKA,X'11' 01620000 BC 15,RCLS03 01640000 RCLS08 OI WORKA,X'01' 01660000 BC 15,RCLS02 01680000 RCLS12 CLI 0(RX),X'E2' 01700000 BC 10,RCLS01 01720000 BC 15,RCLS05 01740000 RCLS15 CLI WORKA+1,X'00' 01760000 BC 8,RCLS08 01780000 TM ONE+1,X'01' 01800000 BCR 15,14 01820000 RCLS20 CLI WORKA,X'01' 01840000 BC 8,RCLS03 01860000 CLI WORKA+1,X'00' 01880000 BC 8,RCLS05 01900000 BC 15,RCLS03 01920000 WORKA DC F'0' 01940000 ONE DC H'1' 01960000 END 01980000 ./ ADD SSI=01014057,NAME=IHD02200,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02200 * 00060000 TITLE 'IHD02200 -CONVERT PACKED DECIMAL TO ZONED DECIMAL SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE CONVERTS A PACKED DECIMAL NUMBER TO ZONED DECIMAL * 00140000 * IT IS REQUIRED WHEN ARITHMETIC OPERATIONS ARE PERFORMED IN PACKED * 00160000 * DECIMAL AND THE RECEIVING FIELD IS ZONED. IT IS ALSO REQUIRED IF * 00180000 * THE USER DISPLAYS PACKED FORMAT DATA. * 00200000 * * 00220000 *ENTRY POINTS: * 00240000 * IHD02201 ENTRY POINT CALLING SEQUENCE: * 00260000 * LA 15,=A(IHD02201) * 00280000 * BALR 14,15 * 00300000 * * 00320000 *INPUT: * 00340000 * THE INPUT CONSISTS OF A 10 BYTES PACKED DECIMAL FIELD LOCATED IN * 00360000 * THE GLOBAL TABLE. IT IS ADDRESSABLE BY BASE REGISTER 3 AND A * 00380000 * DISPLACEMENT OF 32. ITS FORMAT IS AS FOLLOW: * 00400000 * ---------------------- -------------- * 00420000 * -DIGIT DIGIT DIGIT DIGIT SIGN - * 00440000 * ---------------------- -------------- * 00460000 * * 00480000 *OUTPUT: * 00500000 * THE OUTPUT IS AN 18 BYTE ZONED DECIMAL FIELD WHICH REPLACES THE * 00520000 * INPUT STREAM * 00540000 * * 00560000 *EXTERNAL ROUTINES: N/A * 00580000 * * 00600000 *EXITS NORMAL: * 00620000 * WHEN THE ENTIRE FIELD IS CONVERTED A BRANCH TO THE MAIN PROGRAM * 00640000 * IS TAKEN WITH THE BRANCH TO THE NEXT SEQUENTIAL INSTRUCTION * 00660000 * BCR 15,14 * 00680000 * * 00700000 *EXITS ERROR: N/A * 00720000 * * 00740000 *TABLE/WORK AREAS: * 00760000 * WORKA CONTAINS THE DATA TO BE CONVERTED * 00780000 * WORKB IS THE WORK AREA FOR THE UNPACKING OPERATION * 00800000 * * 00820000 *ATTRIBUTES: * 00840000 * SERIALLY REUSABLE * 00860000 * * 00880000 *NOTES: * 00900000 * ALTHOUGH THE LENGTH OF THE FIELD IS 10 BYTES, 18 VALID DIGITS IS * 00920000 * MAXIMUM ALLOWED VALUE FOR CONVERSION * 00940000 * 00960000 * 00980000 IHD02200 START 0 PKD 01000000 ENTRY IHD02201 PKDZND 01020000 USING *,15,3 01040000 IHD02201 UNPK WORKB(4),WORKA+8(3) 01060000 UNPK WORKB+3(15),WORKA+10(8) 01080000 MVC WORKA(18),WORKB 01100000 BCR 15,14 01120000 GLTAB EQU IHD02201+4096 01140000 WORKA EQU GLTAB+32 01160000 WORKB EQU GLTAB+56 01180000 END 01200000 ./ ADD SSI=03014059,NAME=IHD02300,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02300 * 00060000 TITLE 'IHD02300 - PERFORM STATEMENT - NESTING, NO DIAGNOSTICS. ' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE CONSISTS OF 3 PARTS REQUIRED WHEN A SINGLE PERFORM* 00140000 * STATEMENT OR NESTED PERFORMS APPEAR IN THE SOURCE PROGRAM. * 00160000 * THE FIRST PART BUILDS A TABLE OF END AND RETURN ADDRESSES OF THE * 00180000 * PERFORM OR NESTED PERFORMS RANGE. * 00200000 * THE SECOND PART CHECKS TO DETERMINE IF THE PERFORM IS COMPLETED * 00220000 * BY COMPARING THE RETURN ADDRESS. THIS PART IS ENTERED EVERY TIME * 00240000 * THERE IS A LABEL IN THE SOURCE PROGRAM. * 00260000 * THE LAST PART DELETES THE ENTRIES FROM THE TABLE EVERY TIME A * 00280000 * PERFORM RANGE IS COMPLETED. * 00300000 * * 00320000 *ENTRY POINTS: * 00340000 * IHD02301 PART 1 ENTRY POINT CALLING SEQUENCE: * 00360000 * LA 15,IHD02301 * 00380000 * BALR 14,15 * 00400000 * L 0,RETURN-ADDRESS * 00420000 * L 0,ENDING ADDRESS * 00440000 * L 0,BEGINNING ADDRESS * 00460000 * IHD02302 PART 2 ENTRY POINT CALLING SEQUENCE: * 00480000 * LA 15,IHD02302 * 00500000 * BALR 14,15 * 00520000 * IHD02304 PART 3 ENTRY POINT CALLING SEQUENCE: * 00540000 * LA 15,IHD02304 * 00560000 * BALR 14,15 * 00580000 * * 00600000 *INPUT: * 00620000 * IHD02301 BUILDS AN INTERNAL TABLE OF ADDRESSES FROM INFORMATION * 00640000 * PASSED IN THE CALLING SEQUENCE * 00660000 * * 00680000 *OUTPUT: * 00700000 * THE ENTRIES MADE IN THE TABLE ARE THE ONLY OUTPUT * 00720000 * * 00740000 *EXTERNAL ROUTINES: N/A * 00760000 * * 00780000 *EXITS NORMAL: * 00800000 * THERE ARE 3 NORMAL EXITS: A. FROM IHD02301 LA 14,12(14) * 00820000 * BR 14 * 00840000 * B. FROM IHD02302 BR 14 * 00860000 * C. FROM IHD02304 BR 14 * 00880000 * * 00900000 *EXITS ERROR: N/A * 00920000 * * 00940000 *TABLE/WORK AREAS: * 00960000 * TABLE AN 80 BYTE AREA WHERE THE ADDRESSES ARE STORED * 00980000 * * 01000000 *ATTRIBUTES: * 01020000 * SERIALLY REUSABLE * 01040000 * * 01060000 *NOTES: * 01080000 * THIS SUBROUTI/E ALLOWS FOR A MAXIMUM OF 10 PERFORMS WITHIN A * 01100000 * PERFORM RANGE * 01120000 * 01140000 * 01160000 IHD02300 START 0 PERFORM SUBROUTINES 01180000 ************************************** 01200000 *** PERFORM OBJECT TIME SUBROUTINE *** 01220000 *** NESTING WITHOUT DIAGNOSTICS *** 01240000 ************************************** 01260000 ENTRY IHD02301 ESTABLISH 01280000 ENTRY IHD02302 RETURN 01300000 ENTRY IHD02304 DELETE 01320000 R1 EQU 1 WORK REGISTER 01340000 R2 EQU 2 WORK REGISTER 01360000 R4 EQU 11 ENDING ADDRESS 01380000 R5 EQU 12 RETURN ADDRESS 01400000 R6 EQU 6 TABLE POINTER 01420000 R7 EQU 7 DISPLACEMENT 01440000 R12 EQU 12 REGISTER 12 01460000 R13 EQU 13 SAVE AREA POINTER 01480000 R14 EQU 14 LINK REGISTER 01500000 R15 EQU 15 SUBROUTINE POINTER 01520000 ***************************** 01540000 *** ESTABLISH NEW PERFORM *** 01560000 ***************************** 01580000 USING *,R15 INFORM ASSEMBLER OF BASE REGISTER 01600000 IHD02301 STM R14,R12,12(R13) STORE ALL REGS IN USER SAVE AREA 01620000 LA R4,176 SPECIFY REGISTER 11 01640000 LA R5,192 SPECIFY REGISTER 12 01660000 EX R5,0(R14) GET RETURN ADDRESS 01680000 EX R4,4(R14) GET ENDING ADDRESS 01700000 LA R6,TABLE POINT TO ADDRESS TABLE 01720000 L R7,NEXT GET DISPLACEMENT TO NEXT TABLE SPOT 01740000 AR R6,R7 ADD NEXT DISPLACEMENT 01760000 ST R4,0(R6) STORE EADD IN TABLE 01780000 ST R5,4(R6) STORE RADD IN TABLE 01800000 LA R7,8(R7) BUMP DISPLACEMENT BY 8 01820000 ST R7,NEXT AND SAVE IT 01840000 LM R14,R12,12(R13) RESTORE ALL REGISTERS 01860000 LA R14,12(R14) BUMP RETURN AROUND PARAMETERS 01880000 BR 14 BACK TO MAIN PROGRAM 01900000 ********************** 01920000 *** DELETE PERFORM *** 01940000 ********************** 01960000 USING *,R15 INFORM ASSEMBLER OF BASE REGISTER 01980000 IHD02304 LA R1,8 CREATE CONSTANT 8 02000000 L R2,NEXT GET NEXT DISPLACEMENT 02020000 SR R2,R1 SUBTRACT 8 FROM DISPLACEMENT 02040000 ST R2,NEXT PUT IT BACK 02060000 BR R14 BACK TO MAIN PROGRAM 02080000 ************************************************ 02100000 *** RETURN-TEST IF END OF THIS PERFORM RANGE *** 02120000 ************************************************ 02140000 USING *,R15 02160000 IHD02302 L R1,NEXT GET TABLE DISPLACEMENT 02180000 LTR R1,R1 ANY ACTIVE PERFORMS 02200000 BZ LEAVE IF NOT-LEAVE 02220000 N R14,HIZERO CLEAR HIBYTE GARBAGE 02240000 C R14,TABLE-8(R1) IS THIS END OF THIS PERFORM RANGE 02260000 BNE LEAVE IF NOT-LEAVE 02280000 L R14,TABLE-4(R1) GET RETURN ADDRESS 02300000 LEAVE BR R14 BACK TO MAIN PROGRAM 02320000 ******************** 02340000 *** DECLARATIVES *** 02360000 ******************** 02380000 TABLE DC 20F'0' 10 EADDS AND RADDS 02400000 NEXT DC F'0' NEXT TABLE DISPLACEMENT 02420000 HIZERO DC X'00FFFFFF' TO CLEAR BIBYTE OF REGISTER 02440000 END 02460000 ./ ADD SSI=01014059,NAME=IHD02400,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02400 * 00060000 TITLE 'IHD02400 - VARIABLE GROUP MOVE SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE IS USED TO MOVE FIELDS WHEN EITHER OR BOTH FIELDS * 00140000 * ARE VARIABLE GROUPS. THE MOVE PROCEEDS FROM LEFT TO RIGHT UNTIL * 00160000 * THE ENTIRE SENDING FIELD IS MOVED. IN CASE OF UNEQUAL FIELDS THE * 00180000 * REMAINING PORTION OF THE RECEIVING FIELD IS BLANKED OUT. THE MOVE* 00200000 * IS DONE IN GROUPS OF 256 BYTES EACH IF THE LENGTH EXCEEDS SUCH * 00220000 * VALUE. * 00240000 * * 00260000 *ENTRY POINTS: * 00280000 * IHD02401 ENTRY POINT CALLING SEQUENCE: * 00300000 * LA 15,IHD02401 * 00320000 * BALR 14,15 * 00340000 * * 00360000 *INPUT: * 00380000 * REGISTER 1 - ADDRESS OF SENDING FIELD * 00400000 * REGISTER 2 - ADDRESS OF RECEIVING FIELD * 00420000 * REGISTER 3 - GLOBAL TABLE * 00440000 * REGISTER 6 - LENGTH OF FIELD TO BE MOVED * 00460000 * * 00480000 *OUTPUT: * 00500000 * RECEIVING FIELD WILL CONTAIN THE DATA IN THE SENDING FIELD * 00520000 * * 00540000 *EXTERNAL ROUTINES: N/A * 00560000 * * 00580000 *EXITS NORMAL: * 00600000 * NORMAL RETURN TO MAIN PROGRAM: BR 14 * 00620000 * * 00640000 *EXITS ERROR: N/A * 00660000 * * 00680000 *TABLE/WORK AREAS: N/A * 00700000 * * 00720000 *ATTRIBUTES: * 00740000 * SERIALLY REUSABLE * 00760000 * * 00780000 *NOTES: * 00800000 * 00820000 * 00840000 IHD02400 START 0 MOV 00860000 ENTRY IHD02401 MOVE 00880000 USING *,15 USE SUBROUTINE POINTER AS BASE 00900000 AD1 EQU 1 ADDRESS OF SENDING FIELD 00920000 AD2 EQU 2 ADDRESS OF RECEIVING FIELD 00940000 RG EQU 3 GLOBAL TABLE POINTER 00960000 LX EQU 4 LX IS OPND2 - OPND1 LENGTH 00980000 LB EQU 5 LB IS NUMBER OF BYTES TO BLANK 01000000 L EQU 6 L IS NUMBER OF BYTES TO MOVE 01020000 ADB EQU 7 ADDRESS TO BLANK 01040000 K EQU 8 CONSTANT 256 01060000 RD EQU 13 SAVE AREA POINTER 01080000 RE EQU 14 RETURN REGISTER 01100000 RF EQU 15 SUBROUTINE POINTER AND BASE 01120000 L1 EQU 32 LENGTH OF SENDING FIELD 01140000 L2 EQU 34 LENGTH OF RECIEVING FIELD 01160000 RJ EQU 36 RIGHT JUSTIFIED SWITCH 01180000 BSW EQU 37 BLANK SWITCH 01200000 IHD02401 STM 14,12,12(RD) STORE REGS IN CALLERS SAVE 01220000 LA K,128 PUT 128 IN REGISTER 01240000 SLL K,1 MAKE CONSTANT 256 01260000 NI BSW(RG),0 TURN OFF BLANK SWITCH 01280000 LH LX,L2(RG) GET OPND2 LENGTH 01300000 SH LX,L1(RG) SUBTRACT OPND1 LENGTH 01320000 BZ M5 FIELDS ARE EQUAL IN LENGTH 01340000 BM M2 SENDING FIELD IS LONGER 01360000 OI BSW(RG),1 TURN ON BLANK SWITCH 01380000 LR LB,LX BYTES TO BLANK 01400000 LR ADB,AD2 ADDRESS TO BLANK 01420000 TM RJ(RG),1 RIGHT JUSTIFIED 01440000 BO M4 GO RIGHT JUSTIFY 01460000 AH ADB,L1(RG) ADD L1 TO ADDRESS TO BLANK 01480000 M5 LH L,L1(RG) LENGTH TO MOVE IS OPND1 01500000 M6 CR L,K COMPARE LENGTH TO 256 01520000 BH M7 GO MOVE 256 BYTES 01540000 LTR L,L IS LENGTH TO MOVE ZERO 01560000 BZ M12 IF YES-SKIP MOVE 01580000 BCTR L,0 MAKE MACHINE LENGTH 01600000 EX L,MOVER MOVE SEND TO RCVING 01620000 M12 TM BSW(RG),1 TEST BALNK SWITCH 01640000 BO M8 GO BLANK REST OF FIELD 01660000 M10 LM 14,12,12(RD) RESTORE REGISTERS 01680000 BR 14 RETURN TO CALLER 01700000 M2 LH L,L2(RG) LENGTH TO MOVE IS OPND2 01720000 TM RJ(RG),1 RIGHT JUSTIFIED 01740000 BZ M6 AD1 STAYS AD1 01760000 SR AD1,LX AD1 IS AD1 PLUS LX-NEGATIVE 01780000 B M6 GO DO MOVE 01800000 M4 AR AD1,LX AD1 IS AD1 PLUS LX 01820000 B M5 GO GET LENGTH OF L1 01840000 M7 MVC 0(256,AD2),0(AD1) MOVE 256 BYTES 01860000 AR AD1,K UP AD1 256 BYTES 01880000 AR AD2,K UP AD2 256 BYTES 01900000 SR L,K DOWN LENGTH TO MOVE 256 01920000 B M6 GO MOVE MORE 01940000 M8 MVI 0(ADB),C' ' MOVE 1 BLANK TO RCVING FIELD 01960000 BCT LB,M9 IS ONE BLANK SUFFICIENT 01980000 B M10 IF YES-GET OUT 02000000 M9 CR LB,K COMPARE BLANKS TO 256 02020000 BH M11 GO BLANK 256 BYTES 02040000 BCTR LB,0 MAKE MACHINE LENGTH 02060000 EX LB,BLANK MOVE BLANKS 02080000 B M10 FINISHED 02100000 M11 MVC 1(256,ADB),0(ADB) BALNK 256 BYTES 02120000 AR ADB,K UP ADDRESS TO BLANK 256 02140000 SR LB,K DOWN BYTES TO BLANK 256 02160000 B M9 GO BLANK MORE 02180000 MOVER MVC 0(0,AD2),0(AD1) MOVE SENDING TO RECEIVING FLD 02200000 BLANK MVC 1(0,ADB),0(ADB) MOVE BLANKS TO RECEIVING 02220000 END 02240000 ./ ADD SSI=01014061,NAME=IHD02500,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02500 * 00060000 TITLE 'IHD02500 - TWO VARIABLE FIELDS COMPARE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE IS USED TO COMPARE TWO FIELDS EITHER OR BOTH OF * 00140000 * WHICH ARE GROUP VARIABLE. THE COMPARE PROCEEDS FROM LEFT TO RIGHT* 00160000 * UNTIL AN UNEQUAL COMPARE IS FOUND OR THE ENTIRE FIELD IS COMPARED.* 00180000 * SINCE THE FIELDS COULD BE VARIABLE THE LONGER FIELD IS USED AS THE* 00200000 * FIRST OPERAND IN THE COMPARE. THE COMPARE IS DONE IN GROUPS OF * 00220000 * 256 BYTES EACH IF THE LENGTH OF THE FIELD IS GREATER * 00240000 * * 00260000 *ENTRY POINTS: * 00280000 * IHD02501 ENTRY POINT CALLING SEQUENCE: * 00300000 * LA 15,IHD02501 * 00320000 * BALR 14,15 * 00340000 * * 00360000 *INPUT: * 00380000 * REGISTER 1 - ADDRESS OF FIELD 1 * 00400000 * REGISTER 2 - ADDRESS OF FIELD 2 * 00420000 * REGISTER 4 - LENGTH OF FIELD 1 * 00440000 * REGISTER 5 - LENGTH OF FIELD 2 * 00460000 * REGISTER 13 - SAVE AREA ADDRESS * 00480000 * * 00500000 *OUTPUT: * 00520000 * THE RESULTANT CONDITION CODE IS PASSED TO THE MAIN PROGRAM * 00540000 * * 00560000 *EXTERNAL ROUTINES: N/A * 00580000 * * 00600000 *EXITS NORMAL: * 00620000 * NORMAL RETURN: BR 14 * 00640000 * * 00660000 *EXITS ERROR: N/A * 00680000 * * 00700000 *TABLE/WORK AREAS: N/A * 00720000 * * 00740000 *ATTRIBUTES: * 00760000 * SERIALLY REUSABLE * 00780000 * * 00800000 *NOTES: * 00820000 * THE LIMITATION OF THE COMPARE INSTRUCTION OF 256 BYTES NECESSITATE* 00840000 * THE USE OF A LOOP TO COMPARE LONGER FIELDS * 00860000 * 00880000 * 00900000 IHD02500 START 0 COM 00920000 ENTRY IHD02501 COMPARE 00940000 USING *,15 INFORM ASSEMBLER OF BASE 00960000 AD1 EQU 1 ADDRESS OF OPERAND1 00980000 AD2 EQU 2 ADDRESS OF OPERAND2 01000000 RG EQU 3 GLOBAL TABLE POINTER 01020000 L1 EQU 4 LENGTH OF OPERAND1 01040000 L2 EQU 5 LENGTH OF OPERAND2 01060000 ADB EQU 6 ADDRESS TO COMPARE FOR BLANKS 01080000 LB EQU 7 LENGTH TO COMPARE FOR BLANKS 01100000 K EQU 8 CONSTANT 256 01120000 L EQU 9 LENGTH TO COMPARE 01140000 RD EQU 13 SAVE AREA POINTER 01160000 RE EQU 14 RETURN REGISTER 01180000 RF EQU 15 SUBROUTINE POINTER AND BASE 01200000 LEN1 EQU 32 LENGTH OF OPERAND1 01220000 LEN2 EQU 34 LENGTH OF OPERAND2 01240000 BSW EQU 36 BLANK SWITCH 01260000 IHD02501 STM 14,12,12(RD) STORE REGS IN CALLERS SAVE 01280000 LA K,128 PUT 128 IN CONSTANT REG 01300000 SLL K,1 DOUBLE IT TO 256 01320000 LH L1,LEN1(RG) LENGTH OF OPND1 01340000 LH L2,LEN2(RG) LENGTH OF OPND2 01360000 CR L1,L2 COMPARE L1 TO L2 01380000 BH M1 OPERAND 1 LONGER 01400000 BL M2 OPERAND 2 LONGER 01420000 NI BSW(RG),0 TURN OFF BLANK SWITCH 01440000 LR L,L1 COMPARE LENGTH IS L1 01460000 M3 CR L,K COMPARE L TO 256 01480000 BC 11,M7 NOT LOW-GO COMPARE 256 BYTES 01500000 LTR L,L IS LENGTH TO COMPARE ZERO 01520000 BZ M8 IF YES-SAY BASIC COMP IS EQUAL 01540000 BCTR L,0 REDUCE L TO MACHINE LENGTH 01560000 EX L,C1 COMPARE OPND1 TO OPND2 01580000 BE M8 GO SEE IF THERE ARE BLNKS TO CK 01600000 M4 LM 14,12,12(RD) RESTORE REGITERS 01620000 BR 14 RETURN TO CALLER 01640000 M1 LR L,L2 COMPARE LENGTH IS L2 01660000 LR LB,L1 LENGTH TO CHECK BLANKS IS 01680000 SR LB,L2 L1-L2 01700000 LR ADB,AD1 ADDRESS TO CHECK BLANKS IS 01720000 AR ADB,L2 AD1 + L2 01740000 OI BSW(RG),1 TURN ON BLANK SWITCH 01760000 B M3 GO COMPARE FIELDS 01780000 M2 LR L,L1 COMPARE LENGTH IS L1 01800000 LR LB,L2 LENGTH TO CHECK BLANKS IS 01820000 SR LB,L1 L2 - L1 01840000 LR ADB,AD2 ADDRESS TO CHECK BLANKS IS 01860000 AR ADB,L1 AD2 + L1 01880000 OI BSW(RG),1 TURN ON BLANK SWITCH 01900000 B M3 GO COMPARE FIELDS 01920000 M7 CLC 0(256,AD1),0(AD2) COMPARE 256 BYTES 01940000 BNE M4 IF UNEQUAL GET OUT 01960000 AR AD1,K UP AD1 256 BYTES 01980000 AR AD2,K UP AD2 256 BYTES 02000000 SR L,K REDUCE LENGTH 256 BYTES 02020000 B M3 GO COMPARE MORE 02040000 M8 TM BSW(RG),1 IS BLANK SWITCH ON 02060000 BZ M4 FIELDS EQUAL-GET OUT 02080000 CLI 0(ADB),C' ' COMPARE ONE BYTE TO BLANK 02100000 BNE M6 GO SET CONDITION CODE 02120000 BCTR LB,0 1 BYTE IS NOW COMPARED 02140000 LTR LB,LB TEST LENGTH REMAINING 02160000 BZ M4 IF ZERO-GET OUT 02180000 M5 CR LB,K COMPARE LENGTH REMAINING TO 256 02200000 BH M9 GO COMPARE 256 BYTES 02220000 BCTR LB,0 GET MACHINE LENGTH 02240000 EX LB,C2 COMPARE FOR BLANKS 02260000 BE M4 IF BLANKS GET OUT 02280000 M6 CR L1,L2 SET CONDITION CODE 02300000 B M4 GET OUT 02320000 M9 CLC 0(256,ADB),1(ADB) COMPARE 256 BYTES 02340000 BNE M6 GO SET CONDITION CODE 02360000 AR ADB,K UP ADDRESS TO BLANK 256 02380000 SR LB,K DOWN LENGTH 256 02400000 B M5 GO CHECK FOR MORE BLANKS 02420000 C1 CLC 0(0,AD1),0(AD2) COMPARE OPND1 TO OPND2 02440000 C2 CLC 0(0,ADB),1(ADB) COMPARE FOR BLANKS 02460000 END 02480000 ./ ADD SSI=01014061,NAME=IHD02600,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02600 * 00060000 TITLE 'IHD02600 - CHECK LENGTH OF FIELD TO BE DISPLAYED' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE CHECKS THE LENGTH OF A FIELD TO BE DISPLAYED TO BE* 00140000 * SURE IT FITS INTO THE DEFINED FIELD. IT IS USED ONLY IF DISPLAY * 00160000 * DATA FIT CHECK IS TO BE DONE BEFORE MOVING DATA TO A DISPLAY BUFFER 00180000 * * 00200000 *ENTRY POINTS: * 00220000 * IHD02601 ENTRY POINT CALLING SEQUENCE: * 00240000 * LA 15,IHD02601 * 00260000 * BALR 14,15 * 00280000 * * 00300000 *INPUT: * 00320000 * REGISTER 1 CONTAINS THE ADDRESS OF THE NEXT AVAILABLE BYTE IN THE* 00340000 * BUFFER. * 00360000 * REGISTER 2 POINTS TO THE DATA TO BE MOVED * 00380000 * REGISTER 3 CONTAINS THE ADDRESS OF THE FIRST BYTE BEYOND THE BUFFER 00400000 * * 00420000 *OUTPUT: * 00440000 * DISPLAY DATA MOVED TO BUFFER AREA * 00460000 * * 00480000 *EXTERNAL ROUTINES: N/A * 00500000 * * 00520000 *EXITS NORMAL: * 00540000 * RETURN TO MAIN PROGRAM: BR 14 * 00560000 * * 00580000 *EXITS ERROR: N/A * 00600000 * * 00620000 *TABLE/WORK AREAS: * 00640000 * WORKW CONTAINS THE PARAMETERS PASSED BY THE MAIN PROGRAM * 00660000 * * 00680000 *ATTRIBUTES: * 00700000 * SERIALLY REUSABLE * 00720000 * * 00740000 *NOTES: * 00760000 * 00780000 * 00800000 IHD02600 START 0 00820000 ENTRY IHD02601 00840000 ********************************************************************** 00860000 *** SUBROUTINE USED TO MOVE DATA TO BUFFER IF USER REQUESTED THAT *** 00880000 *** OBJECT TIME FIT CHECKING BE DONE FOR MOVING DATA TO DISPLAY BUFF*** 00900000 ********************************************************************** 00920000 R1 EQU 1 NEXT BUFFER BYTE AVAILABLE 00940000 R2 EQU 2 DATA POINTER 00960000 R3 EQU 3 ADDRESS OF BYTE BEYOND BUFFER 00980000 R4 EQU 4 BYTES TO MOVE MINUS ONE 01000000 R5 EQU 5 WORK REGISTER 01020000 R13 EQU 13 CALLERS SAVE AREA POINTER 01040000 R14 EQU 14 RETURN ADDRESS 01060000 R15 EQU 15 SUBROUTINE POINTER & BASE REGIS 01080000 WORKW EQU 0 PARAMETER PASSING AREA 01100000 USING *,R15 SPECIFY BASE REGISTER 01120000 IHD02601 STM R3,R5,32(R13) SAVE REGS 2-5 IN CALLER SAVE 01140000 LM R3,R4,WORKW(R3) GET PARAMETERS 01160000 LTR R4,R4 IS LENGTH TO MOVE ZERO 01180000 BM DONE IF SO MOVE NOTHING 01200000 LA R5,1(R1,R4) CALC THEOR NEW NEXT AVAIL BYTE 01220000 CR R5,R3 COMPARE TO BUFFER END PLUS 1 01240000 BH HI GO REDUCE LENGTH TO FIT 01260000 EX R4,MV MOVE WHOLE FIELD TO BUFFER 01280000 LR R1,R5 GET NEW NEXT AVAILABLE BYTE 01300000 DONE LM R3,R5,32(R13) RESTORE REGS 2-5 01320000 BR 14 RETURN TO CALLER 01340000 HI LR R4,R3 ADDRESS OF BYTE AFTER BUFFER 01360000 SR R4,R1 CALCULATE BYTES CAN MOVE 01380000 BCTR R4,0 REDUCE TO MACHINE LENGTH 01400000 LTR R4,R4 IS LENGTH TO MOVE ZERO 01420000 BM DONE IF SO MOVE NOTHING 01440000 EX R4,MV MOVE WHATS POSSIBLE 01460000 LR R1,R3 POINT TO BYTE AFTER BUFFER 01480000 B DONE LEAVE 01500000 MV MVC 0(0,1),0(2) MOVE DATA TO BUFFER 01520000 LTORG 01540000 END 01560000 ./ ADD SSI=01017046,NAME=IHD02700,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02700 * 00060000 TITLE 'IHD02700 - DISPLAY ON SYSPCH SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE IS USED TO WRITE DATA ON SYSPCH WHEN 'DISPLAY ON * 00140000 * SYSPCH' IS SPECIFIED * 00160000 * * 00180000 *ENTRY POINTS: * 00200000 * IHD02701 PART 1 ENTRY POINT CALLING SEQUENCE: * 00220000 * LA 15,IHD02701 * 00240000 * BALR 14,15 * 00260000 * IHD02702 PART 2 ENTRY POINT CALLING SEQUENCE: * 00280000 * LA 15,IHD02702 * 00300000 * BALR 14,15 * 00320000 * * 00340000 *INPUT: * 00360000 * REGISTER 1 CONTAINS THE ADDRESS OF NEXT AVAILABLE BUFFER BYTE * 00380000 * REGISTER 4 CONTAINS THE ADDRESS OF THE BYTE AFTER THE BUFFER * 00400000 * REGISTER 13 CONTAINS THE ADDRESS OF THE SAVE AREA * 00420000 * * 00440000 *OUTPUT: * 00460000 * A MESSAGE IS WRITTEN ON THE DEVICE ASSIGNED TO SYSPCH * 00480000 * * 00500000 *EXTERNAL ROUTINES: N/A * 00520000 * * 00540000 *EXITS NORMAL: * 00560000 * NORMAL RETURN TO MAIN PROGRAM: BR 14 * 00580000 * * 00600000 *EXITS ERROR: N/A * 00620000 * * 00640000 *TABLE/WORK AREAS: * 00660000 * THIS SUBROUTINE USES THE SYSTEM BUFFER AS THE I/O AREA * 00680000 * * 00700000 *ATTRIBUTES: * 00720000 * SERIALLY REUSABLE * 00740000 * * 00760000 *NOTES: * 00780000 * 00800000 * 00820000 IHD02700 START 0 DISPLAY ON SYSPCH 00840000 ENTRY IHD02701 DPCH1 00860000 R0 EQU 0 00880000 R1 EQU 1 NEXT AVAIL BUFF-BYTE POINTER 00900000 R2 EQU 2 WORK REGISTER 00920000 R3 EQU 3 GLOBAL TABLE POINTER 00940000 R4 EQU 4 BYTE AFTER BUFFER POINTER 00960000 R5 EQU 5 00980000 R6 EQU 6 01000000 R7 EQU 7 DCB POINTER 01020000 R8 EQU 8 01040000 R9 EQU 9 01060000 R10 EQU 10 01080000 R11 EQU 11 01100000 R12 EQU 12 01120000 R13 EQU 13 SAVE AREA POINTER 01140000 R14 EQU 14 RETURN ADDRESS 01160000 R15 EQU 15 SUBTN PNTR & BASE REGISTER 01180000 WORKW EQU 0 WORKW DISPLACEMENT 01200000 LRECL EQU 82 DISPLACEMENT OF LRECL IN DCB 01220000 IHD02701 STM R12,R0,12(R13) STORE REGS IN USER SAVE AREA 01240000 BALR R12,0 01260000 USING *,R12 01280000 ST R13,SAVE+4 STORE ADR OF CALLER SAVE AREA 01300000 LA R13,SAVE POINT TO LOCAL SAVE AREA 01320000 DISP1 BC 0,DISP2 OPEN SWITCH 01340000 MVI DISP1+1,X'F0' SET OPEN SWITCH 01360000 OPEN (FILE,(OUTPUT)) OPEN FILE 01380000 DISP2 PUT FILE GET NEXT BUFFER 01400000 MVC 72(8,R1),WORKW(R3) PRGNAM TO BUFFER 01420000 LA R0,80(R1) CALC LIMIT OF BUFFER 01440000 ST R0,WORKW(R3) STORE LIMIT IN GLOBAL TABLE 01460000 MVI 0(R1),C' ' BLANK 1ST POS. OF BUFFER 01480000 MVC 1(71,R1),0(R1) CLE AR BUFFER 01500000 L R13,SAVE+4 LOAD ADR OF CALLER SAVE AREA 01520000 LM R12,R0,12(R13) RESTORE REGS 01540000 BR R14 RETURN TO CALLER 01560000 SAVE DC 18F'0' THIS PROGRAMS SAVE AREA 01580000 FILE DCB DSORG=PS,MACRF=PL,DDNAME=SYSPUNCH,RECFM=F,BFTEK=S, X01600000 LRECL=80,BLKSIZE=80 01620000 END 01640000 ./ ADD SSI=02017049,NAME=IHD02800,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02800 * 00060000 TITLE 'IHD02800 - DISPLAY ON SYSOUT SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS IS A TWO PART SUBROUTINE: 00140000 * IHD02801 WHICH RETURNS THE ADDRESS OF THE NEXT DISPLAY BUFFER* 00160000 * IHD02802 WHICH WRITES THE ACTUAL MESSAGE * 00180000 * * 00200000 *ENTRY POINTS: * 00220000 * IHD02801 ENTRY POINT CALLING SEQUENCE: * 00240000 * LA 15,IHD02801 * 00260000 * BALR 14,15 * 00280000 * * 00300000 *INPUT: * 00320000 * REGISTER 1 CONTAINS THE ADDRESS OF NEXT AVAILABLE BUFFER BYTE * 00340000 * REGISTER 4 CONTAINS THE ADDRESS OF THE BYTE AFTER THE BUFFER * 00360000 * REGISTER 6 CONTAINS THE LINE COUNT * 00380000 * REGISTER 13 CONTAINS THE ADDRESS OF THE SAVE AREA * 00400000 * * 00420000 *OUTPUT: * 00440000 * THE OUTPUT OF IHD02801 IS THE ADDRESS OF NEXT DISPLAY BUFFER IN * 00460000 * REGISTER 1 * 00480000 * * 00500000 *EXTERNAL ROUTINES: N/A * 00520000 * * 00540000 *EXITS NORMAL: * 00560000 * NORMAL RETURN TO MAIN PROGRAM: BR 14 * 00580000 * * 00600000 *EXITS ERROR: N/A * 00620000 * * 00640000 *TABLE/WORK AREAS: * 00660000 * THE SYSTEM BUFFERS ARE USED AS THE I/O AREAS * 00680000 * * 00700000 *ATTRIBUTES: * 00720000 * SERIALLY REUSABLE * 00740000 * * 00760000 *NOTES: * 00780000 * WHEN A PUT IS ISSUED THE CURRENT BUFFER IS FREED AND THE NEXT * 00800000 * BUFFER IS CLEARED * 00820000 * 00840000 * 00860000 * ENTRY 2801 RETURNS THE ADDRESS OF THE NEXT SYSOUT DISPLAY BUFFER 00880000 * IN REG 1, AND THE BUFFER LIMIT IN GLOBAL TABLE AT 00900000 * WORKW. THE CALLER THEN FILLS THE BUFFER, AND WHEN DONE 00920000 * GOES TO ENTRY 2802. 00940000 * ENTRY 2802 ISSUES A PUT MACRO TO FREE THE CURRENT BUFFER, BLANKS 00960000 * THE NEXT BUFFER, AND STORES THE NEXT BUFFER ADDRESS 00980000 * FOR ENTRY 2801 . 01000000 * THERE IS ALWAYS ONE EXTRA PUT OUTSTANDING, BUT ITS BUFFER HAS BEEN 01020000 * CLEARED, SO THAT WHEN THE SCHEDULER FLUSHES IT, IT 01040000 * APPEARS AS A BLANK LINE. 01060000 IHD02800 CSECT 01080000 ENTRY IHD02801,IHD02802 01100000 WORKW EQU 0 WORK W DISPLACEMENT IN GLOBAL TABLE 01120000 LRECL EQU 82 DISPLACEMENT OF LRECL IN DCB 01140000 R0 EQU 0 WORK REG 01160000 R1 EQU 1 POINTS TO BUFFER 01180000 R2 EQU 2 WORK REG 01200000 R3 EQU 3 POINTS TO GLOBAL TABLE OF CALLER 01220000 R4 EQU 4 01240000 R5 EQU 5 01260000 R6 EQU 6 01280000 R7 EQU 7 01300000 R8 EQU 8 01320000 R9 EQU 9 01340000 R10 EQU 10 RETURN REG FOR CLEAR ROUTINE 01360000 R11 EQU 11 BASE REG FOR CLEAR ROUTINE 01380000 R12 EQU 12 BASE REG FOR ENTRY ONE AND TWO 01400000 R13 EQU 13 01420000 R14 EQU 14 01440000 R15 EQU 15 01460000 IHD02801 STM R14,R12,12(R13) 01480000 BALR R12,0 LOAD BASE REG 01500000 USING *,R12 01520000 ST R13,SAVE+4 STORE HIGHER SAVE AREA ADR 01540000 LA R13,SAVE POINT TO LOCAL SAVE AREA 01560000 DISP1 BC 0,DISP2 BRANCH AFTER FIRST TIME 01580000 MVI DISP1+1,X'F0' SET SWITCH 01600000 OPEN (FILE,(OUTPUT)) 01620000 PUT FILE GET FIRST BUFFER 01640000 LA R10,DISP3 LOAD RETURN REG FOR CLEAR ROUTINE 01660000 B CLEAR GO CLEAR FIRST BUFFER 01680000 DISP2 L R1,SAVE POINT TO NEXT BUFFER 01700000 DISP3 LH R0,FILE+LRECL LOAD LENGTH 01720000 AR R0,R1 CALC UPPER LIMIT OF BUFFER 01740000 ST R0,WORKW(R3) STORE UPPER LIMIT IN GLOBAL TABLE 01760000 LA R1,1(R1) BUMP POINTER PAST CONTROL CHAR 01780000 B DISP4 EXIT 01800000 IHD02802 STM R14,R12,12(R13) 01820000 BALR R12,0 LOAD BASE 01840000 USING *,R12 01860000 ST R13,SAVE+4 01880000 LA R13,SAVE POINT TO LOCAL SAVE AREA 01900000 PUT FILE WRITE CURRENT BUFFER AND GET NEXT 01920000 ST R1,SAVE STORE ADR OF NEXT BUFFER 01940000 BAL R10,CLEAR CLEAR NEXT BUFFER 01960000 * *** DISP4 IS THE EXIT FOR BOTH ENTRIES.. CAN'T HAVE RELOCATABLES 01980000 DISP4 L R13,4(R13) POINT TO HIGHER SAVE AREA 02000000 LM R14,R0,12(R13) RESTORE ALL REGS EXCEPT R1 02020000 LM R2,R12,28(R13) 02040000 BR R14 02060000 * *** ROUTINE TO CLEAR BUFFER BEFORE USING 02080000 CLEAR BALR R11,0 LOAD BASE 02100000 USING *,R11 02120000 LH R2,FILE+LRECL LOAD BUFFER LENGTH 02140000 SH R2,TWO DUNK FOR EXECUTE 02160000 MVI 0(R1),C' ' BLANK FIRST POS 02180000 EX R2,MVC BLANK REST 02200000 BR R10 RETURN 02220000 MVC MVC 1(0,R1),0(R1) 02240000 TWO DC H'2' 02260000 SAVE DC 18F'0' SAVE AREA & POINTER TO NEXT BUFFER 02280000 FILE DCB DSORG=PS,MACRF=PL,DDNAME=SYSOUT,RECFM=FA,BFTEK=S 02300000 END 02320000 ./ ADD SSI=02014148,NAME=IHD02900,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD02900 * 00060000 TITLE 'IHD02900 - ACCEPT FROM SYSIPT SUBROUTINE' 00080000 * 0132-0134,0152,0175 6756 00100000 *STATUS: CHANGE LEVEL 10 * 00120000 *FUNCTION/OPERATION: * 00140000 * THIS SUBROUTINE IS USED TO READ A RECORD FROM THE DEVICE ASSIGNED * 00160000 * TO SYSIPT WHEN THE 'ACCEPT' VERB IS USED WITHOUT THE 'UPON' CLAUSE* 00180000 * * 00200000 *ENTRY POINTS: * 00220000 * IHD02901 ENTRY POINT CALLING SEQUENCE: * 00240000 * LA 15,IHD02901 * 00260000 * BALR 14,15 * 00280000 * * 00300000 *INPUT: * 00320000 * REGISTER 1 CONTAINS THE ADDRESS OF THE FIELD * 00340000 * REGISTER 2 CONTAINS THE LENGTH OF THE FIELD * 00360000 * REGISTER 13 CONTAINS THE ADDRESS OF THE SAVE AREA * 00380000 * * 00400000 *OUTPUT: * 00420000 * ONE RECORD IS READ INTO THE USER SPECIFIED FIELD * 00440000 * * 00460000 *EXTERNAL ROUTINES: N/A * 00480000 * * 00500000 *EXITS NORMAL: * 00520000 * NORMAL RETURN TO MAIN PROGRAM: BR 14 * 00540000 * * 00560000 *EXITS ERROR: N/A * 00580000 * * 00600000 *TABLE/WORK AREAS: * 00620000 * THE SYSTEM BUFFER SERVE AS I/O AREA * 00640000 * * 00660000 *ATTRIBUTES: * 00680000 * SERIALLY REUSABLE * 00700000 * * 00720000 *NOTES: * 00740000 * 00760000 * 00780000 IHD02900 START 0 ACCEPT SYSIN 00800000 ENTRY IHD02901 00820000 R0 EQU 0 **** REGISTER EQUATES **** 00840000 R1 EQU 1 ADR OF FIELD --LOADED BY CALLER 00860000 R2 EQU 2 LENGTH OF FIELD--LOADED BY CALLER 00880000 R3 EQU 3 POINTS TO GLOBAL TABLE--NOT USED 00900000 R4 EQU 4 FIELD ADR MOVED HERE FOR LOCAL USE 00920000 R5 EQU 5 00940000 R6 EQU 6 00960000 R7 EQU 7 00980000 R8 EQU 8 01000000 R9 EQU 9 01020000 R10 EQU 10 01040000 R11 EQU 11 WORK REG--ACTUAL SYSIN RECORD LENGTH 01060000 R12 EQU 12 BASE REG 01080000 R13 EQU 13 SAVE AREA FOR CONTROL PROGRAM 01100000 R14 EQU 14 C.P. RETURN REG 01120000 R15 EQU 15 C.P. ENTRY POINT AND WORK REG 01140000 LRECL EQU 82 DISPLACEMENT OF DCBLRECL FIELD 01160000 IHD02901 STM R14,R12,12(R13) STORE REGS IN CALLERS AREA 01180000 BALR R12,0 ESTABLISH ADDRESSABILITY 01200000 USING *,R12 01220000 ST R13,SAVE+4 STORE ADR OF CALLERS SAVE AREA 01240000 LA R13,SAVE POINT TO LOCAL SAVE AREA 01260000 LR R4,R1 POINTER TO FIELD TO NON-C.P. REG 01280000 D1 BC 0,D2 FIRST TIME SWITCH 01300000 MVI D1+1,X'F0' SET FIRST TIME ONLY SWITCH 01320000 GETMAIN R,LV=96 GET 96 BYTES OF CORE 6756 01340000 ST R1,SAVE1 SAVE REGISTER 1 6756 01360000 MVC 0(96,R1),FILE MOVE DCB TO CORE FROM GETMAIN 6756 01380000 LR R6,R1 POINT REG 6 TO DCB 6756 01400000 OPEN ((R6),(INPUT)) OPEN FILE 6756 01420000 D2 L R1,SAVE1 RESTORE REGISTER 1 6756 01440000 GET (R1) 6756 01460000 BCTR R2,0 DUNK LENGTH BY ONE 01480000 LTR R2,R2 TEST FOR LENGTH EQ ZERO OR ONE 01500000 BM D5 IF LENGTH EQ ZERO EXIT. NO DATA MOVE 01520000 MVI 0(R4),C' ' ELSE BLANK 1ST OR ONLY BYTE 01540000 BCTR R2,0 DUNK LENGTH BY ONE MORE 01560000 BZ D3 BR. IF LENGTH EQ 1. CC FROM LTR INST 01580000 EX R2,MOVEB ELSE BLANK REST OF FIELD 01600000 D3 LA R2,2(R2) RESTORE LENGTH 01620000 L R6,SAVE1 POINT REG 6 TO DCB 6756 01640000 LH R11,LRECL(R6) LOAD REG 11 WITH REC LENGTH 6756 01660000 LTR R11,R11 TEST FOR ZERO 01680000 BZ D5 EXIT IF ZERO. NO DATA MOVE 01700000 CR R11,R2 COMP. REC LENGTH TO FIELD LNTH 01720000 BC 12,D4 IF EQ OR LO USE REC LENGTH 01740000 LR R11,R2 ELSE USE FIELD LENGTH IF LOWER 01760000 D4 BCTR R11,0 DUNK LENGTH FOR MOVE 01780000 EX R11,MOVE MOVE DATA TO FIELD 01800000 D5 L R13,SAVE+4 RESTORE POINTER TO CALLER SAVE AREA 01820000 LM R14,R12,12(R13) RESTORE CALLERS REGS 01840000 BR R14 RETURN TO CALLER 01860000 SAVE DC 18F'0' LOCAL SAVE AREA 01880000 SAVE1 DC F'0' SAVE AREA FOR REGISTER 1 6756 01900000 MOVE MVC 0(0,R4),0(R1) 01920000 MOVEB MVC 1(0,R4),0(R4) 01940000 FILE DCB DSORG=PS,MACRF=GL,DDNAME=SYSIN,RECFM=F 01960000 END 01980000 ./ ADD SSI=00017049,NAME=IHD03001,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD03001 00060000 TITLE ' IEP03001 - BUFFER RELEASE SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE IS USED TO FREE BUFFER AREA TO THE DATA MANAGEMENT* 00140000 * SYSTEM. IT IS USED EVERY TIME A CLOSE IS ISSUED. * 00160000 * * 00180000 *ENTRY POINTS: * 00200000 * IEP03001 ENTRY POINT CALLING SEQUENCE: * 00220000 * LA 15,IEP03001 * 00240000 * BALR 14,15 * 00260000 *INPUT: * 00280000 * REGISTER 1 CONTAINS THE ADDRESS OF THE DCB PERTAINING TO THE FILE * 00300000 * BEEN CLOSED * 00320000 * * 00340000 *OUTPUT: * 00360000 * AN AREA EQUAL TO THE I/O AREA USED BY THE FILE BEEN CLOSED IS * 00380000 * RELEASED TO THE CONTROL PROGRAM * 00400000 * * 00420000 *EXTERNAL ROUTINES: N/A * 00440000 * * 00460000 *EXITS NORMAL: * 00480000 * NORMAL RETURN TO MAIN PROGRAM: BR 14 * 00500000 * * 00520000 *EXITS ERROR: N/A * 00540000 * * 00560000 *TABLE/WORK AREAS: N/A * 00580000 * * 00600000 *ATTRIBUTES: * 00620000 * SERIALLY REUSABLE * 00640000 * * 00660000 *NOTES: * 00680000 * 00700000 * 00720000 IHD03001 CSECT 00740000 USING *,2 00760000 LR 2,15 00780000 TM 23(1),1 BUFCB ADDR? 00800000 BCR 1,14 NO-RETURN 00820000 ST 14,WORK 00840000 FREEPOOL (1) 00860000 L 14,WORK 00880000 BR 14 00900000 WORK DC F'0' 00920000 END 00940000 ./ ADD SSI=01011180,NAME=IHD03002,SOURCE=0 *( 5081 00005020 * 005000,007800,011400,012400 5081 00010020 *) 5081 00015020 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03002 00060000 TITLE 'IHD03002---FILL LAST TRACK OF RELATIVE DATA SET' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * COMPLETE LAST TRACK OF RELATIVE DATA SET WITH DUMMY RECORDS. 00140000 *ENTRY POINTS: 00160000 * IHD03002 ENTERED FORM COBOL OBJECT PROGRAM VIA BALR 14,15 00180000 *INPUT: N/A 00200000 *OUTPUT: N/A 00220000 *EXTERNAL ROUTINES: N/A 00240000 *EXITS NORMAL: 00260000 * RETURN VIA REGISTER 14. 00280000 *EXITS ERROR: N/A 00300000 *TABLE/WORK AREAS: N/A 00320000 *ATTRIBUTES: N/A 00340000 *NOTES: 00360000 * 00380000 * 1. IF OPENED INPUT EXIT IMMEDIATELY. 00400000 * 2. IF OUTPUT WRITE DUMMY RECORDS UNTIL TRACK FULL. 00420000 * 00440000 IHD03002 START 0 ENTRY POINT 00460000 USING *,R15 00480000 STM R10,R14,SV 5081 00500020 LR R12,R15 00520000 DROP R15 00540000 USING IHD03002,R12 00560000 * 00580000 LR R2,R1 POINT DCB 00600000 TM MACRF(R2),X'20' INPUT FILE 00620000 BO CLS BR. YES 00640000 * 00660000 * WRITE DUMMY RECORDS. 00680000 * 00700000 LA R1,DECB(R2) POINT DECB 00720000 MVI TYPE+1(R2),SD WRITE DUMMY TYPE 00740000 TM 8(R1),X'80' LAST TRK. FULL 00760000 BO CLS BR. YES 00780000 L R10,AREAD(R2) 5081 00786020 MVI 0(R10),X'FF' 5081 00792020 * 00800000 LP EQU * 00820000 L R15,RDWR(R2) 00840000 BALR R14,R15 WRITE 00860000 LR R11,R15 SAVE RETR. CODE 00880000 L R15,CHK(R2) 00900000 BALR R14,R15 CHECK 00920000 LTR R11,R11 RETR. CODE = 0 00940000 BZ LP BR. YES 00960000 * 00980000 * FREE BUFFER AND RETURN. 01000000 * 01020000 CLS EQU * 01040000 LH R0,BUFL(R2) BUFFER LEN. 01060000 L R1,AREAD(R2) BUFFER ADDR. 01080000 FREEMAIN R,LV=(0),A=(1) 01100000 LR R1,R2 01120000 LM R10,R14,SV 5081 01140020 BR R14 RETURN 01160000 * 01180000 * CONSTANTS AND EQUATES. 01200000 * 01220000 SV DC 5F'0' 5081 01230020 R10 EQU 10 5081 01240020 * 01260000 R0 EQU 0 01280000 SD EQU X'10' 01300000 R2 EQU 2 01320000 R1 EQU 1 01340000 R15 EQU 15 01360000 R14 EQU 14 01380000 R12 EQU 12 01400000 R11 EQU 11 01420000 BUFL EQU 24 01440000 AREAD EQU 100 01460000 DECB EQU 88 01480000 TYPE EQU 92 01500000 MACRF EQU 42 01520000 CHK EQU 52 01540000 RDWR EQU 48 01560000 END 01580000 ./ ADD SSI=00017057,NAME=IHD03004,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03004 00060000 TITLE 'IHD03004---ACQUIRE 1REA TO CREATE DIRECT ORGANIZATION FILES' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * ALLOCATE BUFFER FOR BSAM DIRECT. 00140000 *ENTRY POINTS: 00160000 * IHD03004 ENTERED FORM COBOL OBJECT PROGRAM VIA BALR 14,15 00180000 *INPUT: N/A 00200000 *OUTPUT: N/A 00220000 *EXTERNAL ROUTINES: N/A 00240000 *EXITS NORMAL: 00260000 * RETURN VIA REGISTER 14. 00280000 *EXITS ERROR: N/A 00300000 *TABLE/WORK AREAS: N/A 00320000 *ATTRIBUTES: N/A 00340000 *NOTES: 00360000 * 00380000 * 1. PICK UP DCBBUFL AND ISSUE GETMAIN FOR THAT AMOUNT. 00400000 * 2. ROUND UP DCBKEYLE TO NEXT MULTIPLE OF 8, ADD TO AREA 00420000 * ADDRESS AND USE AS BASE LOCATOR VALUE. 00440000 * 00460000 * 3. SUBTRACT ACTUAL DCBKEYLE FROM ABOVE AND STORE IN 00480000 * DECB AREA FIELD. 00500000 * 00520000 * INITIALIZATION AND HOUSEKEEPING. 00540000 * 00560000 IHD03004 START 0 ENTRY POINT 00580000 USING *,R15 00600000 STM R14,R12,12(R13) SAVE REGS. 00620000 LR R2,R1 POINT DCB 00640000 * 00660000 * PICK UP DCBKEYLE AND ROUND UP. 00680000 * 00700000 XR R3,R3 00720000 IC R3,KEYLE(R2) KEY LEN. 00740000 LR R4,R3 00760000 LR R5,R3 00780000 LP EQU * 00800000 SH R5,H8 COMPUTE KEY LEN. MOD8 00820000 BP LP 00840000 LCR R5,R5 00860000 AR R4,R5 00880000 * 00900000 * GET STORAGE FOR BUFFER. 00920000 * 00940000 LH R0,BUFL(R2) BUF. LEN. 00960000 GETMAIN R,LV=(0) 00980000 ST R1,BUFHLD(R2) KEEP AREA ADDR. 01000000 * 01020000 * COMPUTE BASE LOCATOR VALUE FOR DATA ON DOUBLE WORD BOUNDARY. 01040000 * 01060000 AR R1,R4 B. L. VALUE 01080000 LR R5,R1 01100000 SR R5,R3 01120000 ST R5,AREAD(R2) DECB AREA FIELD 01140000 * 01160000 * RETURN TO CALLER. 01180000 * 01200000 ST R1,24(R13) RETURN VALUE IN REG. 1 01220000 LM R14,R12,12(R13) 01240000 BR R14 01260000 * 01280000 * CONSTANTS AND EQUATES. 01300000 * 01320000 H8 DC H'8' 01340000 * 01360000 KEYLE EQU 16 01380000 BUFHLD EQU 108 01400000 BUFL EQU 24 01420000 AREAD EQU 100 01440000 * 01460000 R0 EQU 0 01480000 R1 EQU 1 01500000 R2 EQU 2 01520000 R3 EQU 3 01540000 R4 EQU 4 01560000 R5 EQU 5 01580000 R12 EQU 12 01600000 R13 EQU 13 01620000 R14 EQU 14 01640000 R15 EQU 15 01660000 END 01680000 ./ ADD SSI=01016001,NAME=IHD03008,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03008 00060000 TITLE 'IHD03008---INIT. BALANCE OF DIRECT DATA SET BEFORE CLOSING' 00080000 *STATUS CHANGE LEVEL 10 00100000 *STATUSO CHANGE LEVEL 21 9112 00120000 *7058,0158 9112 00140000 *FUNCTION/OPERATION: 00160000 * INITIALIZE BALANCE OF DIRECT DATA SET BEFORE CLOSE. 00180000 *ENTRY POINTS: 00200000 * IHD03008: CALLED FROM COBOL PROGRAM VIA BALR 14,15 00220000 *INPUT: N/A 00240000 *OUTPUT: N/A 00260000 *EXTERNAL ROUTINES: N/A 00280000 *EXITS NORMAL: 00300000 * RETURN TO COBOL PROGRAM WHEN FINISHED. 00320000 *EXITS ERROR: N/A 00340000 *TABLE/WORK AREAS: N/A 00360000 *ATTRIBUTES: N/A 00380000 *NOTES: 00400000 * 00420000 * 1. IF FILE-LIMIT SPECIFIED FILL UNUSED TRACKS WITH DUMMY 00440000 * OR CAPACITY RECORDS. 00460000 * 2. OTHERWISE COMPLETE CURRENT TRACK AND EXIT. 00480000 * 00500000 IHD03008 START 0 ENTRY POINT 00520000 USING *,R15 00540000 STM R11,R14,SV 00560000 LR R12,R15 00580000 DROP R15 00600000 USING IHD03008,R12 00620000 * 00640000 LR R2,R1 POINT DCB 00660000 TM MACRF(R2),X'20' INPUT FILE 00680000 BO CLS BR. YES 00700000 LA R1,DECB(R2) POINT DECB 00720000 * 00740000 FILLUP EQU * 00760000 CLC FLIM(4,R2),AKWK(R2) FILE-LIMIT REACHED 00780000 BL CLS BR. YES 00800000 CLI RECFM(R2),X'81' F-TYPE 00820000 BE WD BR. YES 00840000 * 00860000 * WRITE CAPACITY RECORD. 00880000 * 00900000 MVI TYPE+1(R2),SZ WRITE CAP. TYPE 00920000 L R15,RDWR(R2) 00940000 BALR R14,R15 WRITE 00960000 L R15,CHK(R2) 00980000 BALR R14,R15 CHECK 01000000 * 01020000 * UPDATE CURRENT TRACK NUMBER. 01040000 * 01060000 UPAK EQU * 01080000 L R0,AKWK(R2) ADD 1 TO TRK. NO. 01100000 A R0,F1 01120000 ST R0,AKWK(R2) 01140000 B FILLUP CK. FOR MORE TRKS. 01160000 * 01180000 * WRITE DUMMY RECORDS. 01200000 * 01220000 WD EQU * 01240000 MVI TYPE+1(R2),SD WRITE DUMMY TYPE 01260000 LP EQU * 01280000 L R15,RDWR(R2) 01300000 BALR R14,R15 WRITE 01320000 LR R11,R15 SAVE RET. CODE 01340000 L R15,CHK(R2) 01360000 BALR R14,R15 CHECJ 01380000 LTR R11,R11 RET. CODE 0 01400000 BZ LP BR. YES 01420000 B UPAK UP TRK. NO. 01440000 * 01460000 * RETURN TO MAIN PROGRAM. 01480000 * 01500000 CLS EQU * 01520000 LH R0,BUFL(R2) BUFFER LEN. 01540000 L R1,BUFHLD(R2) BUFFER ADDR. 01560000 FREEMAIN R,LV=(0),A=(1) FREE BUFFER 01580000 LR R1,R2 01600000 MVC AKWK(4,R1),FZERO RESET INITIAL TRACK NO. 9112 01620000 LM R11,R14,SV 01640000 BR R14 RETURN 01660000 * 01680000 * CONSTANTS AND EQUATES. 01700000 * 01720000 SV DC 4F'0' 01740000 F1 DC F'1' 01760000 FZERO DC F'0' USED TO RESET INTIAL TRACK NO. 9112 01780000 * 01800000 R11 EQU 11 01820000 R12 EQU 12 01840000 R14 EQU 14 01860000 R15 EQU 15 01880000 R0 EQU 0 01900000 R1 EQU 1 01920000 R2 EQU 2 01940000 SZ EQU X'04' 01960000 SD EQU X'10' 01980000 MACRF EQU 42 02000000 DECB EQU 88 02020000 RECFM EQU 36 02040000 CHK EQU 52 02060000 RDWR EQU 48 02080000 AKWK EQU 124 02100000 TYPE EQU 92 02120000 BUFL EQU 24 02140000 BUFHLD EQU 108 02160000 FLIM EQU 112 02180000 END 02200000 ./ ADD SSI=01011180,NAME=IHD03101,SOURCE=0 *( 00001001 *0793009016-009064,009820 6527 00008020 *) 00015015 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03101 00060000 TITLE 'IHD03101---HANDLE SYNAD FOR QISAM' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * ANALIZE SYNCHRONOUS I/O ERROR ON QISAM FILE. 00140000 * TAKE USE AFTER STANDARD ERROR OR INVALID KEY EXIT. 00160000 *ENTRY POINTS: 00180000 * IHD03101: ENTERED FROM DATA MANAGEMENT VIA THE DCBSYNAD EXIT. 00200000 *INPUT: N/A 00220000 *OUTPUT: N/A 00240000 *EXTERNAL ROUTINES: N/A 00260000 *EXITS NORMAL: 00280000 * BRANCH VIA REGISTER 2 IF INVALID KEY. 00300000 * BRANCH TO USE AFTER STANDARD ERROR ROUTINE. 00320000 *EXITS ERROR: 00340000 * BRANCH VIA REGISTER 14 IF NO EXIT WAS PROVIDED. 00360000 *TABLE/WORK AREAS: N/A 00380000 *ATTRIBUTES: N/A 00400000 *NOTES: 00420000 * 00440000 * 1. IF BITS 0 OR 1 OF DCBEXCD2 ARE ON BRANCH TO INVALID 00460000 * KEY ADDRESS PASSED IN REGISTER 2. 00480000 * 2. OTHERWISE TAKE USE AFTER STANDARD ERROR EXIT IF 00500000 * GIVEN. 00520000 * 3. OTHERWISE BRANCH TO ADDRESS PASSED IN REGISTER 14. 00540000 * 00560000 IHD03101 START 0 ENTRY POINT 00580000 USING *,R15 00600000 ST R2,HLD 00620000 L R2,16(3) DCB ADDR. FROM WORKX 00640000 S R2,F20 POINT DCB MINUS 20 00660000 STM R14,R1,0(R2) SAVE REGS. 14, 15, 0, 1 00680000 STM 3,1,HLD+4 FOR DEBUGGING PURPOSES 2268 00700015 CLC HLD+1(3),HLD+53 IS A(INV KEY RTN) = A(IHD03101) 4651 00704001 * HLD+1=R2=INV KEY RTN 4651 00708001 * HLD+53=R15=IHD03101 4651 00712001 BE TWOOPENS YES, ISSUE A DIAGNOSTIC AND RETURN 4651 00716001 TM EXCD2+20(R2),X'C0' CK. BITS 0 AND 1 00720000 BZ USE5 BR. NEITHER 00740000 L R2,HLD 00760000 BR R2 BR. INV. KEY ADDR. 00780000 * 00800000 USE5 EQU * 00820000 TM 19(R2),X'01' EXIT GIVEN 00840000 BO SYNADMSG NO INV KEY OR USE EXITS 2268 00850015 * ISSUE SYNADAF AND ABEND 2268 00860015 L R15,16(R2) 00880000 BR R15 TAKE USE EXIT 00900000 SYNADMSG L 1,16(3) PUTS A(DCB) INTO REG1 2268 00901015 SYNADAF ACSMETH=QISAM 6527 00901420 MVI LENGTH+1,57 LENGTH OF MESSAGE + 4 6527 00901820 MVC BUFFER(35),49(1) FIRST PART OF SYNADAF MSG. 6527 00902220 MVC BUFFER+35(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 00902620 LR 6,1 SAVE POINTER TO SYNADAF MSG. 6527 00903020 LA 1,LENGTH POINT TO MESSAGE 6527 00903420 LR 7,15 SAVE R15 6527 00903820 SVC 35 ISSUE MESSAGE 6527 00904220 LR 15,7 RESTORE R15 6527 00904620 MVI LENGTH+1,66 LENGTH OF MESSAGE + 4 6527 00905020 MVC BUFFER(44),84(6) REST OF SYNADAF MSG. 6527 00905420 MVC BUFFER+44(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 00905820 LA 1,LENGTH POINT TO MESSAGE 000D 00907000 SVC 35 ISSUE MESSAGE 000D 00907600 LR 15,7 RESTORE R15 000D 00908200 SYNADRLS RLSE MSG & SAVE AREA 2268 00910015 RETURN LM 3,1,HLD+4 4651 00911001 BR 14 2268 00912015 TWOOPENS LA 1,OPENMSG PT TO OPEN OUTPUT TWICE MSG 4651 00913001 LR 7,15 4651 00914001 SVC 35 ISSUE MSG ON CONSOLE 4651 00915001 LR 15,7 4651 00916001 B RETURN 4651 00917001 * 00920000 * CONSTANTS AND EQUATES. 00940000 * 00960000 HLD DC 16F'0' FOR DEBUGGING PURPOSES 2268 00970015 LENGTH DC X'00008000' LENGTH AND FLAG FOR WTO 000D 00974000 MESSAGE DC C'IHD980I I/O ERROR ' 000D 00978000 BUFFER DC 48X'00' BUFFER AREA 6527 00982020 OPENMSG DC X'00458000' FLAG AND LENGTH 000D 00986000 DC C'IHD984I AN ISAM FILE MAY NOT BE OPENED FOR ' 4651 00994001 DC C'OUTPUT MORE THAN ONCE.' 4651 00996001 ROUTDESC DC X'02000020' ROUTING AND DESCRIPTOR CODES 000D 00998000 F20 DC F'20' 01000000 * 01020000 EXCD2 EQU 81 01040000 R2 EQU 2 01060000 R14 EQU 14 01080000 R15 EQU 15 01100000 R1 EQU 1 01120000 END 01140000 ./ ADD SSI=01011180,NAME=IHD03102,SOURCE=0 *( 00004015 *0794012817-012873,013680 6527 00010020 *) 00016015 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03102 00060000 TITLE 'IHD03102---WAIT AND CHECK I/O OPERATION FOR BISAM' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * CHECK I/O OPERATION ON BISAM FILES. 00140000 * TAKE USE AFTER STANDARD ERROR OR INVALID KEY EXIT. 00160000 *ENTRY POINTS: 00180000 * IHD03102: ENTERED FROM MAIN PROGRAM AFTER I/O VIA BALR 14,15. 00200000 *INPUT: N/A 00220000 *OUTPUT: N/A 00240000 *EXTERNAL ROUTINES: N/A 00260000 *EXITS NORMAL: 00280000 * BRANCH VIA REGISTER 2 IF INVALID KEY. 00300000 * BRANCH TO USE AFTER STANDARD ERROR ROUTINE. 00320000 *EXITS ERROR: 00340000 * BRANCH VIA REGISTER 14 IF NO EXIT WAS PROVIDED. 00360000 *TABLE/WORK AREAS: N/A 00380000 *ATTRIBUTES: N/A 00400000 *NOTES: 00420000 * 00440000 * 1. WAIT FOR COMPLETION OF READ OR WRITE. 00460000 * 2. CHECK ECB FOR NORMAL COMPLETION. 00480000 * 3. CHECK BITS 0, 2 AND 7 OF BYTE 24 OF DECB FOR 00500000 * INVALID KEY CONDITIONS. 00520000 * 4. TAKE INVALID KEY OR USE AFTER STANDARD ERROR 00540000 * EXITS WHEN APPLICABLE. 00560000 * 00580000 * THE INVALID KEY ADDRESS IS IN REGISTER 2 AND THE 00600000 * DECB ADDRESS IS IN REGISTER 1. 00620000 * 00640000 IHD03102 START 0 ENTRY POINT 00660000 USING *,R15 00680000 STM 12,11,SV SAVE ALL REGS 2276 00700015 LR R12,R15 00720000 USING IHD03102,R12 00740000 DROP R15 00760000 * 00780000 * WAIT FOR COMPLETION OF I/O REQUEST. 00800000 * 00820000 WAIT ECB=(1) 00840000 LM R12,R1,SV 00860000 USING IHD03102,R15 00880000 DROP R12 00900000 CLI 5(R1),X'04' TEST FOR WRITE 3607 00908015 BNE TSTCOMP NO 3607 00916015 MVC 12(4,R1),32(R1) RESET POINTER IN DECB 3607 00924015 TSTCOMP TM EXCOD(R1),X'FD' CHECK IF SUCCESSFUL 3607 00932015 BCR 8,R14 RETURN IF YES 00940000 * 00960000 * CHECK FOR INVALID KEY CONDITION. 00980000 * 01000000 TM EXCOD(R1),X'A1' BITS 0, 2, 7 01020000 BCR 7,R2 INV. KEY IF ANY 01040000 * 01060000 * CHECK IF USE AFTER STANDARD ERROR ADDRESS PROVIDED AND 01080000 * BRANCH. 01100000 * 01120000 USE5 EQU * 01140000 LR R2,R1 01160000 S R2,F272 POINT DCB MINUS 20 01180000 STM R14,R1,0(R2) SAVE REGS. 14, 15, 0, 1 01200000 TM 19(R2),X'01' USE EXIT GIVEN 01220000 BC 1,SYNADMSG ISSUE MSG AND RETURN 2276 01240015 L R15,16(R2) 01260000 BR R15 TAKE USE EXIT 01280000 SYNADMSG L 0,SV+20 SET UP REG0 FOR SYNADAF A(DECB) 2276 01281015 LA 2,20(2) ADD 20 TO R2 TO GET A(DCB) 6527 01281420 LR 1,2 SET UP R1 FOR SYNADAF 6527 01281820 SYNADAF ACSMETH=BISAM 6527 01282220 MVI LENGTH+1,57 LENGTH OF MESSAGE + 4 6527 01282620 MVC BUFFER(35),49(1) FIRST PART OF SYNADAF MSG. 6527 01283020 MVC BUFFER+35(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 01283420 LR 6,1 SAVE POINTER TO SYNADAF MSG. 6527 01283820 LA 1,LENGTH POINT TO MESSAGE 6527 01284220 LR 7,15 SAVE R15 6527 01284620 SVC 35 ISSUE MESSAGE 6527 01285020 LR 15,7 RESTORE R15 6527 01285420 MVI LENGTH+1,66 LENGTH OF MESSAGE + 4 6527 01285820 MVC BUFFER(44),84(6) REST OF SYNADAF MSG. 6527 01286220 MVC BUFFER+44(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 01286620 LA 1,LENGTH POINT TO MESSAGE 000D 01288000 SVC 35 ISSUE MESSAGE 000D 01288700 LR 15,7 RESTORE R15 000D 01289400 SYNADRLS RELSE MSG & SAVEAREA 2276 01291015 LM 12,11,SV 2276 01292015 BR 14 2276 01293015 * 01300000 * CONSTANTS AND EQUATES. 01320000 * 01340000 SV DC 16F'0' SAVEAREA FOR ALL REGS 2276 01350015 LENGTH DC X'00008000' LENGTH AND FLAG FOR WTO 000D 01356000 MESSAGE DC C'IHD981I I/O ERROR ' 000D 01362000 BUFFER DC 48X'00' BUFFER AREA 6527 01368020 ROUTDESC DC X'02000020' ROUTING AND DESCRIPTOR CODES 000D 01374000 F272 DC F'272' 01380000 * 01400000 EXCOD EQU 24 01420000 * 01440000 R1 EQU 1 01460000 R2 EQU 2 01480000 R12 EQU 12 01500000 R13 EQU 13 01520000 R14 EQU 14 01540000 R15 EQU 15 01560000 END 01580000 ./ ADD SSI=01011195,NAME=IHD03104,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03104 00060000 *( 00065000 *0794006780-006940,007720 6527 00070020 *) 00075000 TITLE 'IHD03104---HANDLE SYNAD FOR QSAM AND BSAM' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * ANALIZE SYNCHRONOUS I/O ERROR ON QSAM AND BSAM FILES. 00140000 * TAKE USE AFTER STANDARD ERROR EXIT. 00160000 *ENTRY POINTS: 00180000 * IHD03104: ENTERED FROM DATA MANAGEMENT VIA THE DCBSYNAD EXIT. 00200000 *INPUT: N/A 00220000 *OUTPUT: N/A 00240000 *EXTERNAL ROUTINES: N/A 00260000 *EXITS NORMAL: 00280000 * BRANCH TO USE AFTER STANDARD ERROR ROUTINE. 00300000 *EXITS ERROR: 00320000 * BRANCH VIA REGISTER 14 IF NO EXIT WAS PROVIDED. 00340000 *TABLE/WORK AREAS: N/A 00360000 *ATTRIBUTES: N/A 00380000 *NOTES: 00400000 * 00420000 * 1. IF USE AFTER STANDARD ERROR PROVIDED SAVE REGISTERS 14, 15, 00440000 * 0 AND 1 AND BRANCH TO ADDRESS PROVIDED. 00460000 * 2. OTHERWISE RETURN TO DATA MANAGEMENT. 00480000 * 00500000 IHD03104 START 0 00520000 USING *,R15 00540000 STM 12,11,SAVEREGS 4986 00550000 LR R2,R1 00560000 S R2,F20 POINT DCB MINUS 20 00580000 TM 19(R2),X'01' ADDR. GIVEN 00600000 BC 1,SYNADMSG ISSUE SYNADAF,THEN RETURN 4986 00640000 L R15,16(R2) LOAD ADDR. 00660000 BR R15 BR. TO USER UTINE 00662000 SYNADMSG TM 42(R1),X'20' IF BIT 2 OF BYTE 42 (DECIMAL) 4986 00664000 BO BSAMSYND CALLED DCBMACR FIELD IS ZERO 4986 00666000 TM 43(R1),X'20' THE ACCESS METHOD IS QSAM 4986 00668000 BO BSAMSYND ELSE IT IS BSAM 4986 00670000 SYNADAF ACSMETH=QSAM 4986 00672000 B COMPRESS 4986 00674000 BSAMSYND SYNADAF ACSMETH=BSAM 4986 00676000 COMPRESS EQU * 6527 00677020 MVI LENGTH+1,57 LENGTH OF MESSAGE + 4 6527 00678020 MVC BUFFER(35),49(1) FIRST PART OF SYNADAF MSG. 6527 00679020 MVC BUFFER+35(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 00680020 LR 6,1 SAVE POINTER TO SYNADAF MSG. 6527 00681020 LA 1,LENGTH POINT TO MESSAGE 6527 00682020 LR 7,15 SAVE R15 6527 00683020 SVC 35 ISSUE MESSAGE 6527 00684020 LR 15,7 RESTORE R15 6527 00685020 MVI LENGTH+1,66 LENGTH OF MESSAGE + 4 6527 00686020 MVC BUFFER(44),84(6) REST OF SYNADAF MSG. 6527 00687020 MVC BUFFER+44(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 00688020 LA 1,LENGTH POINT TO MESSAGE 000D 00696000 SVC 35 ISSUE MESSAGE 000D 00698000 LR 15,7 RESTORE R15 000D 00700000 SYNADRLS RLSE MSG & SAVE AREA 4986 00702000 LM 12,11,SAVEREGS RESTRE REGS 4986 00704000 BR R14 RETURN TO DATA MGMT 4986 00706000 * 00708000 * CONSTANTS AND EQUATES. 00720000 * 00740000 F20 DC F'20' 00760000 SAVEREGS DC 16F'0' 4986 00763000 LENGTH DC X'00008000' LENGTH AND FLAG FOR WTO 000D 00766000 MESSAGE DC C'IHD981I I/O ERROR ' 000D 00769000 BUFFER DC 48X'00' BUFFER AREA 6527 00772020 ROUTDESC DC X'02000020' ROUTING AND DESCRIPTOR CODES 000D 00775000 * 00780000 R0 EQU 0 00800000 R1 EQU 1 00820000 R2 EQU 2 00840000 R14 EQU 14 00860000 R15 EQU 15 00880000 END 00900000 ./ ADD SSI=01011180,NAME=IHD03108,SOURCE=0 *( 00001001 *0794009940-010120,011040 6527 00002020 *) 00003001 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03108 00060000 TITLE 'IHD03108---HANDLE SYNAD FOR BDAM' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * ANALIZE SYNCHRONOUS I/O ERROR ON BDAM FILES. 00140000 * TAKE USE AFTER STANDARD ERROR OR INVALID KEY EXIT. 00160000 *ENTRY POINTS: 00180000 * IHD03108: ENTERED FROM DATA MANAGEMENT VIA THE DCBSYNAD EXIT. 00200000 *INPUT: N/A 00220000 *OUTPUT: N/A 00240000 *EXTERNAL ROUTINES: N/A 00260000 *EXITS NORMAL: 00280000 * BRANCH VIA REGISTER 2 IF INVALID KEY. 00300000 * BRANCH TO USE AFTER STANDARD ERROR ROUTINE. 00320000 *EXITS ERROR: 00340000 * BRANCH VIA REGISTER 14 IF NO EXIT WAS PROVIDED. 00360000 *TABLE/WORK AREAS: N/A 00380000 *ATTRIBUTES: N/A 00400000 *NOTES: 00420000 * 00440000 * 1. BITS 8, 10, 19 AND 23 OF THE ECB INDICATE AN INVALID 00460000 * KEY CONDITION AND A BRANCH TO THE ADDRESS PASSED IN 00480000 * REGISTER 2 IS TAKEN. 00500000 * 2. ALL OTHER CONDITIONS CAUSE A BRANCH TO THE USE AFTER 00520000 * STANDARD ERROR ROUTINE IF PROVIDED. OTHERWISE RETURN TO 00540000 * DATA MANAGEMENT. 00560000 * 3. REGISTERS 14, 15, 0 AND 1 ARE ALWAYS SAVED. 00580000 * 00600000 IHD03108 START 0 00620000 USING *,R15 00640000 ST R2,HOLD 00660000 STM 3,1,HOLD+4 4986 00670000 LR R2,R1 00680000 S R2,F20 POINT TO DCB MINUS 20 00700000 STM R14,R1,0(R2) SAVE 14, 15, 0, 1 00720000 TM ECB+1(R1),X'A0' BITS 8 OR 10 00740000 BC 7,IK BR. YES 00760000 TM ECB+1(R1),X'10' BIT 11 00780000 BZ USE5 BR. NO 00800000 TM ECB+2(R1),X'11' BITS 19 OR 23 00820000 BC 7,IK BR. YES 00840000 USE5 EQU * 00860000 TM 19(R2),X'01' ADDR. GIVEN 00880000 BC 1,SYNADMSG ISSUE SYNADAF AND RETURN 4986 00888000 * TO DATE MANAGEMENT URN 4986 00896000 LR R14,R0 LOAD REG 14 WITH DECB ADDR 3191 00905015 L R14,IOB(R14) LOAD REG 14 WITH IOB ADDR 3191 00910015 LTR R14,R14 ANY IOB ASSIGNED 3191 00915015 BZ LOAD15 NO 3191 00920015 MVI IOBDAVLI(R14),X'00' ZERO AVAIL. BYTE IN IOB 3191 00925015 LOAD15 L R15,16(R2) LOAD ADDR. 3191 00930015 L R14,0(R2) RESET LINK REG TO D/M FOR USE 3191 00935001 BR R15 BR. TO USER ROUTINE 00940000 IK EQU * 00960000 LR R14,R0 LOAD REG 14 WITH DECB ADDR 3191 00965015 L R14,IOB(R14) LOAD REG 14 WITH IOB ADDR 3191 00970015 LTR R14,R14 ANY IOB ASSIGNED 3191 00975015 BZ LOAD2 NO 3191 00980015 MVI IOBDAVLI(R14),X'00' ZERO AVAIL. BYTE IN IOB 3191 00985015 LOAD2 L R2,HOLD BR. TO INV. KEY ADDR. 3191 00990015 BR R2 6527 00991020 SYNADMSG SYNADAF ACSMETH=BDAM 4986 00992000 MVI LENGTH+1,57 LENGTH OF MESSAGE + 4 6527 00993020 MVC BUFFER(35),49(1) FIRST PART OF SYNADAF MSG. 6527 00994020 MVC BUFFER+35(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 00995020 LR 6,1 SAVE POINTER TO SYNADAF MSG. 6527 00996020 LA 1,LENGTH POINT TO MESSAGE 6527 00997020 LR 7,15 SAVE R15 6527 00998020 SVC 35 ISSUE MESSAGE 6527 00999020 LR 15,7 RESTORE R15 6527 01000020 MVI LENGTH+1,66 LENGTH OF MESSAGE + 4 6527 01001020 MVC BUFFER(44),84(6) REST OF SYNADAF MSG. 6527 01002020 MVC BUFFER+44(4),ROUTDESC MOVE IN ROUT & DESC CODES 6527 01003020 LA 1,LENGTH POINT TO MESSAGE 000D 01014000 SVC 35 ISSUE MESSAGE 000D 01016000 LR 15,7 RESTORE R15 000D 01018000 SYNADRLS RELSE MSG ANS SAVE AREA 4986 01020000 LM 2,1,HOLD RELOAD REGS 4986 01022000 BR 14 AND RETURM 4986 01024000 * 01026000 * CONSTANTS AND EQUATES 01040000 * 01060000 F20 DC F'20' 01080000 HOLD DC 16F'0' 4986 01086000 LENGTH DC X'00008000' LENGTH AND FLAG FOR WTO 000D 01092000 MESSAGE DC C'IHD981I I/O ERROR ' 000D 01098000 BUFFER DC 48X'00' BUFFER AREA 6527 01104020 ROUTDESC DC X'02000020' ROUTING AND DESCRIPTOR CODES 000D 01110000 * 01120000 IOB EQU 16 3191 01125015 IOBDAVLI EQU 44 3191 01130015 R0 EQU 0 3191 01135015 ECB EQU 104 01140000 R1 EQU 1 01160000 R2 EQU 2 01180000 R14 EQU 14 01200000 R15 EQU 15 01220000 END 01240000 ./ ADD SSI=03013083,NAME=IHD03300,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM * 00020000 * COBOL(E) 360S-CO-503 * 00040000 * MODULE IHD03300 * 00060000 TITLE 'IHD03300 - INTERRUPT HANDLING SUBROUTINE' 00080000 *STATUS: CHANGE LEVEL 10 * 00100000 *FUNCTION/OPERATION: * 00120000 * THIS SUBROUTINE ANYLIZES THE CAUSE FOR THE INTERRUPT AND APPROPRI * 00140000 * ATE ACTION IS TAKEN. THIS SUBROUTINE IS ENTERED IF ANY OF THESE * 00160000 * NON-MASKABLE INTERRUPTS OCCURS: * 00180000 * 1. FIXED POINT DIVIDE * 00200000 * 2. DECIMAL DIVIDE * 00220000 * 3. EXPONENT OVERFLOW * 00240000 * 4. FLOATING POINT DIVIDE * 00260000 * * 00280000 *ENTRY POINTS: * 00300000 * THIS SUBROUTINE IS ENTERED FROM THE SUPERVISOR INTERRUPT HANDLING * 00320000 * ROUTINE. THE ENTRY POINT IS GIVEN TO THE SUPERVISOR WITH THE SPIE* 00340000 * MACRO * 00360000 * * 00380000 *INPUT: * 00400000 * INPUT IS VIA THE 'PIE' TABLE WHOSE ADDRESS IS IN REGISTER 1 * 00420000 * * 00440000 *OUTPUT: N/A * 00460000 * * 00480000 *EXTERNAL ROUTINES: N/A * 00500000 * * 00520000 *EXITS NORMAL: * 00540000 * NORMAL RETURN TO THE SUPERVISOR BY BR 14 * 00560000 * * 00580000 *EXITS ERROR: N/A * 00600000 * * 00620000 *TABLE/WORK AREAS: N/A * 00640000 * * 00660000 *ATTRIBUTES: * 00680000 * SERIALLY REUSABLE * 00700000 * * 00720000 *NOTES: * 00740000 IHD03300 START 0 00760000 ENTRY IHD03301 00780000 * 00800000 * 00820000 USING PIEMAGE,PIEADDR ADDRESS PIE 00840000 USING *,MAPREG ADDRESS THIS SUBROUTINE 00860000 * 00880000 * 00900000 IHD03301 CLI PIECOD,EXPOFL CK. EXPONENT OVERFLOW 00920000 BCR NOTEQ,RETADDR RETR. TO SUPR. IF NOT 00940000 L R2,PIEICR ADDRESS NSI 00960000 CLI 0(R2),LDOP IS NSI LOAD 00980000 BNE A BR. IF NOT 01000000 EX 0,0(R2) EXECUTE LOAD 01020000 LA R2,4(R2) ADDRESS NSI + 1 01040000 A XC LAINSTR+2(2),LAINSTR+2 CLEAR LOW END OF LA INSTR. 01060000 PACK LAINSTR+2(1),1(1,R2) PUT REGISTER IN LA INSTR. 01080000 CLI 0(R2),X'07' CHECK FOR BCR INSTR. 01100000 BE LAINSTR YES,BRANCH 01120000 MVC LAINSTR+2(2),2(R2) NO,PUT BASE AND DISP IN LA INST 01140000 CLI 0(R2),BROP CHECK FOR BC INSTR. 01160000 BCR NOTEQ,RETADDR NO,RETURN 01180000 LAINSTR LA R2,0 THIS INSTR WILL BE MODIFIED 01200000 XC PIEIC,PIEIC ZERO NEW ADDRESS FIELD 01220000 O R2,PIEICR SAVE FIFTH BYTE OF OLD PSW 01240000 ST R2,PIEICR SET NEW ADDRESS 01260000 BR RETADDR RETURN TO SUPERVISOR 01280000 * 01300000 * 01320000 PIEADDR EQU 1 01340000 RETADDR EQU 14 01360000 MAPREG EQU 15 01380000 R2 EQU 2 01400000 R3 EQU 3 01420000 NOTEQ EQU 7 01440000 EXPOFL EQU 12 01460000 LDOP EQU 88 01480000 BROP EQU 71 01500000 * 01520000 * 01540000 PIEMAGE DSECT 01560000 DS F 01580000 DS 3C 01600000 PIECOD DS C 01620000 PIEICR DS C 01640000 PIEIC DS CL3 01660000 * 01680000 * 01700000 END 01720000 ./ ADD SSI=00017058,NAME=IHD03402,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM 00020000 * COBOL(E) 360S-CO-503 00040000 * MODULE IHD03402 00060000 TITLE 'IHD03402---CREATE FILES WITH DIRECT ORGANIZATION' 00080000 *STATUS CHANGE LEVEL 10 00100000 *FUNCTION/OPERATION: 00120000 * WRITE WHEN USING BSAM DIRECT. 00140000 *ENTRY POINTS: 00160000 * IHD03402 ENTERED FORM COBOL OBJECT PROGRAM VIA BALR 14,15 00180000 *INPUT: N/A 00200000 *OUTPUT: N/A 00220000 *EXTERNAL ROUTINES: N/A 00240000 *EXITS NORMAL: 00260000 * RETURN VIA REGISTER 14. 00280000 *EXITS ERROR: N/A 00300000 *TABLE/WORK AREAS: N/A 00320000 *ATTRIBUTES: N/A 00340000 *NOTES: 00360000 * 00380000 * INITIALIZATION AND HOUSEKEEPING. 00400000 * 00420000 IHD03402 START 0 ENTRY POINT 00440000 USING *,R15 00460000 STM R14,R12,12(R13) SAVE REGS. 00480000 ST R13,SV+4 00500000 LA R13,SV POINT TO SAVE AREA 00520000 LR R12,R15 00540000 DROP R15 00560000 USING IHD03402,R12 NEW BASE REG. 00580000 * 00600000 * LOAD ADDRESSES OF PARAMETERS INTO WORK REGISTERS 00620000 * AND SET UP VALUES FOR RECORD CONSTRUCTION. 00640000 * 00660000 LR R3,R1 POINT TO DCB 00680000 LA R1,DECB(R3) POINT TO DECB 00700000 XR R4,R4 00720000 IC R4,KEYLE(R3) 00740000 BCTR R4,0 LEN. TO MOVE SYM. KEY TO BUF. 00760000 L R6,SKAD(R3) SYM. KEY ADDR. 00780000 L R7,AREAD(R3) BUF. ADDR. 00800000 L R8,AKAD(R3) ACT. KEY ADDR. 00820000 L R9,0(R8) ACT. KEY 00840000 * 00860000 * COMPARE ACTUAL KEY OF RECORD TO ACTUAL KEY OF PREVIOUS RECORD. 00880000 * 1. IF HIGH INITIALIZE INTERMEDIATE RECORDS AND TRACKS. 00900000 * 2. IF EQUAL OUTPUT RECORD. 00920000 * 3. IF LOW CHANGE TO EQUAL PREVIOUS VALUE. 00940000 * 00960000 KEYCK EQU * 00980000 C R9,AKWK(R3) COMPARE KEYS 01000000 BH SKIPTRK BR. NEW GT OLD 01020000 BE OUTREC BR. NEW EQ OLD 01040000 L R9,AKWK(R3) SET NEW EQ OLD 01060000 ST R9,0(R8) UPDATE ACTUAL KEY 01080000 * 01100000 * MOVE SYMBOLIC KEY TO BUFFER AND WRITE DATA BLOCK. 01120000 * 1. IF F-TYPE END OF TRACK HANDLED BY BSAM. 01140000 * 2. IF U- OR V-TYPE WRITE CAPACITY RECORD AT END OF TRACK 01160000 * AND RETRY DATA WRITE. 01180000 * 01200000 OUTREC EQU * 01220000 EX R4,MOVE SYM. KEY TO BUF. 01240000 OUTRA EQU * 01260000 MVI TYPE+1(R3),SF WRITE TYPE SF 01280000 BAL R10,WRT 01300000 LTR R11,R11 RET. CODE 0 01320000 BZ RET BR. YES 01340000 LA R9,1(R9) ADVANCE ACT. KEY TO NEXT TRK. 01360000 ST R9,0(R8) NEW ACT. KEY 01380000 ST R9,AKWK(R3) OLD ACT. KEY 01400000 CLI RECFM(R3),X'81' F-TYPE 01420000 BE RET BR. YES 01440000 MVI TYPE+1(R3),SZ WRITE CAPACITY RECORD 01460000 BAL R10,WRT 01480000 B OUTRA 01500000 * 01520000 * RETURN TO MAIN PROGRAM 01540000 * 01560000 RET EQU * 01580000 L R13,SV+4 RESTORE REGS. 01600000 LM R14,R12,12(R13) 01620000 BR R14 RETURN 01640000 * 01660000 * INSTRUCTION EXECUTED TO MOVE SYMBOLIC KEY TO BUFFER. 01680000 * 01700000 MOVE MVC 0(0,R7),0(R6) 01720000 * 01740000 * SKIP INTERMEDIATE RECORDS AND/OR TRACKS. 01760000 * 1. IF F-TYPE WRITE DUMMY RECORDS UNTIL TRACK MATCHING 01780000 * NEW ACTUAL KEY IS REACHED. 01800000 * 2. IF U- OR V-TYPE WRITE CAPACITY RECORDS. 01820000 * 01840000 SKIPTRK EQU * 01860000 CLI RECFM(R3),X'81' F-TYPE 01880000 BNE OUTCAP BR. NO 01900000 MVI TYPE+1(R3),SD WRITE DUMMY RECORD 01920000 BCTR R7,0 LOWER ADDR. TO ALLOW DUMMY FLAG 01940000 ST R7,AREAD(R3) 01960000 OUTDUM EQU * 01980000 BAL R10,WRT WRITE 02000000 LTR R11,R11 RET. CODE 0 ( MORE ROOM ) 02020000 BZ OUTDUM BR. YES 02040000 LA R7,1(R7) RESTORE BUF. ADDR. 02060000 ST R7,AREAD(R3) 02080000 UPAKWK EQU * 02100000 L R11,AKWK(R3) ADD 1 TO OLD ACTUAL KEY 02120000 LA R11,1(R11) 02140000 ST R11,AKWK(R3) 02160000 B KEYCK GO CHECK IF ADVANCE COMPLETE 02180000 OUTCAP EQU * 02200000 MVI TYPE+1(R3),SZ WRITE CAPACITY RECORD 02220000 BAL R10,WRT 02240000 B UPAKWK 02260000 * 02280000 * LINKAGE TO BSAM WRITE ROUTINES. 02300000 * REGISTER 1 ALREADY POINTS TO DECB. 02320000 * 02340000 WRT EQU * 02360000 L R15,48(R3) READ/WRITE ADDR. 02380000 BALR R14,R15 WRITE 02400000 LR R11,R15 SAVE RET. CODE 02420000 L R15,52(R3) CHECK ADDR. 02440000 BALR R14,R15 CHECK 02460000 BR R10 RETURN 02480000 * 02500000 * CONSTANTS AND EQUATES. 02520000 * 02540000 SV DC 18F'0' 02560000 * 02580000 SF EQU X'20' 02600000 SZ EQU X'04' 02620000 SD EQU X'10' 02640000 R1 EQU 1 02660000 R3 EQU 3 02680000 R4 EQU 4 02700000 R6 EQU 6 02720000 R7 EQU 7 02740000 R8 EQU 8 02760000 R9 EQU 9 02780000 R10 EQU 10 02800000 R11 EQU 11 02820000 R12 EQU 12 02840000 R13 EQU 13 02860000 R14 EQU 14 02880000 R15 EQU 15 02900000 * 02920000 DECB EQU 88 02940000 KEYLE EQU 16 02960000 SKAD EQU 116 02980000 AKAD EQU 120 03000000 AREAD EQU 100 03020000 TYPE EQU 92 03040000 AKWK EQU 124 03060000 RECFM EQU 36 03080000 END 03100000 ./ ADD SSI=00012501,NAME=IHD03801,SOURCE=0 * IBM SYSTEM/360 OPERATING SYSTEM 01000017 * COBOL(E) 360S-LM-504 02000017 * MODULE IHD03801 03000017 EJECT 04000017 *STATUS: CHANGE LEVEL 14 05000017 *FUNCTION/OPERATION: TAKES CHECKPOINTS AND RECEIVES RESTARTS 06000017 * FOR RERUN FEATURE 07000017 * 08000017 *ENTRY POINTS: 09000017 * IHD03801 FROM READ/WRITE/REWRITE EXPANSIONS 10000017 * CALLING SEQUENCE: LA 1,RERUNLIT 11000017 * L 15,=A(IHD03801) 12000017 * BALR 14,15 13000017 * RERUNLIT FORMAT: DS 0F 14000017 * DC C'EXT-NAME' 8 BYTES 15000017 * DC F'RECORD-VALUE' 4 BYTES 16000017 * DC F'RECORD-COUNT' 4 BYTES 17000017 * 18000017 * 19000017 *INPUT: GEN REG 1 POINTS TO PARAMETERS 20000017 *OUTPUT: PARAMETERS IN RERUNLIT CHANGED TO REFLECT NEW RECORD COUNT 21000017 * GEN REG 2 IS DESTROYED BY THIS ROUTINE 22000017 *EXTERNAL ROUTINES: SVC TO TAKE CHECKPOINT 23000017 *EXITS NORMAL: RESTORE REGISTERS AND BR 14 24000017 *EXITS ERROR: N/A 25000017 *TABLES/WORKAREAS: BSAM DCB FOR TAKING CHECKPOINTS 26000017 *ATTRIBUTES: SERIALLY REUSABLE 27000017 * 28000017 ******************************************************************* 29000017 * 30000017 * 31000017 IHD03801 START 0 32000017 GRP EQU 1 PARAMETER REG 33000017 GRS EQU 13 SAVE REG 34000017 GRR EQU 14 RETURN REG 35000017 GRL EQU 15 LINK REG 36000017 GRB EQU 12 BASE REGISTER FOR CHECKPT 37000017 GRWA EQU 2 WORK REG A 38000017 USING IHD03801,GRL 39000017 L GRWA,12(GRP) GRWA IS DESTROYABLE FROM IN-LINE 40000017 BCT GRWA,RETURN1 DECREMENT THE RECORD-COUNT 41000017 MVC 12(4,GRP),8(GRP) IF ZERO, RESET THE COUNTER 42000017 B CHECKPT AND TAKE A CHECKPOINT 43000017 RETURN1 ST GRWA,12(GRP) IF NOT ZERO, STORE THE COUNT 44000017 BR GRR AND RETURN TO IN-LINE CODE 45000017 DROP GRL 46000017 EJECT 47000017 * *************************** 48000017 * *** CHECKPOINT ROUTINE *** 49000017 * *************************** 50000017 * AT ENTRY TO THIS ROUTINE: 51000017 * GRP POINTS TO EXTERNAL-NAME 52000017 * GRS POINTS TO SAVE-AREA 53000017 * GRR POINTS TO RETURN POINT 54000017 * 55000017 CHECKPT SAVE (14,12) 56000017 LR GRB,GRL SET UP BASE REG FOR CHECKPOINTS 57000017 USING IHD03801,GRB 58000017 MVC BSAMDCB+40(8),0(GRP) MOVE EXTERNAL NAME INTO DCB 59000017 OPEN (BSAMDCB,(OUTPUT)) 60000017 CHKPT BSAMDCB TAKE A CHECKPOINT 61000017 CLOSE (BSAMDCB,LEAVE) 62000017 RETURN (14,12) RETURN TO CALLING ROUTINE 63000017 BSAMDCB DCB DSORG=PS,MACRF=(W),DDNAME=DUMMY,DEVD=DA,RECFM=U, X64000017 BLKSIZE=3625 65000017 END 66000017 ./ ADD SSI=00019155,NAME=IHD03900,SOURCE=0 *// IHDFIDST 00020000 IDST TITLE 'IHDFIDST' 00040000 * 00060000 *TITLE IHDFIDST 00080000 * 00100000 * LEVEL 180 09/14/66 00120000 * 00140000 * THIS ROUTINE CONVERTS ANY INTERNAL DECIMAL NUMBER CONTAINED IN A 00160000 * 16-BYTE FIELD TO ANY STERLING FORMAT SPECIFIED. 00180000 * THE CALLING SEQUENCE IS AS FOLLOWING -- 00200000 * LA 0,STERLING-FIELD 00220000 * LA 1,INPUT ID FIELD 00240000 * L 15,=V(IDTOST) 00260000 * BALR 14,15 00280000 * DC XL2(INFO) 00300000 * WHERE 'INFO' IS A 2-BYTE PARAMETER WITH THE FOLLOWING INFORMATION- 00320000 * BIT 0 =1 IF IBM SHILLING 00340000 * BIT 1 =1 IF 2 CHARACTER PENCE REPRESENTATION 00360000 * BIT 2 =1 IF IBM PENCE 00380000 * BITS 3 -7 =NUMBER OF DIGITS OF PENCE DECIMALS 00400000 * BITS 8 -12=NUMBER OF DIGITS OF POUND INTEGERS 00420000 * BITS 13-15=000 NO SIGN 00440000 * =001 SIGN ON HIGH-ORDER POUND 00460000 * =010 SIGN ON LOW-ORDER POUND 00480000 * =011 SIGN ON HIGH-ORDER SHILLING 00500000 * =100 SIGN ON LOW-ORDER PENCE 00520000 * =101 SIGN ON LOW-ORDER DECIMAL 00540000 *ENTRY POINT 0 IHDFIDST 00560000 *INPUT - SEE ABONE. REG 3 IS INITIALIZED BY CALLER TO POINT TO TGT. 00580000 *OUTPUT 0 CONVERTED STELING FIELDS AT ADDRESS SPECIFIED IN CALLING 00600000 * SEQUENCE. 00620000 * ON SIZE ERROR, HIGH ORDER POUND INTEGERS ARE TRUNCATED. 00640000 *EXTERNAL ROUTINES 0 NONE 00660000 *EXITS- IF NO SIZE ERROR OPTION, EXIT IS BC 15,2(14) 00680000 * IF SIZE ERROR OPTION SPEC'D AND- 00700000 * 1. THERE IS A SIZE ERROR- EXIT IS BC 15,2(14) 00720000 * 2. THERE IS NOT A SIZE ERROR- EXIT IS TAKEN FROM 0(3) 00740000 *WORK AREAS 0 BYTES 96-220 OF TGT. 00760000 *ATTRIBUTES 0 SERIALLY REUSABLE. INPUT SIGNS ARE EXPECTED TO BE C,F ORD 00780000 * 00800000 IHD03900 START 0 00820000 ENTRY IHD03901 00840000 R13 EQU 13 00860000 R14 EQU 14 00880000 R15 EQU 15 00900000 R0 EQU 0 00920000 R1 EQU 1 00940000 R2 EQU 2 00960000 R3 EQU 7 00980000 RG EQU 3 01000000 R4 EQU 4 01020000 R5 EQU 5 01040000 R6 EQU 6 01060000 R7 EQU 7 01080000 HI EQU 2 01100000 LO EQU 4 01120000 NOTLO EQU 11 01140000 EQ EQU 8 01160000 NOTEQ EQU 7 01180000 NOTPOS EQU 13 01200000 ONES EQU 1 01220000 NOTONE EQU 14 01240000 ZERO EQU 8 01260000 MIXED EQU 4 01280000 NOTMXD EQU 11 01300000 UNCOND EQU 15 01320000 * 01340000 USING *,15 01360000 IHD03901 STM R1,R7,RS1 01380000 TM 15(R1),X'03' REG 1 POINTS TO INPUT ID FIELD 01400000 BC NOTMXD,IDS000 01420000 MVI SIGN,X'D0' 01440000 BC UNCOND,IDS005 01460000 IDS000 MVI SIGN,X'C0' 01480000 IDS005 EQU * 01500000 IC R2,0(14) CALCULATE LGN OF STERLING OUTPUT= R3 01520000 N R2,MK2832 PENCE DECIMAL, 01540000 LR R5,R2 01560000 IC R3,1(14) 01580000 SRL R3,3 01600000 N R3,MK2832 + POUND INTEGER, 01620000 AR R3,R2 01640000 TM 0(14),X'C0' 01660000 BC MIXED,IDS010 + SHILLING AND PENCE DIGITS. 01680000 BC ZERO,IDS020 01700000 LA R3,1(R3) 01720000 IDS010 LA R3,1(R3) 01740000 IDS020 LA R3,2(R3) 01760000 AR R3,R0 R3 POINTS TO LAST/NEXT BYTE OF 01780000 BCTR R3,0 01800000 LTR R2,R2 STERLING OUTPUT. 01820000 BC ZERO,IDS060 01840000 LR R6,R3 01860000 UNPK WORK1(16),0(9,R1) 01880000 UNPK WORK1+15(15),8(8,R1) 01900000 OI WORK1+29,X'F0' 01920000 LA R4,WORK1+29 01940000 IDS030 MVC 0(1,R3),0(R4) MOVE PENCE DECIMAL TO OUTPUT AREA 01960000 BCTR R3,0 01980000 BCTR R4,0 02000000 BCT R2,IDS030 02020000 IDS040 EQU * SAVE ONLY THE TOTAL NUMBER OF PENCE, 02040000 TM 1(14),X'05' 02060000 BC NOTONE,IDS045 02080000 MVZ 0(1,R6),SIGN 02100000 IDS045 LA R2,18(0) 02120000 SR R2,R5 02140000 BCTR R2,0 02160000 EX R2,MVC 02180000 CL R2,CON15 02200000 BC HI,IDS050 02220000 EX R2,PACK 02240000 BC UNCOND,IDS070 02260000 IDS050 PACK DIVID+7(2),WORK2(3) MORE THAN 16 DIGITS IN PENCE 02280000 PACK DIVID+8(8),WORK2+2(15) TOTAL (I.E. 17 DIGITS) 02300000 XC DIVID(7),DIVID 02320000 BC UNCOND,IDS070 02340000 IDS060 ZAP DIVID(16),0(16,R1) 02360000 OI DIVID+15,X'0F' CHANGE SIGN TO + TO WORK WITH. 02380000 IDS070 DP DIVID(16),TWELVE(2) DIVIDE BY 12 TO GET SHILLINGS. 02400000 UNPK WORK2(3),DIVID+14(2) REMAINDER = NO. OF PENCE. 02420000 TM 0(14),X'40' 02440000 BC ZERO,IDS090 02460000 IDS080 BCTR R3,0 2 CHARACTER PENCE REPRESENTATION. 02480000 MVC 0(2,R3),WORK2+1 02500000 TM 1(14),X'05' 02520000 BC ONES,IDS085 02540000 TM 1(14),X'04' 02560000 BC ZERO,IDS085 02580000 MVZ 1(1,R3),SIGN 02600000 BCT R3,IDS120 02620000 IDS085 OI 1(R3),X'F0' 02640000 BCTR R3,0 02660000 BC UNCOND,IDS120 02680000 IDS090 CP DIVID+14(2),TEN(2) 1 CHARACTER PENCE REPRESENTATION. 02700000 BC LO,IDS110 0-9 PENCE. 02720000 BC EQ,IDS100 02740000 TM 0(14),X'20' *** 11 PENCE, 02760000 BC ZERO,IDS095 02780000 MVI 0(R3),X'50' IN IBM REP. 02800000 BCT R3,IDS120 02820000 IDS095 MVI 0(R3),X'60' IN BSI REP. 02840000 BCT R3,IDS120 02860000 IDS100 TM 0(14),X'20' *** 10 PENCE 02880000 BC ZERO,IDS105 02900000 MVI 0(R3),X'60' IN IBM REP. 02920000 BCT R3,IDS120 02940000 IDS105 MVI 0(R3),X'50' IN BSI REP. 02960000 BCT R3,IDS120 02980000 IDS110 OI WORK2+2,X'F0' 03000000 MVC 0(1,R3),WORK2+2 03020000 BCTR R3,0 03040000 IDS120 ZAP WORK2(16),DIVID(14) 03060000 MVC WORK1(16),WORK2 03080000 DP WORK1(16),CON20(2) DIVIDE BY 20 TO GET POUNDS 03100000 UNPK WORK2(3),WORK1+14(2) REMAINDER= NO. OF SHILLINGS 03120000 TM 0(14),X'80' 03140000 BC ZERO,IDS130 03160000 IDS125 BCTR R3,0 03180000 MVC 0(2,R3),WORK2+1 SHILLING IN IBM REPRESENTATION,2CHAR 03200000 TM 1(R14),X'03' 03220000 BC NOTONE,IDS127 NO SIGN IN SHILLING FIELD. 03240000 MVZ 0(1,R3),SIGN 03260000 IDS127 OI 1(R3),X'F0' 03280000 BCTR R3,0 03300000 BC UNCOND,IDS150 03320000 IDS130 CP WORK1+14(2),TEN(2) SHILLINGS IN BSI REP. 03340000 BC LO,IDS135 03360000 BC HI,IDS138 03380000 MVI 0(R3),X'50' 10 SHILLINGS. 03400000 BCTR R3,0 03420000 BC UNCOND,IDS150 03440000 IDS135 OI WORK2+2,X'F0' 03460000 BC UNCOND,IDS140 03480000 IDS138 NI WORK2+2,X'CF' 11-19 SHILLINGS HAS FORM C1-C9 03500000 IDS140 MVC 0(1,R3),WORK2+2 03520000 BCTR R3,0 03540000 IDS150 UNPK WORK2(15),WORK1+6(8) MAX. NO. OF POUND DIGITS= 15 03560000 LA R5,2(0) 03580000 IC R1,1(14) 03600000 N R1,MK3032 03620000 CR R1,R5 03640000 BC NOTEQ,IDS155 SIGN NOT ON LO-ORDER POUND. 03660000 MVZ WORK2+14(1),SIGN 03680000 BC UNCOND,IDS158 03700000 IDS155 OI WORK2+14,X'F0' 03720000 IDS158 LA R2,WORK2+14 03740000 IC R4,1(14) 03760000 SRL R4,3 03780000 N R4,MK2832 R4 HAS NUMBER OF POUND INTEGERS 03800000 LR R6,R4 SAVE IT IN R6 ALSO. 03820000 IDS160 MVC 0(1,R3),0(R2) 03840000 BCTR R3,0 03860000 BCTR R2,0 03880000 BCT R4,IDS160 03900000 LA R5,1(0) 03920000 CR R1,R5 03940000 BC NOTEQ,IDS170 03960000 MVZ 1(1,R3),SIGN SIGN ON HIGH ORDER POUND. 03980000 IDS170 XC MAXIM(9),MAXIM 04000000 MVI MAXIM+8,X'0C' DO SIZE-ERROR CHECKING. 04020000 LA R6,1(R6) 04040000 STC R6,TEMP 04060000 SRA R6,1 04080000 LA R5,MAXIM+8 04100000 SR R5,R6 04120000 TM TEMP,1 04140000 BC ONES,IDS174 04160000 OI 0(R5),X'01' 04180000 BC UNCOND,IDS175 04200000 IDS174 OI 0(R5),X'10' 04220000 IDS175 CP WORK1(14),MAXIM(9) 04240000 BC NOTLO,EXIT IF THERE IS ERROR, EXIT BC 15,2(14) 04260000 CLC 0(4,RG),NIL NO ERROR, IS OPTION SPEC'D 04280000 BC EQ,EXIT NO 04300000 L 14,0(RG) YES, PICK UP RETURN ADDRESS 04320000 LM R1,R7,RS1 FROM GLOBAL TABLE +0 04340000 BCR UNCOND,R14 EXIT 04360000 EXIT LM R1,R7,RS1 04380000 BC UNCOND,2(R14) 04400000 MVC MVC WORK2(0),WORK1+12 04420000 PACK PACK DIVID(16),WORK2(0) 04440000 ZEROS DC X'000F' 04460000 CON15 DC F'15' 04480000 MK3032 DC F'7' 04500000 MK2832 DC X'0000001F' 04520000 TEN DC X'010C' 04540000 ELEVEN DC X'011C' 04560000 TWELVE DC X'012F' 04580000 CON20 DC X'020C' 04600000 CON18 DC F'18' 04620000 NIL DC F'0' 04640000 WORK1 DS 36C 04660000 WORK2 DS 36C 04680000 DIVID DS 16C 04700000 MAXIM DS 9C 04720000 TEMP DS C 04740000 RS1 DS 7F 04760000 SIGN DS C 04780000 END 04800000 EJECT 04820000 ./ ADD SSI=00019156,NAME=IHD04000,SOURCE=0 *// IHDFSTID 00020000 STID TITLE 'IHDFSTID' 00040000 * 00060000 *TITLE IHDFSTID 00080000 * 00100000 * LEVEL 180 09/14/66 00120000 * 00140000 * THIS ROUTINE CONVERTS ANY STERLING NON-REPORT FIELD INTO A 16-BYTE 00160000 * ID NUMBER. THE CALLING SEQUENCE IS - 00180000 * LA 0,STERLING-FIELD 00200000 * LA 1,OUTPUT ADDRESS 00220000 * L 15,V(STTOID) 00240000 * BALR 14,15 00260000 * DC XL2(INFO) WHERE INFO HAS THE FOLLOWING INFORMATION 00280000 * 00300000 * BIT 0 =1 IF IBM SHILLING 00320000 * BIT 1 =1 IF 2 CHARACTER PENCE REPRESENTATION 00340000 * BIT 2 =1 IF IBM PENCE 00360000 * BIT 3 -7 =NO. OF DIGITS OF PENCE DECIMAL 00380000 * BIT 8 -12=NO. OF DIGITS OF POUND INTEGER 00400000 * BIT 13-15= 000 NO SIGN 00420000 * = 001 SIGN ON HIGH-ORDER POUND 00440000 * = 010 SIGN ON LOW-ORDER POUND 00460000 * = 011 SIGN ON HIGH-ORDER SHILLING 00480000 * = 100 SIGN ON LOW-ORDER PENCE 00500000 * = 101 SIGN ON LOW-ORDER DECIMAL 00520000 *ENTRY POINT 0 IHDFSTID 00540000 *INPUT 0 SEE ABOVE. REG13 IS INITIALIZED BY CALLER TO POINT TO TGT. 00560000 *OUTPUT 0 A 16-BYTE INTERNAL DECIMAL NUMBER AT OUTPUT ADDRESS SPECIFIED 00580000 * IN THE CALLING SEQUENCE. 00600000 *EXTERNAL ROUTINES 0 NONE 00620000 *EXITS - NORMAL - BY BC 15,2(14) 00640000 * ERROR 0 NONE 00660000 *WORK AREAS 0 BYTES 96-158 OF TGT. 00680000 *ATTRIBUTES 0 SERIALLY REUSABLE. 00700000 IHD04000 START 0 00720000 ENTRY IHD04001 00740000 R0 EQU 0 00760000 R1 EQU 1 00780000 R2 EQU 2 00800000 R3 EQU 6 00820000 RG EQU 3 00840000 R4 EQU 4 00860000 R5 EQU 5 00880000 R6 EQU 6 00900000 R14 EQU 14 00920000 R15 EQU 15 00940000 ZERO EQU 8 00960000 ONES EQU 1 00980000 NOTONE EQU 14 01000000 EQ EQU 8 01020000 NOTEQ EQU 7 01040000 HI EQU 2 01060000 LO EQU 4 01080000 NOTLO EQU 11 01100000 UNCOND EQU 15 01120000 * 01140000 USING *,15 01160000 IHD04001 STM R1,R6,RS1 01180000 MVI SIGN,X'FF' 01200000 IC R2,1(14) 01220000 SRL R2,3 01240000 N R2,MK2832 NO. OF POUND INTEGERS. 01260000 BCTR R2,0 01280000 LR R1,R0 STERLING INPUT FIELD ADDRESS. 01300000 MVC LOCSIG(1),1(14) SAVE SIGN POSITION IN WORK CELL 01320000 NI LOCSIG,X'07' 01340000 CLI LOCSIG,1 01360000 BC NOTEQ,STT010 01380000 PACK SIGN(1),0(1,R1) SIGN ON HI ORDER POUND 01400000 BC 15,STT020 01420000 STT010 CLI LOCSIG,2 01440000 BC NOTEQ,STT020 01460000 AR R2,R0 01480000 PACK SIGN(1),0(1,R2) SIGN ON LOW ORDER POUND 01500000 SR R2,R0 01520000 STT020 EX R2,PACK 01540000 MP WORK(16),CON240(2) POUND * 240 = PENCE. 01560000 OI WORK+15,X'0F' CHANGE SIGN TO + TO WORK WITH. 01580000 ZAP WORK2(16),WORK(16) 01600000 STT030 AR R2,R0 01620000 LA R2,1(R2) 01640000 TM 0(14),X'80' 2 CHAR. SHILLING REPRESENTATION 01660000 BC ZERO,STT050 01680000 CLI LOCSIG,3 01700000 BC NOTEQ,STT040 01720000 PACK SIGN(1),0(1,R2) SIGN ON HI-ORDER SHILLING 01740000 STT040 PACK WORK(16),0(2,R2) 01760000 LA R2,1(R2) 01780000 STT045 MP WORK(16),CON12(2) SHILLING * 12 = PENCE. 01800000 OI WORK+15,X'0F' CHANGE SIGN TO + TO WORK WITH. 01820000 AP WORK2(16),WORK(16) 01840000 LA R2,1(R2) 01860000 BC 15,STT080 01880000 STT050 TM 0(R2),X'F0' 1 CHARACTER SHILLING REPRESENTATION. 01900000 BC ONES,STT070 01920000 CLI 0(R2),X'50' IS IT TEN SHILLINGS. 01940000 BC EQ,STT075 01960000 MVI WORK+14,X'01' 01980000 STT060 XC WORK(14),WORK 02000000 PACK WORK+15(1),0(1,R2) 02020000 BC 15,STT045 02040000 STT070 MVI WORK+14,X'00' 02060000 BC 15,STT060 02080000 STT075 ZAP WORK(16),TEN(2) 02100000 BC UNCOND,STT045 02120000 * 02140000 STT080 TM 0(14),X'40' 02160000 BC ZERO,STT100 02180000 CLI LOCSIG,4 2 CHARACTER PENCE REPRESENTATION. 02200000 BC NOTEQ,STT090 02220000 PACK SIGN(1),1(1,R2) SIGN ON LOW ORDER PENCE. 02240000 STT090 PACK WORK(16),0(2,R2) 02260000 OI WORK+15,X'0F' CHANGE SIGN TO + TO WORK WITH. 02280000 LA R2,1(R2) 02300000 STT095 AP WORK2(16),WORK(16) 02320000 LA R2,1(R2) 02340000 BC 15,STT150 02360000 STT100 CLI 0(R2),X'60' 1 CHARACTER PENCE REPRESENTATION. 02380000 BC HI,STT130 BUT, ONLY 0-9 PENCE,BRANCH. 02400000 BC LO,STT120 02420000 TM 0(14),X'20' 02440000 BC ZERO,STT110 02460000 STT105 MVC WORK+14(2),TEN IBM REP, 10 PENCE 02480000 BC 15,STT115 02500000 STT110 MVC WORK+14(2),ELEVEN BSI REP, 11 PENCE 02520000 STT115 XC WORK(14),WORK 02540000 BC 15,STT095 02560000 STT120 TM 0(14),X'20' 02580000 BC ZERO,STT105 BSI REP, 10 PENCE 02600000 BC ONES,STT110 IBM REP, 11 PENCE 02620000 * 02640000 STT130 PACK WORK(16),0(1,R2) 02660000 BC 15,STT095 02680000 * 02700000 STT150 IC R5,1(14) 02720000 SRL R5,3 02740000 N R5,MK2832 NO. OF DIGITS IN TOTAL PENCE FIELD 02760000 LA R5,2(R5) = NO. OF POUND INTEGERS +3. 02780000 LR R3,R5 02800000 LA R0,17(0) 02820000 CR R3,R0 ARE THERE MORE THAN 18 DIGITS 02840000 BC NOTLO,STT190 18 OR MORE BYTES,ONLY 18 RETURNED 02860000 BCTR R0,0 02880000 CR R3,R0 02900000 BC EQ,STT200 17 BYTES. 02920000 SLL R5,4 02940000 EX R5,UNPKT 02960000 STT155 LA R4,WORK 02980000 AR R4,R3 03000000 LA R4,1(R4) R4 NOW POINTS TO 1ST BYTE AFTER 03020000 * PENCE FIELD. 03040000 IC R1,0(14) GET NO. OF PENCE DECIMALS 03060000 N R1,MK2832 03080000 LTR R1,R1 03100000 BC ZERO,STT180 03120000 BCTR R1,0 03140000 EX R1,MVC MOVE PENCE DEC TO THE RIGHT OF 03160000 LA R3,1(R3) 03180000 AR R3,R1 PENCE FIELD. 03200000 * 03220000 * OUTPUT CONVERTED DATA TO ADDRESS INDICATED IN CALLING PARAMETER. 03240000 * 03260000 STT180 MVC WORK2(4),RS1 03280000 L R4,WORK2 03300000 CR R3,R0 R0 HAS 16 IN IT. 03320000 BC EQ,STT186 17 BYTES TO UNPACK. 03340000 BC HI,STT187 18 BYTES TO UNPACK. 03360000 STT185 EX R3,PACKA 03380000 BC UNCOND,EXIT 03400000 STT186 PACK 0(9,R4),WORK(3) 03420000 PACK 8(8,R4),WORK+2(15) 03440000 BC UNCOND,EXIT 03460000 STT187 PACK 0(9,R4),WORK(4) 03480000 PACK 8(8,R4),WORK+3(15) 03500000 EXIT CLI LOCSIG,5 PUT IN THE ORIGINAL SIGN. 03520000 BC EQ,EXIT1 03540000 MVN 15(1,R4),SIGN 03560000 EXIT1 LM R1,R6,RS1 03580000 BC 15,2(14) 03600000 STT190 MVC WORK(4),RS1 03620000 L R4,WORK 03640000 ZAP 0(16,R4),WORK2(16) MOVE TO OUTPUT AREA. 03660000 BC 15,EXIT 03680000 STT200 UNPK WORK(3),WORK2+7(2) 03700000 UNPK WORK+2(15),WORK2+8(8) UNPACK TO 17 BYTES. 03720000 BC 15,STT155 03740000 SPACE 4 03760000 PACK PACK WORK(16),0(0,R1) 03780000 UNPKT UNPK WORK(0),WORK2(16) 03800000 MVC MVC 0(0,R4),0(R2) 03820000 PACKA PACK 0(16,R4),WORK(0) 03840000 DS 0F 03860000 MK2832 DC X'0000001F' 03880000 CON240 DC X'240C' 03900000 CON12 DC X'012C' 03920000 TEN DC X'010C' 03940000 ELEVEN DC X'011C' 03960000 RS1 DS 6F 03980000 WORK DS 20C 04000000 WORK2 DS 20C 04020000 LOCSIG DS C 04040000 SIGN DS C 04060000 END 04080000 EJECT 04100000 ./ ADD SSI=00019157,NAME=IHD04100,SOURCE=0 *// IHDFIDSR 00020000 IDSR TITLE 'IHDFIDSR' 00040000 * 00060000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00080000 * TITLE 'IHDFIDSR - INTERNAL DECIMAL TO STERLING REPORT' 00100000 * 00120000 * LEVEL 180 09/14/66 00140000 * 00160000 *FUNCTION/OPERATION0 THIS ROUTINE EDITS A PACKED DECIMAL QUANTITY 00180000 * INTO A STERLING REPORT FIELD, AS DEFINED BY A STERLING REPORT 00200000 * PICTURE AND OTHER PARAMETERS IN THE CALLING SEQUENCE. 00220000 * THE PACKED DECIMAL QUANTITY CONTAINS 31 DIGITS,SIGNED,AND IS NOT 00240000 * CHANGED BY THE ROUTINE. THE REPORT FIELD MAY BE UP TO 127 BYTES 00260000 * LONG. 00280000 * THE DECIMAL FIELD,PENCE,IS CONVERTED TO POUNDS,SHILLING,PENCE AND 00300000 * PENCE DECIMAL FIELDS ACCORDING TO THE SPECIFICATIONS IN THE CALLING 00320000 * SEQUENCE. THE POUND INTEGER FIELD IS EDITED USING THE EDIT-AND-MARK 00340000 * INSTUCTION. ALL OTHER FIELDS ARE EDITED DIRECTLY BY THE SUBROUTINE. 00360000 * 00380000 *ENTRY IHDFIDSR ONLY. 00400000 * THE CALLING SEQUENCE IS 00420000 * 00440000 * ( LA REGISTER0(ADDRESS OF REPORT FIELD) 00460000 * LA REGISTER13(ADDRESS OF WORKSPACE) ) 00480000 * 00500000 * LA REGISTER15(IHDFIDSR) ROUTINE ADDRESS 00520000 * BALR REGISTER14,REGISTER15 BRANCH TO ROUTINE,WITH REGISTER14 00540000 * SET TO NEXT INSTRUCTION 00560000 * DC AL4(SOURCE FIELD ADDRESS) 00580000 * DC AL1(PICTURE LENGTH) 00600000 * DC AL3(PICTURE ADDRESS) 00620000 * DC AL4(ON-SIZE-ERROR ROUTINE) 00640000 * DC AL1(LENGTH OF REPORT FIELD) 00660000 * DC AL1(NO.OF DECIMAL DIGITS) 00680000 * DC AL1(NO.OF POUND INTEGERS) 00700000 * DC X'INFOA' (1BYTE) 00720000 * NORMAL RETURN POINT. 00740000 * 00760000 * NOTES ON CALLING SEQUENCE0 00780000 * 'REPORT FIELD' IS THE STERLING REPORT FIELD REQUIRED. 00800000 * 'SOURCE FIELD' CONTAINS THE SIGNED,PACKED DECIMAL,QUANTITY. 00820000 * 'PICTURE' IS THE DEFINITION OF THE OUTPUT FORMAT REQUIRED. 00840000 * REGISTER 13 CONTAINS THE ADDRESS OF A WORK AREA FIELD,STARTING ON A 00860000 * DOUBLE WORD BOUNDARY.(THE ROUTINE REQUIRES ONLY A FULL WORD 00880000 * BOUNDARY).THE FIRST 96 BYTES ARE PRE-EMPTED BY COBOL. 00900000 * REGISTER 14 IS POINTING TO THE PARAMETER LIST. 00920000 * REGISTER 15 CONTAINS THE ADDRESS OF THE SUBROUTINE. 00940000 * 'ON-SIZE-ERROR ROUTINE' IS THE POINTER TO THE P.G.T. WHICH CONTAINS 00960000 * THE ADDRESS OF THE ROUTINE TO BE USED IN 00980000 * THE CASE OF AN ON-SIZE-ERROR OCCURRING. 01000000 * THE 1 BYTE FIELD 'INFOA' CONTAINS THE FOLLOWING INFORMATION 01020000 * BIT 0 X'80' BLANK WHEN ZERO 0 = NO, 1 = YES 01040000 * 1 X'40' SHILLING DELIMITER = C 0 = NO, 1 = YES 01060000 * 2 X'20' POUND DELIMITER = C 0 = NO, 1 = YES 01080000 * 3 X'10' NO POUNDS PRESENT 0 = NO 1 = YES 01100000 * NOTE THAT 'NO POUNDS PRESENT' MEANS THAT IF THERE ARE ANY 01120000 * CHARACTERS PRESENT BEFORE THE POUND DELIMITER,THEY ARE ALL ONLY 01140000 * SEPARATOR CHARACTERS. 01160000 EJECT 01180000 *INPUT0 ALL INPUT PARAMETERS ARE DEFINED EXPLICITLY BY THE CALLING 01200000 * SEQUENCE 01220000 * THE INPUT DATA CONSISTS OF A 16 BYTE FIELD, CONTAINING 31 PACKED 01240000 * DECIMAL DIGITS AND A SIGN. THE DATA IS IN PENCE AND PENCE DECIMAL, 01260000 * THE NUMBER OF DECIMAL PLACES BEING GIVEN BY THE 'NO.OF DECIMAL 01280000 * DIGITS' PARAMETER. 01300000 * THE PICTURE CONTAINS THE FORMAT REQUIRED FOR OUTPUT. IT CONSISTS 01320000 * OF A STRING OF BYTE PAIRS (OF TOTAL LENGTH GIVEN BY THE 'PICTURE 01340000 * LENGTH' PARAMETER) CONTAINING THE REQUIRED CHARACTER IN THE FIRST 01360000 * BYTE,AND THE COUNT OF SUCCESSIVE OCCURENCES OF THAT CHARACTER IN 01380000 * THE SECOND BYTE. 01400000 * 01420000 *OUTPUT0 THE OUTPUT CONSISTS OF THE EDITED STERLING REPORT FIELD,AT THE 01440000 * ADDRESS DEFINED BY REGISTER 0 UPON ENTRY. 01460000 * ALL INPUT FIELDS, AND PARAMETERS ARE UNCHANGED. ALL REGISTERS ARE 01480000 * RESTORED, WITH THE EXCEPTION OF REGISTER 15 (THE BASE REGISTER OF 01500000 * THE ROUTINE) AND REGISTER 14,WHICH IS CHANGED TO THE ADDRESS OF THE 01520000 * FIRST INSTUCTION AFTER THE PARAMETER LIST IF THE NORMAL EXIT IS 01540000 * TAKEN. 01560000 * 01580000 *EXITS-NORMAL0 THE NORMAL EXIT IS TO THE FIRST INSTUCTION AFTER THE 01600000 * CALLING SEQUENCE PARAMETER LIST, WITH REGISTER 14 SET TO THIS 01620000 * ADDRESS. REGISTER 15 CONTAINS THE ADDRESS OF THE ROUTINE. 01640000 * 01660000 *EXITS-ERROR0 THE ONLY ERROR EXIT IS TO THE ON-SIZE-ERROR ROUTINE. 01680000 * THIS WILL OCCUR IF AN ON-SIZE-ERROR ROUTINE IS GIVEN (THE 01700000 * PARAMETER IS NOT ZERO) AND EITHER THE 'NO. OF POUND INTEGERS' 01720000 * PARAMETER IS NOT ZERO,BUT THE NO.OF POUND DIGITS GENERATED FROM THE 01740000 * SOURCE FIELD IS GREATER THAN THE NO.OF POUND INTEGERS SPECIFIED, 01760000 * OR,IF THE 'NO OF POUND INTEGERS' PARAMETER IS ZERO,BUT THE NUMBER 01780000 * OF SHILLINGS DIGITS GENERATED IS GREATER THAN TWO. NOTE THAT IF 01800000 * NO POUND INTEGERS ARE SPECIFIED,SHILLINGS ARE NOT CONVERTED TO 01820000 * POUNDS AND SHILLINGS,SO THE SIZE LIMIT IS 99 SHILLINGS,NOT 19. 01840000 * REGISTER 15 IS POINTING AT THE ON-SIZE-ERROR ROUTINE. 01860000 * NOTE THAT REGISTER 14 IS NOT CHANGED IF THE ON-SIZE-ERROR EXIT IS 01880000 * TAKEN,AND REMAINS POINTING AT THE PARAMETER LIST. 01900000 * 01920000 *TABLES0 NONE 01940000 * 01960000 *WORK AREAS0 THE ROUTINE USES ONE WORK AREA,246 BYTES IN LENGTH.THE 01980000 * ADDRESS OF THIS WORK AREA IS GIVEN TO THE ROUTINE THROUGH REGISTER 02000000 * 13,AND STARTS ON A FULL-WORD BOUNDARY.THE STRUCTURE OF THE AREA IS 02020000 * 12 FULL WORDS FOR REGISTER SAVE AREA,3 FULL WORDS FOR TEMPORARY 02040000 * ADDRESS SAVE AREAS,1 HALF-WORD AREA,AND THE REST NON-ALLIGNED AREAS 02060000 * 02080000 *ATTRIBUTES0 THE ROUTINE IS RE-ENTRANT. 02100000 * THE ONLY CORE STORAGE CHANGED BY THE ROUTINE IS THE OUTPUT AREA AND 02120000 * THE WORK AREA. 02140000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 02160000 EJECT 02180000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 02200000 * FURTHER NOTES ON THE OPERATION OF THE ROUTINE. 02220000 * ********** 02240000 * THE SOURCE FIELD,IN PENCE,PENCE DECIMAL,AND SIGN,IS CONVERTED TO 02260000 * POUNDS,SHILLINGS,PENCE,AND PENCE DECIMAL,WITH SIGN SAVED. 02280000 * THE EDITING MAY THEN COMMENCE 02300000 * 02320000 * IF BLANK-WHEN-ZERO IS SPECIFIED,AND THE FIELD IS ZERO,THE COMPLETE 02340000 * OUTPUT FIELD IS SET TO BLANK 02360000 * 02380000 * EDITING IS CARRIED OUT FROM LEFT TO RIGHT. 02400000 * ********** 02420000 * THE STERLING REPORT FIELD IS DEVIDED INTO 3 FIELDS BY THE 02440000 * DELIMITER CHARACTERS(C OR D),THESE FIELDS BEING POUNDS,SHILLINGS 02460000 * AND PENCE WITH PENCE DECIMALS. 02480000 * THESE FIELDS ARE FURTHER DEVIDED AS FOLLOWS- 02500000 * POUNDS - STATIC CHARACTERS,DIGIT FIELD,SEPARATORS 02520000 * SHILLS - DIGIT FIELD,SEPARATORS 02540000 * PENCE - DIGIT FIELD,SEPARATORS,DECIMALS,TERMINATORS. 02560000 * THESE SUB-FIELDS ARE DEFINED AS- 02580000 * POUND DIGITS-THAT PART OF THE FIELD FROM THE FIRST DIGIT POSITION 02600000 * TO THE LAST DIGIT POSITION.THESE MAY INCLUDE INSERTION (NON-DIGIT) 02620000 * CHARACTERS. 02640000 * POUND STATIC CHARACTERS-ALL CHARACTERS PRECEDING THE DIGIT FIELD 02660000 * POUND SEPARATORS-ALL CHARACTERS AFTER THE DIGIT FIELD,BUT BEFORE 02680000 * THE DELIMITER. 02700000 * SHILLS DIGITS-THE 2 DIGITS AT THE START OF THE FIELD. 02720000 * SHILLS.SEPARATORS-ALL REMAINING CHARACTERS BEFORE THE DELIMITER. 02740000 * PENCE DIGITS-THE 2 DIGITS AT THE START OF THE FIELD 02760000 * PENCE SEPARATORS-THE CHARACTERS UP TO THE NEXT DIGIT POSITION. 02780000 * PENCE DECIMALS-THAT PART OF THE FIELD FROM THE FIRST DIGIT 02800000 * POSITION (AFTER THE SEPARATORS) UP TO THE LAST DIGIT POSITION. 02820000 * PENCE TERMINATORS-ALL REMAINING CHARACTERS. 02840000 * ANY OF THESE FIELDS MAY BE OMITTED,EXCEPT THE SHILLINGS AND PENCE 02860000 * DIGITS.TO RESOLVE AMBIGUITY WHEN FIELDS ARE OMITTED,THE FOLLOWING 02880000 * RULES APPLY- 02900000 * IF POUND DIGIT FIELD IS OMITTED,(NO.OF POUND INTEGERS IS ZERO) 02920000 * THEN THE ENTIRE POUND FIELD IS CONSIDERED AS SEPARATORS,UNLESS 02940000 * THERE IS A SIGN (+ OR -) IN THE FIELD.IN THIS CASE,THE SIGN IS 02960000 * THE TERMINATOR OF THE STATIC FIELD,AND THE NO POUND BIT IN INFOA 02980000 * (BIT 3,X'10') WILL NOT BE SET ON. 03000000 * IF THE PENCE DECIMAL FIELD IS OMITTED,THE PENCE SEPARATORS ARE 03020000 * COMBINED WITH THE PENCE TERMINATORS. 03040000 * ********** 03060000 EJECT 03080000 * 03100000 * THE RULES FOR EDITING ARE AS FOLLOWS- 03120000 * POUND STATIC CHARACTERS WILL ALWAYS APPEAR 03140000 * POUND DIGITS ARE EDITED IN THE NORMAL WAY. IF THE COMPLETE FIELD 03160000 * IS A FLOAT CHARACTER ($ OR SIGN),THE FLOAT CHARACTER WILL BE 03180000 * REPLACED BY A BLANK IF THE VALUE OF FIELD IS ZERO,BUT STATIC 03200000 * CHARACTERS WILL STILL APPEAR. 03220000 * THE POUND SEPARATOR FIELD WILL APPEAR UNLESS THE LAST CHARACTER 03240000 * OF THE POUND DIGIT FIELD RESULTED IN AN * OR BLANK AND THE 03260000 * DELIMITER IS A C,IN WHICH CASE THE LAST CHARACTER WILL BE 03280000 * PROPOGATED THROUGH THE FIELD.(NOTE THAT THIS CAN ONLY OCCUR IF 03300000 * THE POUND DIGIT FIELD IS PRESENT,CONTAINS NO NINE,AND THE VALUE 03320000 * OF THE FIELD IS ZERO). 03340000 * THE SHILLING DIGITS WILL ALWAYS APPEAR.THIS FIELD IS INDEPENDENT 03360000 * OF THE POUND FIELD,EXCEPT FOR THE X8 TYPE EDITING,WHEN THE 8 IS 03380000 * TREATED AS 9 UNLESS POUND FIELD VALUE WAS ZERO. 03400000 * THE SHILLING SEPARATOR FIELD WILL APPEAR UNLESS THE LAST DIGIT 03420000 * CHARACTER OF THE DIGIT FIELD RESULTED IN AN * OR BLANK AND THE 03440000 * DELIMITER IS A C,IN WHICH CASE THE LAST CHARACTER WILL BE 03460000 * PROPOGATED THROUGH THE FIELD.(THIS CAN ONLY OCCUR IF THE SHILLS 03480000 * FIELD VALUE IS ZERO,AND THE 2ND DIGIT WAS NOT A 9 OR FORCED TO 03500000 * 9 BY THE VALUE OF THE POUND FIELD).THIS FIELD IS INDEPENDENT 03520000 * OF THE POUND FIELD EXCEPT FOR THE EFFECT OF X8 TYPE EDIT. 03540000 * THE PENCE DIGIT FIELD WILL ALWAYS APPEAR.THIS FIELD IS INDEPENDENT 03560000 * OF PRECEDING FIELDS,EXCEPT FOR THE X8 TYPE EDITING,WHEN THE 8 IS 03580000 * TREATED AS 9 UNLESS BOTH POUND AND SHILLINGS VALUES ARE ZERO. 03600000 * THE REMAINING PENCE FIELDS WILL ALWAYS APPEAR. 03620000 * 03640000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 03660000 EJECT 03680000 IHD04100 CSECT 03700000 ENTRY IHD04101 03720000 * DEFINE SYMBOLIC REGISTERS 03740000 * 03760000 R1 EQU 1 USED FOR TRT,EDIT AND MARK INSTRUCTIONS 03780000 R2 EQU 2 03800000 RG EQU 3 A( GLOBAL TABLE ) 03820000 MASKER EQU 4 POSITION IN EDIT MASK 03840000 GEN EQU 5 GENERAL USAGE REGISTER 03860000 WREG1 EQU 6 THESE MUST BE EVEN/ODD PAIR,USED 03880000 WREG2 EQU 7 FOR WORKREGISTERS 03900000 TARGET EQU 8 CURRENT BYTE IN TARGET (OUTPUT AREA) 03920000 PICTURE EQU 9 CURRENT CHARACTER IN PICTURE 03940000 SOURCE EQU 10 ADDRESS OF SOURCE (INPUT) FIELD 03960000 WORK EQU 11 USED TO ADDRESS WORKSPACE 03980000 GLOBAL EQU 12 X RESERVED BY COBOL 04000000 WORKSP EQU 3 04020000 RETURN EQU 14 X RESERVED BY COBOL - ADDRESS OF PARAMETER LIST 04040000 * ALSO RETURN POSITION 04060000 CALLER EQU 15 CALLING REGISTER,USED AS BASE REGISTER 04080000 * 04100000 * OTHER DEFINITIONS 04120000 XX EQU 16 NO.OF BYTES IN SOURCE FIELD 04140000 WC EQU 96 NO.OF.BYTES AT START OF WORK AREA RESERVED BY COBOL 04160000 REGFROM EQU 0 FIRST REGISTER TO BE SAVED 04180000 REGTO EQU 11 LAST REGISTER TO BE SAVED 04200000 * 04220000 * ESTABLISH BASE REGISTER USAGES 04240000 USING *,CALLER 04260000 USING PARAM,RETURN 04280000 * SAVE REGISTERS 04300000 IHD04101 STM 3,11,REGSAVE 04320000 * SET UP POINTERS TO INPUT,OUTPUT,PICTURE AND WORK AREA.CLEAR WORKAREA 04340000 LR SOURCE,R1 PICK UP SOURCE ADDRESS 04360000 * PICK UP TARGET ADDR 04380000 LR TARGET,0 (ALSO IN REGSAVE 0 TO 3) 04400000 LR PICTURE,R2 04420000 ST R2,PCTADD 04440000 * ZERO WORK AREA BEYOND REGISTER SAVE AREA 04460000 XC TEMP1(ENDSTOR-TEMP1),TEMP1 EXC.OR WITH SELF =0 04480000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 04500000 * THE SOURCE FIELD CONSISTS OF PENCE INTEGERS,PENCE DECIMALS AND SIGN 04520000 * THE SIGN IS MOVED TO FIELD 'SSIGN' 04540000 * THE INTEGER PENCE ARE MOVED TO A 16 BYTE FIELD 'INTEGER' 04560000 * WITH A PLUS SIGN 04580000 * THE INTEGER PENCE ARE CONVERTED TO SHILLINGS AND PENCE,WITH 04600000 * 14 BYTES SHILLINGS (27 DIGITS,WITH PLUS SIGN) 04620000 * 2 BYTES PENCE (03 DIGITS,WITH PLUS SIGN) 04640000 * IF POUNDS ARE SPECIFIED (NO.POUND INTEGERS NOT ZERO) 04660000 * THE INTEGER SHILLINGS ARE CONVERTED TO POUNDS AND SHILLINGS,WITH 04680000 * 12 BYTES POUNDS (23 DIGITS,WITH PLUS SIGN) 04700000 * 2 BYTES SHILLINGS (03 DIGITS,WITH PLUS SIGN) 04720000 * THE FIELD INTEGER THEREFORE CONTAINS (16 BYTES) 04740000 * P O U N D S SHILL PENCE 04760000 * 00 00 00 00 DD DD DD DD DD DD DD D+ 0D D+ 0D D+ 04780000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 04800000 * 04820000 * SAVE SIGN 04840000 MVC SSIGN(1),XX-1(SOURCE) 04860000 OI SSIGN,X'10' ENSURE NON ZERO 04880000 * IS SOURCE ZERO 04900000 CP 0(XX,SOURCE),ZERO(1) 04920000 BE ZEROSRC SOURCE IS ZERO 04940000 * TRANSFER VALUE TO WORK AREA,AND CONVERT TO LSD. 04960000 * POSITION DECIMAL POINT 04980000 SR WREG1,WREG1 05000000 IC WREG1,DECDGT PICK UP NO. DECIMAL DIGITS 05020000 * SHIFT RIGHT ONE BIT,CONVERTING DIGITS TO CHARS - FOR MVC 05040000 SRL WREG1,1 05060000 * 05080000 * INITIALLY JUST MOVE TO GET INTEGER R.J AT INTEGER+15 05100000 * COMPUTE STARTING POINT FOR MOVE 05120000 LA WREG2,INTEGER(WREG1) 05140000 TM DECDGT,X'01' COUNT ODD 05160000 BO OFFSET LOW BIT TEST 05180000 * BIT=ZERO, STRAIGHT MOVE 05200000 MVC 0(XX,WREG2),0(SOURCE) 05220000 B MOVDGT 05240000 * ODD NO. DEC DIGITS,MOVE WITH OFFSET, DROPPING LOW ORDER 05260000 * BYTE, BECAUSE MOVE IS ONLY 16 BYTES. 05280000 OFFSET MVO 0(XX,WREG2),0(XX-1,SOURCE) 05300000 GETLSD EQU * 05320000 * NOW INSERT PLUS SIGN IN LOW ORDER INTEGER 05340000 MOVDGT MVN INTEGER+XX-1(1),ZERO 05360000 * INTEGER NOW CONTAINS PENCE ONLY,WITH A PLUS SIGN 05380000 * CONVERT PENCE TO SHILLINGS AND PENCE 05400000 * PROCESS DECIMAL DIGITS LATER ON 05420000 COMPS DP INTEGER(XX),TWLV(2) 05440000 * SHILLINGS ARE IN INTEGER(0 TO XX-1-2) 05460000 * TEST FOR ZERO SHILLINGS 05480000 CP INTEGER(XX-2),ZERO(1) 05500000 BE ZEROSH 05520000 * CONVERT SHILLINGS TO POUNDS AND SHILLINGS. 05540000 TM PNDDGT,X'FF' ANY POUND DIGITS SPECIFIED 05560000 BM COMPP YES CONVERT SHILLS TO POUNDS 05580000 * IF NO POUND DIGITS,CHECK FOR SHILLS OVERFLOW 05600000 CP INTEGER(XX-2),MAXSHILS(2) SHILLS GREATER THAN MAXIMUM 05620000 BH SIZERR YES THEN SIZE ERROR 05640000 B POUND 05660000 COMPP DP INTEGER(XX-2),TWNTY(2) 05680000 * POUNDS ARE NOW IN INTEGER(0 TO XX-1-2-2) 05700000 * TEST FOR ZERO POUNDS 05720000 CP INTEGER(XX-2-2),ZERO(1) 05740000 BE ZEROPD 05760000 * FIND OUT HOW MANY POUND DIGITS THERE ARE 05780000 * USE TRT AND STOP ON NON ZERO 05800000 COMPX SR R1,R1 05820000 TRT SCAN(XX-4),INTEGER 05840000 * ARGUMENT ADDR (BYTE NO.) IS IN REG 1 05860000 * GET BYTE AT WHICH WE STOPPED N BYTES FROM INTEGER 05880000 LA WREG1,INTEGER 05900000 SR WREG2,WREG2 05920000 IC WREG2,0(R1) 05940000 AR WREG1,WREG2 05960000 * CONVERT BYTE COUNT TO DIGITS 05980000 AR WREG2,WREG2 06000000 * IF HIGH DIGIT ZERO R1 OFF BY 1 06020000 TM 0(WREG1),X'F0' 06040000 BM TEST1 NOT ZERO 06060000 LA WREG2,1(WREG2) 06080000 TEST1 LH WREG1,PDIGITS 06100000 SR WREG1,WREG2 06120000 * COMPARE AGAINST NO. POUND DIGITS 06140000 IC WREG2,PNDDGT 06160000 CR WREG1,WREG2 06180000 BNH POUND 06200000 EJECT 06220000 SIZERR EQU * 06240000 * TOO MANY POUND DIGITS, IS THERE A SIZE ERROR EXIT 06260000 * OR TOO MANY SHILLINGS 06280000 SIZEER L WREG1,0(RG) 06300000 LTR WREG1,WREG1 IS THERE AN ADDRESS 06320000 BZ POUND NO 06340000 LM 3,11,REGSAVE 06360000 B 6(RETURN) 06380000 SPACE 1 06400000 ZEROSRC TM INFOA,BLANKWZ IS BLANK WHEN ZERO SPECIFIED 06420000 BZ GETLSD NO, NORMAL TREATMENT,INTEGER IS ALREADY ZERO 06440000 * BLANK OUT THE TARGET 06460000 MVI 0(TARGET),C' ' 06480000 * PICK UP TARGET LENGTH 06500000 SR WREG2,WREG2 06520000 IC WREG2,TRGLNG 06540000 BCT WREG2,ZAA 06560000 B FINISH 06580000 ZAA EQU * 06600000 BCTR WREG2,0 REDUCE FOR THE MVC 06620000 EX WREG2,PROPTRGT PROPAGATE BLANK 06640000 B FINISH ALL DONE 06660000 * 06680000 ZEROSH OI FLAGA,NOSHILL NO POUNDS OR SHILLS 06700000 ZEROPD OI FLAGA,NOPOUND NO POUNDS 06720000 EJECT 06740000 * THE CONVERSION TO LSD IS COMPLETE,AND THE EDIT MAY BE STARTED. 06760000 * THE STATIC CHARACTERS ARE MOVED DIRECTLY TO THE OUTPUT AREA. 06780000 * THE DIGIT FIELD IS PROCESSED USING THE EDIT-AND-MARK INSTRUCTION. 06800000 * AN EDIT MASK IS BUILT UP FROM THE PICTURE STRING,IN THE WORKAREA. 06820000 * THE EDIT MASK IS INITIALISED BEFORE PROCESSING THE STATIC CHARS. 06840000 * 06860000 * FIRST DETERMINE IF EDIT MASK IS REQUIRED 06880000 * PICK UP PICTURE LENGTH AND ADDRESS 06900000 POUND EQU * 06920000 * SET NO. OF DIGITS TO THAT GIVEN BY PICTURE 06940000 SR WREG1,WREG1 06960000 IC WREG1,PNDDGT 06980000 TM INFOA,PSEPONLY ANY STATIC OR DIGIT FIELDS 07000000 BO LOOPS1 NO PROCESS POUND SEPARATORS,IF ANY 07020000 LTR WREG1,WREG1 IS POUND COUNT ZERO 07040000 BZ POUNDA YES PROCESS LEADING STATIC CHARACTERS 07060000 * 07080000 * AN EDIT MASK IS REQUIRED,SO INITIALISE IT. 07100000 * IF NO. OF DIGITS TO EDIT IS EVEN THERE WILL BE 07120000 * AN EXTRA HIGH ORDER DIGIT PROCESSED, TO HANDLE 07140000 * LEAVE A DUMMY POSITION IN MASK 07160000 * 07180000 SR WREG2,WREG2 07200000 SRL WREG1,1 07220000 TM PNDDGT,X'01' COUNT ODD 07240000 BO POUND1 LOW BIT WAS 1 07260000 LA MASKER,MASKXX TWO SPACES 07280000 * STORE BLANK AS FILL CHAR, AND DIGIT SEL 07300000 MVC 0(2,MASKER),BLDS 07320000 OI FLAGB,DUMMYPOS NOTE THE DUMMY POSITION 07340000 B POUND2 07360000 POUND1 EQU * 07380000 LA MASKER,MASKX ONE SPACE 07400000 * START WITH BLANK AS FILL CHAR 07420000 MVI 0(MASKER),C' ' 07440000 POUND2 EQU * 07460000 * STORE OFFSET FROM INTEGER FOR EDMK 07480000 LH WREG2,PBYTESZ 07500000 SR WREG2,WREG1 07520000 STH WREG2,SAVEOFF 07540000 * IF EXTRA DIGIT IS PRESENT ZERO IT OUT 07560000 * THIS ENSURES NO TROUBLE WITH 0 NOT BEING BLANKED OUT 07580000 TM FLAGB,DUMMYPOS 07600000 BZ POUNDA 07620000 LA R1,INTEGER(WREG2) 07640000 NI 0(R1),X'0F' 07660000 EJECT 07680000 * NOW PROCESS THE PICTURE STRING. 07700000 * EACH CHARACTER IS EXAMINED TO SEE IF IT IS A DIGIT CHARACTER. 07720000 * INITIALLY,ALL CHARACTERS ARE TREATED AS STATIC CHARACTERS,AND ARE 07740000 * MOVED TO THE OUTPUT AREA.AS SOON AS A DIGIT CHARACTER IS FOUND, 07760000 * THIS DEFINES THE START OF THE DIGIT FIELD.FROM THEN ON,THE 07780000 * CHARACTERS ARE MOVED TO THE EDIT MASK.THIS CONTINUES UNTIL THE 07800000 * NO.OF DIGITS PROCESSED IS EQUAL TO THE NUMBER SPECIFIED. 07820000 POUNDA EQU * 07840000 * PUT DIGIT COUNT BACK INTO WREG1 07860000 IC WREG1,PNDDGT 07880000 * SAVE START 07900000 ST MASKER,SAVEMASK 07920000 * START AT MASK 07940000 LA MASKER,MASK 07960000 PICKUP EQU * 07980000 * SCAN PICTURE 08000000 * CHAR FOUND, BRANCH TO ROUTINE 08020000 CLI 0(PICTURE),C'9' 08040000 BE NINE 08060000 CLI 0(PICTURE),C'Z' 08080000 BE ZZED 08100000 CLI 0(PICTURE),C'*' 08120000 BE STAR 08140000 CLI 0(PICTURE),C'$' 08160000 BE POND 08180000 CLI 0(PICTURE),C'+' 08200000 BE SIGN 08220000 CLI 0(PICTURE),C'-' 08240000 BE SIGN 08260000 * THEN MUST BE SEPARATOR 08280000 B SEPT 08300000 EJECT 08320000 * ROUTINES TO HANDLE POUND CHARACTERS 08340000 * 08360000 POND EQU * 08380000 * POUND MAY BE STATIC OR A FLOAT STRING 08400000 TM FLAGB,TRANMASK TRANSFER TO DIGIT MASK YET 08420000 BO STARDGT YES, STORE DIGIT SELECT 08440000 * NO, MAY BE FLOAT STRING 08460000 SR WREG2,WREG2 08480000 IC WREG2,1(PICTURE) TEST COUNT = 1 08500000 BCT WREG2,FLTCHAR 08520000 NOFLT EQU * COUNT IS 1,SO STATIC - MOVE TO OUTPUT AREA 08540000 MVC 0(1,TARGET),0(PICTURE) 08560000 LA TARGET,1(TARGET) 08580000 LA PICTURE,2(PICTURE) 08600000 B PICKUP GET NEXT CHARACTER 08620000 * COUNT EXCEEDS 1, FLOATING STRING 08640000 FLTCHAR EQU * 08660000 MVC FLOAT(1),0(PICTURE) SAVE FLOAT CHAR 08680000 B STARDGTA 08700000 SPACE 1 08720000 SIGN EQU * 08740000 * SIGN MAY BE STATIC OR A FLOAT STRING 08760000 TM FLAGB,TRANMASK TRANSFER TO DIGIT MASK YET 08780000 BO STARDGT YES STORE DIGIT SELECT 08800000 * HOW IS SIGN TO PRINT 08820000 * IS CHAR + 08840000 CLI 0(PICTURE),C'+' 08860000 BNE SIGNA NO 08880000 * CHAR IS + IS SIGN + 08900000 MVI SIGNCHAR,C'+' 08920000 CP SSIGN(1),ZERO(1) 08940000 BH SIGNB YES 08960000 MVI SIGNCHAR,C'-' NO 08980000 B SIGNB 09000000 * CHAR IS -, IS SIGN - TOO 09020000 SIGNA MVI SIGNCHAR,C' ' 09040000 CP SSIGN(1),ZERO(1) 09060000 BH SIGNB NO 09080000 MVI SIGNCHAR,C'-' NO 09100000 * IS CHAR FLOATING 09120000 SIGNB EQU * 09140000 SR WREG2,WREG2 09160000 IC WREG2,1(PICTURE) 09180000 BCT WREG2,SIGNC YES 09200000 * COUNT IS 1,SO STATIC - MOVE TO OUTPUT AREA 09220000 MVC 0(1,TARGET),SIGNCHAR 09240000 LA TARGET,1(TARGET) 09260000 LA PICTURE,2(PICTURE) 09280000 LTR WREG1,WREG1 IS IT STATIC SIGN,NO POUND DIGITS 09300000 BP PICKUP NO.SINCE POUND COUNT PLUS 09320000 B LOOPS1 YES.THEN PROCESS POUND SEPARATORS 09340000 * FLOAT CHAR, SAVE IN FLOAT 09360000 SIGNC EQU * 09380000 MVC FLOAT(1),SIGNCHAR 09400000 B STARDGTA 09420000 EJECT 09440000 * CHAR IS 9 09460000 NINE EQU * 09480000 * IF FIRST 9 ENCOUNTERED SAVE POSITION 09500000 * SO THAT 0 CAN BE INSERTED IF FIRST DIGIT IS ZERO 09520000 TM FIRST9,X'01' 09540000 BO STARDGT 09560000 ST MASKER,FIRST9 09580000 OI FIRST9,X'01' 09600000 * STORE SIGNIFICANT START IN MASK 09620000 NINE1 MVI 0(MASKER),X'21' 09640000 LA MASKER,1(MASKER) 09660000 BCTR WREG1,0 ONE FROM DIGIT COUNT 09680000 SR WREG2,WREG2 09700000 IC WREG2,1(PICTURE) 09720000 * IF ONLY ONE CHAR UPDATE COUNTERS, 09740000 * OTHERWISE PROPAGATE DIGIT SELECTS. 09760000 BCT WREG2,STARDGTA 09780000 B STARA 09800000 * 09820000 SEPT EQU * 09840000 * 0 , AND B 09860000 * SEPARATOR MAY BE STATIC OR AN INSERTION CHARACTER 09880000 LR R1,MASKER 09900000 TM FLAGB,TRANMASK TRANSFER TO DIGIT MASK YET 09920000 BO SEPTM YES,STORE IN MASK 09940000 LR R1,TARGET ELSE STORE IN OUTPUT AREA 09960000 SEPTM MVC 0(1,R1),0(PICTURE) 09980000 SR WREG2,WREG2 10000000 IC WREG2,1(PICTURE) 10020000 * PROPAGATE IF COUNT NOT 1 10040000 BCT WREG2,SEPTMC 10060000 B SEPTMA 10080000 SEPTMC EQU * 10100000 BCTR WREG2,0 10120000 EX WREG2,SEPTMV 10140000 SEPTMA IC WREG2,1(PICTURE) 10160000 LA PICTURE,2(PICTURE) 10180000 TM FLAGB,TRANMASK TRANSFER TO DIGIT MASK YET 10200000 BO SEPTMB YES UPDATE MASK POSITION 10220000 AR TARGET,WREG2 10240000 B PICKUP GET NEXT CHARACTER 10260000 SEPTMB AR MASKER,WREG2 10280000 B PICKUP GET NEXT CHARACTER 10300000 SEPTMV MVC 1(0,R1),0(R1) 10320000 EJECT 10340000 STARDGT EQU * 10360000 * STORE DIGIT SELECT CHARACTERS IN THE EDIT MASK 10380000 * PICK UP COUNT FROM PICTURE 10400000 SR WREG2,WREG2 10420000 IC WREG2,1(PICTURE) 10440000 STARDGTA EQU * ENTRY WHEN WREG2 ALREADY SET TO TRUE COUNT 10460000 * STORE DIGIT SELECTS IN MASK 10480000 MVI 0(MASKER),X'20' DIGIT SELECT 10500000 BCT WREG2,PONDA 10520000 LA WREG2,1(WREG2) 10540000 B STARA 10560000 PONDA EQU * 10580000 * DECREMENT COUNT BY 1 FOR EX OF MVC 10600000 BCTR WREG2,0 10620000 PONDSET EX WREG2,PONDMV 10640000 * RESET COUNT 10660000 LA WREG2,2(WREG2) 10680000 STARA EQU * 10700000 OI FLAGB,TRANMASK TRANSFER TO DIGIT MASK HAS STARTED 10720000 * UPDATE MASK AND PICTURE 10740000 AR MASKER,WREG2 10760000 LA PICTURE,2(PICTURE) 10780000 * DECREMENT DIGIT COUNTER (WREG1) 10800000 SR WREG1,WREG2 10820000 BP PICKUP GET NEXT CHARACTER IF ANY LEFT 10840000 B EDIT ELSE START EDIT 10860000 PONDMV MVC 1(0,MASKER),0(MASKER) LENGTH SET BY PONDSET 10880000 SPACE 1 10900000 * CHAR IS * 10920000 * 10940000 STAR EQU * 10960000 * STORE * AS FILL CHAR 10980000 L WREG2,SAVEMASK START OF MASK 11000000 MVI 0(WREG2),C'*' 11020000 B STARDGT 11040000 SPACE 1 11060000 * CHAR IS Z USE STARDGT 11080000 ZZED EQU STARDGT 11100000 EJECT 11120000 * NO MORE, NOW EDIT AND MARK (MAY BE FLOATING CHAR) 11140000 EDIT EQU * 11160000 * COMPUTE STARTING POINT 11180000 L R1,SAVEMASK 11200000 LR WREG2,R1 FOR EDMK 11220000 LA R1,1(R1) FIRST CHAR + 1 11240000 * COMPUTE LENGTH OF EDIT 11260000 LR GEN,MASKER SAVE POSITION 11280000 SR MASKER,R1 (END+1)-(START+1) = LENGTH-1 11300000 * ESTABLISH R1 11320000 L R1,FIRST9 SET REG 1 TO FLOAT POSITION 11340000 LA WREG1,INTEGER 11360000 AH WREG1,SAVEOFF 11380000 EDITEX EX MASKER,EDITPND 11400000 * OVERLAY SIG. START DIGIT IF FILL CHAR 11420000 L WREG2,FIRST9 11440000 LTR WREG2,WREG2 11460000 BZ EDITCA 11480000 CLI 0(WREG2),C' ' 11500000 BE EDITC 11520000 CLI 0(WREG2),C'*' 11540000 BNE EDITCA 11560000 EDITC MVI 0(WREG2),C'0' 11580000 * DIGIT WASN'T ZERO 11600000 EDITCA EQU * 11620000 TM FLAGA,NOPOUND IS POUND FIELD ZERO 11640000 BO PSEPA YES 11660000 * IS THERE A FLOAT CHAR 11680000 EDITA1 TM FLOAT,X'FF' 11700000 BZ EDITB NO 11720000 MVI MASKX,C' ' 11740000 * STORE FLOAT AT R1-1 11760000 EDITB1 BCTR R1,0 11780000 MVC 0(1,R1),FLOAT 11800000 * MOVE EDITED RESULT TO TARGET 11820000 EDITE LA R1,MASKX 11840000 B EDITD 11860000 EDITB LA R1,MASK 11880000 EDITD EQU * 11900000 * COMPUTE LENGTH OF MOVE 11920000 SR GEN,R1 END+1-START=LENGTH 11940000 BCTR GEN,0 11960000 EX GEN,EDITX 11980000 * UPDATE TARGET 12000000 AR TARGET,GEN 12020000 LA TARGET,1(TARGET) OFF BY 1 12040000 * NOW PROCESS L SEPARATOR TILL C OR D 12060000 B LOOPS1 12080000 EDITPND EDMK 0(0,WREG2),0(WREG1) 12100000 EDITX MVC 0(0,TARGET),0(R1) 12120000 * 12140000 * POUND FIELD ZERO, ANYTHING SPECIAL 12160000 PSEPA EQU * 12180000 * WAS THERE A NINE IN THE PICTURE 12200000 TM FIRST9,X'01' 12220000 BO EDITA1 THEN TEST FOR FLOAT 12240000 * NOTHING SPECIAL, BUT DELIMITER MAY BE C 12260000 PSEPX TM INFOA,PDILIMC DILIMITER A C 12280000 BZ PSEPB NO 12300000 OI FLAGA,DROPPSEP DELIMITER IS C SO DROP SEPARATORS 12320000 PSEPB EQU * WAS THERE A FLOAT CHARACTER 12340000 TM FLOAT,X'FF' 12360000 BZ EDITB 12380000 B EDITE 12400000 EJECT 12420000 * LOOPS1 PROCESSES L SEPARATORS 12440000 * TARGET IS POINTING TO NEXT AVAILABLE ENTRY 12460000 * PICTURE IS POINTING TO NEXT CHARACTER 12480000 * 12500000 LOOPS1 CLI 0(PICTURE),C'C' 12520000 BE GETSHILL 12540000 CLI 0(PICTURE),C'D' 12560000 BE GETSHILL 12580000 * THEN MUST BE SEPARATORS 12600000 TM FLAGA,DROPPSEP SEPORATOR CHARS TO BE DROPPED 12620000 BO LOOPS1A YES 12640000 MVC 0(1,TARGET),0(PICTURE) 12660000 * IF COUNT NOT 1 PROPAGATE 12680000 LOOPS3 SR WREG2,WREG2 12700000 IC WREG2,1(PICTURE) 12720000 BCT WREG2,STARG 12740000 B LOOPS1B 12760000 STARG EQU * 12780000 * NOT 1 12800000 BCTR WREG2,0 12820000 EX WREG2,PROPTRGT PROPAGATE IN TARGET 12840000 * RESET WREG2 12860000 LOOPS1B IC WREG2,1(PICTURE) 12880000 * UPDATE TARGET 12900000 AR TARGET,WREG2 12920000 LA PICTURE,2(PICTURE) 12940000 * NOW GET NEXT SEPARATOR 12960000 B LOOPS1 12980000 * EITHER BLANK OR * TO BE INSERTED 13000000 LOOPS1A EQU * 13020000 * REDUCE TARGET BY 1 TO GET PREVIOUS CHAR 13040000 BCTR TARGET,0 13060000 MVC 1(1,TARGET),0(TARGET) 13080000 LA TARGET,1(TARGET) 13100000 B LOOPS3 13120000 EJECT 13140000 * PROCESS SHILLINGS FIELD 13160000 * PICTURE POINTS TO DELIMITER 13180000 * TARGET POINTS TO NEXT ENTRY IN TARGET FIELD 13200000 GETSHILL EQU * 13220000 * UPDATE PICTURE - SKIP DELIMITER 13240000 PNDSKP EQU * 13260000 LA PICTURE,2(PICTURE) 13280000 * UNPACK SHILLINGS 13300000 * ONLY TWO LOW ORDER DIGITS ARE UNPACKED 13320000 * HENCE UP TO 99 SHILLS WILL BE HANDLED 13340000 UNPK WORKSH(4),INTEGER+XX-3-1(3) HIGH ZERO IS DROPPED 13360000 * ENTRY FROM GETPENCE 13380000 * SAME PROCESSING FOR SHILL AS PENCE 13400000 * OPERATE ON HIGH ORDER DIGIT 13420000 * IS IT ZERO 13440000 GETSHILM CLI WORKSH,C'0' 13460000 BE SHILLA YES 13480000 * NON ZERO, STORE IN TARGET 13500000 SHILLB OI FLAGB,HIDIGSIG HIGH DIGIT SIGNIFICANT 13520000 MVC 0(1,TARGET),WORKSH 13540000 B LOWSH 13560000 * IS PICTURE 9 13580000 SHILLA CLI 0(PICTURE),C'9' 13600000 BE SHILLB 13620000 * IS PICTURE * 13640000 CLI 0(PICTURE),C'*' 13660000 BNE SHILLC NO 13680000 SHILLD MVI 0(TARGET),C'*' 13700000 B LOWSH 13720000 SHILLC EQU * 13740000 * NO, STORE BLANK 13760000 SHILLCX MVI 0(TARGET),C' ' 13780000 LOWSH EQU * 13800000 * DOES PICTURE POINTER NEED UPDATING IS CHARACTER COUNT 1 13820000 CLI 1(PICTURE),X'01' 13840000 BNE LOWSHB NO 13860000 LA PICTURE,2(PICTURE) YES UPDATE POINTER 13880000 LOWSHB EQU * 13900000 * NOW OPERATE ON LOW SHILL DIGIT 13920000 CLI WORKSH+1,C'0' 13940000 BE SHILLE ZERO 13960000 SHILLF MVC 1(1,TARGET),WORKSH+1 13980000 B SHILLSEP 14000000 * DIGIT ZERO, IS PICTURE 9 14020000 SHILLE CLI 0(PICTURE),C'9' 14040000 BE SHILLF YES 14060000 TM FLAGB,HIDIGSIG HIGH DIGIT SIGNIFICANT 14080000 BO SHILLF YES, STORE DIGIT 14100000 * NO, IS PICTURE 8 14120000 CLI 0(PICTURE),C'8' 14140000 BNE SHILLG NO 14160000 * YES, IF POUNDS NON ZERO STORE DIGIT 14180000 TM FLAGB,PENPROC IS THIS PENCE PROCESSING 14200000 BZ SHILLEA NO 14220000 TM FLAGA,NOSHILL ANY SHILLINGS 14240000 BZ SHILLF YES 14260000 * NO SHILL, SO NO POUNDS 14280000 B SHILLEB 14300000 SHILLEA TM FLAGA,NOPOUND IS POUND FIELD ZERO 14320000 BZ SHILLF POUNDS PRESENT 14340000 * NO POUNDS PRESENT,PROPAGATE PREVIOUS CHAR 14360000 SHILLEB MVC 1(1,TARGET),0(TARGET) 14380000 B SHILLSEP 14400000 * IS PICTURE * 14420000 SHILLG CLI 0(PICTURE),C'*' 14440000 BNE SHILLH NO 14460000 SHILLI MVI 1(TARGET),C'*' YES, STORE * 14480000 B SHILLSEP 14500000 * PICTURE IS Z, PROPAGATE PREVIOUS CHAR 14520000 SHILLH MVI 1(TARGET),C' ' 14540000 * NOW PROCESS SEPARATORS IF ANY 14560000 EJECT 14580000 SHILLSEP EQU * PROCESS SEPARATORS,FIRST INITIALISE,CHK SUPPRESSION 14600000 * TARGET IS POINTING TO HIGH SHILLING ENTRY 14620000 * PICTURE IS POINTING TO LOW SHILLING ENTRY 14640000 LA TARGET,1(TARGET) NOW AT LOW SHILLING ENTRY 14660000 LA PICTURE,2(PICTURE) NOW AT NEXT PICTURE ENTRY 14680000 TM FLAGB,PENPROC IS THIS PENCE PROCESSING 14700000 BO GETPENCF YES,EXIT 14720000 TM INFOA,SDILIMC IS DILIMITER A C 14740000 BZ SHILLSA NO 14760000 * ZERO SHILL, DELIMITER C, DROP SEPARATORS 14780000 * IF PREVIOUS CHAR IS * OR BLANK 14800000 CLI 0(TARGET),C'*' 14820000 BE SHILLSE 14840000 CLI 0(TARGET),C' ' 14860000 BNE SHILLSA 14880000 SHILLSE EQU * 14900000 OI FLAGA,DROPSSEP DROP SEPARATORS 14920000 SHILLSA EQU * RESET POINTERS (TARGET IS AT LOW SHILLING ENTRY) 14940000 LA TARGET,1(TARGET) NOW AT NEXT AVAILABLE ENTRY 14960000 SHILLSF EQU * NOW PROCESS SEPARATORS 14980000 * TARGET POINTS TO NEXT AVAILABLE ENTRY 15000000 * PICTURE POINTS TO NEXT CHARACTER 15020000 *** IS DELIMITER REACHED YET 15040000 CLI 0(PICTURE),C'C' 15060000 BE SHILLSB DELIMITER 15080000 CLI 0(PICTURE),C'D' 15100000 BE SHILLSB DELIMITER 15120000 * NOT DELIMITER, STORE CHAR,OR SUPPRESS WITH * OR BLANK 15140000 MVC 0(1,TARGET),0(PICTURE) 15160000 TM FLAGA,DROPSSEP DROP SEPARATORS 15180000 BZ SHILLSC NO 15200000 * SUPPRESS,WITH PREVIOUS TARGET CHAR. 15220000 BCTR TARGET,0 15240000 MVC 1(1,TARGET),0(TARGET) 15260000 LA TARGET,1(TARGET) 15280000 * NOW SEE IF SEPARATOR IS TO BE PROPAGATED 15300000 SHILLSC SR WREG2,WREG2 15320000 IC WREG2,1(PICTURE) 15340000 BCT WREG2,SHILLT 15360000 B SHILLSD 15380000 SHILLT EQU * 15400000 BCTR WREG2,0 15420000 EX WREG2,PROPTRGT PROPAGATE IN TARGET 15440000 * UPDATE POINTERS TO NEXT ENTRY 15460000 SHILLSD IC WREG2,1(PICTURE) 15480000 AR TARGET,WREG2 15500000 LA PICTURE,2(PICTURE) 15520000 B SHILLSF PROCESS NEXT PICTURE CHARACTER 15540000 EJECT 15560000 SHILLSB EQU * DELIMITER REACHED,SO SPACE OVER,AND PROCESS PENCE 15580000 LA PICTURE,2(PICTURE) POINT TO NEXT PICTURE CHARACTER 15600000 * PROCESS PENCE, USE GETSHILL, BUT TURN ON PENCE SW 15620000 GETPENCE EQU * 15640000 * TARGET POINTS TO NEXT AVAILABLE ENTRY 15660000 * PICTURE POINTS TO NEXT PICTURE CHARACTER 15680000 OI FLAGB,PENPROC NOTE THIS IS PENCE 15700000 NI FLAGB,IHDIGSIG RESET HIDIGSIG BIT 15720000 UNPK WORKSH(4),INTEGER+XX-1-1(3) 15740000 B GETSHILM 15760000 * 15780000 GETPENCF EQU * RETURN FROM GETSHILM 15800000 * TARGET POINTS TO LOW PENCE ENTRY 15820000 * PICTURE POINTS TO NEXT PICTURE CHARACTER 15840000 * AT THE END OF THE PICTURE YET 15860000 MVC TEMP1+1(3),PCTADD+1 15880000 L WREG2,TEMP1 15900000 LA WREG2,0(WREG2) CLEAR TOP 8 BITS 15920000 SR GEN,GEN 15940000 IC GEN,PCTLNG 15960000 AR WREG2,GEN 15980000 * WREG2 NOW HAS LOCATION OF END OF PICTURE PLUS ONE 16000000 * 16020000 CR WREG2,PICTURE 16040000 BH PENCESEP PROCESS PENCE SEPARATORS OR DECIMALS 16060000 B FINISH 16080000 * MORE TO GO, HANDLE SEPARATOR 16100000 PENCESEP EQU * 16120000 * PROCESS PENCE SEPARATORS 16140000 * 16160000 * ANY DECIMAL PENCE 16180000 SR WREG1,WREG1 16200000 IC WREG1,DECDGT 16220000 LTR WREG1,WREG1 16240000 BZ NOPDEC NO 16260000 * YES, UNPACK INTO DECIMAL 16280000 UNPK DECIMAL(16),2(8,SOURCE) 16300000 UNPK DECIMAL+15(2*XX-17),9(XX-8,SOURCE) 16320000 * PUT LOCATION FIRST DIGIT IN REGISTER GEN 16340000 LA GEN,DECIMAL+28 16360000 SR GEN,WREG1 16380000 EJECT 16400000 NOPDEC EQU * 16420000 * PICK UP PICTURE CHAR AND PROCESS 16440000 LA TARGET,1(TARGET) SET TARGET TO NEXT AVAIL ENTRY 16460000 * IT WAS AT LOW PENCE 16480000 * END OF PICTURE IS IN WREG2 16500000 PLOOP CR WREG2,PICTURE 16520000 BNH FINISH PAST END - THATS IT 16540000 CLI 0(PICTURE),C'9' 16560000 BE PNINE NINE 16580000 CLI 0(PICTURE),C'C' 16600000 BE PCRED CREDIT 16620000 CLI 0(PICTURE),C'D' 16640000 BE PDEBIT DEBIT 16660000 CLI 0(PICTURE),C'+' 16680000 BE PPLUS PLUS 16700000 CLI 0(PICTURE),C'-' 16720000 BE PMINUS MINUS 16740000 * NOTHING SPECIAL, SO STORE 16760000 MVC 0(0,TARGET),0(PICTURE) 16780000 * PROPAGATE IF NEED BE 16800000 SR WREG1,WREG1 16820000 IC WREG1,1(PICTURE) EXAMINE COUNT 16840000 BCT WREG1,PLOOR 16860000 B PLOOP1 16880000 PLOOR EQU * 16900000 BCTR WREG1,0 16920000 EX WREG1,PROPTRGT PROPAGATE IN TARGET 16940000 * UPDATE POINTERS TO NEXT AVAILABLE ENTRY 16960000 PLOOP1 IC WREG1,1(PICTURE) 16980000 LA PICTURE,2(PICTURE) 17000000 AR TARGET,WREG1 17020000 B PLOOP 17040000 EJECT 17060000 PNINE EQU * 17080000 * STORE DIGITS 17100000 * SEE HOW MANY 17120000 SR WREG1,WREG1 17140000 IC WREG1,1(PICTURE) 17160000 BCTR WREG1,0 REDUCE FOR MOVE 17180000 EX WREG1,PNINEMV MOVE FROM DECIMAL TO TARGET 17200000 LA WREG1,1(WREG1) 17220000 AR TARGET,WREG1 17240000 LA PICTURE,2(PICTURE) 17260000 AR GEN,WREG1 17280000 B PLOOP 17300000 PNINEMV MVC 0(0,TARGET),0(GEN) 17320000 * CREDIT, INSERT CR IF SIGN - 17340000 * DEBIT, INSERT DB IF SIGN - 17360000 PCRED OI FLAGB,INSERTCR INSERT CREDIT 17380000 PDEBIT EQU * INSERT DB 17400000 * IS SIGN - 17420000 CP SSIGN(1),ZERO(1) 17440000 BH PBLANK NO, SIGN + 17460000 * SIGN MINUS, MOVE CR OR DB 17480000 TM FLAGB,INSERTCR INSERT CREDIT SYMBOL 17500000 BO PCREDA CR 17520000 * INSERT DB 17540000 MVC 0(2,TARGET),DB 17560000 B FINISH 17580000 PCREDA MVC 0(2,TARGET),CR 17600000 B FINISH 17620000 PBLANK MVC 0(2,TARGET),BL 17640000 B FINISH 17660000 * 17680000 PPLUS EQU * INSERT + 17700000 CP SSIGN(1),ZERO(1) 17720000 BL PMINUSA 17740000 MVI 0(TARGET),C'+' 17760000 B FINISH 17780000 PPLUSA MVI 0(TARGET),C' ' 17800000 B FINISH 17820000 PMINUS CP SSIGN(1),ZERO(1) 17840000 BH PPLUSA 17860000 PMINUSA MVI 0(TARGET),C'-' 17880000 EJECT 17900000 FINISH EQU * 17920000 L WREG1,0(RG) 17940000 LTR WREG1,WREG1 IS SIZE ERROR OPTION SPEC'D 17960000 BZ FINSH1 NO, EXIT 17980000 LR RETURN,WREG1 YES, RETURN TO NO ERROR ADDRESS 18000000 LM 3,11,REGSAVE 18020000 BR RETURN 18040000 FINSH1 EQU * 18060000 * RESTORE THE REGISTERS AND EXIT 18080000 LM 3,11,REGSAVE 18100000 B 6(RETURN) 18120000 * 18140000 PROPTRGT MVC 1(0,TARGET),0(TARGET) PROPOGATE IN TARGET 18160000 * 18180000 * CONSTANTS 18200000 PDIGITS DC AL2(2*(XX-4)-1) 18220000 PBYTESZ DC AL2(XX-4-1) 18240000 DB DC C'DB' 18260000 CR DC C'CR' 18280000 BL DC C' ' 18300000 TWNTY DC PL2'20' 20+ 18320000 TWLV DC PL2'12' 12+ 18340000 MAXSHILS DC PL2'99' 99 SHILLS MAX IF NO POUNDS 18360000 ZERO DC PL1'0' 0+ 18380000 BLDS DC C' ' 18400000 DC X'20' MUST FOLLOW BLDS 18420000 * SCAN IS USED TO EXAMINE TWELVE BYTES IN A TRT INST. 18440000 SCAN DC XL(XX-4)'000102030405060708090A0B' 18460000 EJECT 18480000 STORAGE EQU * 18500000 * DEFINE STRUCTURE OF WORKING STORAGE 18520000 * SPACE TO SAVE REGISTERS 18540000 REGSAVE DS (REGTO-REGFROM+1)F 18560000 * TEMPORARY STORES 18580000 PCTADD DS F 18600000 SZEERR DS F 18620000 TEMP1 DS FL1 18640000 SAVEMASK DS F 18660000 FIRST9 DS F 18680000 FIRST91 EQU FIRST9+1 18700000 SAVEOFF DS H 18720000 SIGNCHAR DS C 18740000 * 18760000 FLAGA DS CL1 STATUS FLAGS 18780000 * BIT MEANINGS FOR FLAG A 18800000 NOPOUND EQU X'01' POUND VALUE IS ZERO 18820000 NOSHILL EQU X'02' SHILL VALUE IS ZERO (ALSO POUND) 18840000 DROPPSEP EQU X'04' DROP POUND SEPARATORS 18860000 DROPSSEP EQU X'08' DROP SHILL SEPARATORS 18880000 * 18900000 FLAGB DS CL1 18920000 * BIT MEANINGS FOR FLAG B 18940000 TRANMASK EQU X'10' TRANSFER TO POUND DIGIT MASK HAS STARTED 18960000 DUMMYPOS EQU X'20' DUMMY DIGIT POSITION IN MASK 18980000 HIDIGSIG EQU X'40' HIGH ORDER DIGIT POSIT IS SIGNIF SHILL OR PEN 19000000 IHDIGSIG EQU X'BF' X'-40' INVERT OF HISIGDIG 19020000 PENPROC EQU X'80' PENCE PROCESSING IN SHILLS LOOP 19040000 INSERTCR EQU X'01' INSERT CREDIT SYMBOL 19060000 * 19080000 FLOAT DS CL1 FLOATING CHAR 19100000 SSIGN DS CL1 SIGN OF SOURCE 19120000 MASKXX DS CL1 DUMMY DIGIT 19140000 MASKX DS CL1 FOR EXTRA DIGIT 19160000 MASK DS CL127 127BYTE EDIT MASK 19180000 WORKSH DS CL2 19200000 INTEGER DS CL(XX) XX BYTES FOR SOURCE INTEGER DIGITS PACKED 19220000 DECIMAL DS CL(2*XX) 2*XX BYTES FOR SOURCE DECIMAL DIGITS UNPACKED 19240000 ENDSTOR DS 0F 19260000 STORESIZ EQU ENDSTOR-REGSAVE AMOUNT OF WORKSPACE NEEDED 19280000 PARAM DSECT 19300000 * DEFINE CALLING SEQUENCE PARAMETERS 19320000 PAR1 DS 0C 19340000 PCTLNG DS CL1 PICTURE LENGTH 19360000 TRGLNG DS CL1 TARGET LENGTH 19380000 DECDGT DS CL1 NO. DECIMAL DIGITS 19400000 PNDDGT DS CL1 NO. POUND DIGITS 19420000 * 19440000 INFOA DS C SOURCE INFO FLAGS 19460000 * BIT MEANINGS FOR INFOA 19480000 BLANKWZ EQU X'80' BLANK WHEN ZERO CLAUSE 19500000 SDILIMC EQU X'40' SHILL DELIM IS C 19520000 PDILIMC EQU X'20' POUND DELIM IS C 19540000 PSEPONLY EQU X'10' POUND FIELD SEPARATORS ONLY 19560000 * 19580000 PAR2 DS 0C 19600000 DISPLACE EQU PAR2-PAR1 19620000 EJECT 19640000 END 19660000 EJECT 19680000