./ ADD SSI=01011301,NAME=IHCADJST,SOURCE=0 ADJS TITLE 'IHCADJST - FORTRAN G/H LIBRARY BOUNDRY ALIGNMENT MODULE' 00020000 * IHCADJST 00040000 * 00043000 *1332 017000,020650,030800,039600,059600 MAINT 00046000 *C053400 59714 00047022 *A053500 59714 00048022 * 00049000 * STATUS -- CHANGE LEVEL 02 -- 1 AUGUST 1974 -- RELEASE 21.8 00052022 * 00055000 * FUNCTION/OPERATION--IHCADJST IS A MEMBER OF THE LINK LIBRARY AND IS 00060000 * USED TO PROVIDE EXECUTION-TIME ADJUSTMENT OF BOUNDARY 00080000 * MISALIGNMENTS OCCURRING IN A FORTRAN PROGRAM. 00100000 * ENTRY POINT - 00140000 * 'IHCADJST' IS THE FIRST INSTRUCTION OF THE BOUNDARY ALIGNMENT 00160000 * ROUTINE. ENTRY IS FROM THE INTERRUPT HANDLING 00180000 * ROUTINE ( ARITH) IN IBCOM (IHCFCOMH). 00200000 * INPUT - INPUT CONSISTS OF PARAMETERS PASSED FROM ARITH IN REGISTERS. 00220014 * REGISTER 14 CONTAINS ENTRY POINT TO IHCADJST (USED 00240000 * TO ESTABLISH ADDRESSABILITY) 00260000 * REGISTER 15 CONTAINS THE ADDRESS OF REGISTER SAVE 00280000 * AREA IN ARITH. 00300000 * REGISTER 1 CONTAINS THE ADDRESS OF A PARAMETER 00308014 * LIST IN ARITH. THE PARAMETER LIST 00316014 * CONSISTS OF - 00324014 * (1) THE SUPERVISOR RETURN ADDRESS 00332014 * (2) AN S-TYPE ADCON OF THE ROUTINE IN 00340014 * ARITH WHICH IS USED TO WRITE THE 00348014 * BOUNDARY ALIGNMENT MESSAGE 00356014 * (3) THE ADDRESS OF THE PIE 00364014 * (4) THE ADDRESS OF IHCUOPT. 00372014 * (IHCUOPT SPECIFIES THE MAXIMUM 00380014 * NUMBER OF BOUNDARY ALIGNMENT 00388014 * MESSAGES TO BE WRITTEN) 00396014 * (5) THE ADDRESS OF INT6SW 00404014 * (INT6SW IS A SWITCH LOCATED IN 00412014 * IHCFCVTH WHICH INDICATES WHETHER 00420014 * A BOUND. ALIGNMENT ERROR HAS 00428014 * OCCURRED FOR AN ITEM BEING READ 00436014 * OR WRITTEN) 00444014 * REGISTER 2 CONTAINS ADCON OF FIOCS# 00460000 * OUTPUT - OUTPUT CONSISTS OF MESSAGES AND PROPER EXECUTION OF 00480000 * INSTRUCTION WHICH CAUSED BOUNDARY ALIGNMENT ERROR. 00500000 * EXTERNAL ROUTINES- 00520000 * ROUTINE ARITH IN IBCOM 00540000 * EXITS- 00560000 * NORMAL- 00580000 * 1. RETURN TO PROBLEM PROGRAM VIA SUPERVISOR 00600000 * 2. RETURN TO PROBLEM PROGRAM VIA ROUTINE ARITH IN 00620000 * CASE OF AN ARITHMETIC INTERRUPT OCCURRING WHEN 00640000 * REEXECUTING THE BOUNDARY ALIGNMENT ERROR INSTR. 00660000 * ERROR- 00680000 * JOB WILL ABEND UNDER THE FOLLOWING CONDITIONS- 00700000 * 1. BOUNDARY ALIGNMENT WAS ENTERED AS A RESULT OF 00720000 * A BRANCH TO AN ODD LOCATION. 00740000 * 2. INSTRUCTION LENGTH IS NOT EQUAL TO 2 00760000 * 3. INSTRUCTION IS ONE ON WHICH AN ALIGNMENT 00780000 * PROBLEM SHOULD NOT OCCUR 00800000 * 4. OTHER SPECIFICATION ERRORS EXIST (OTHER THAN 00820000 * DATA MISALIGNMENT) 00840000 * 5. A DATA, PROTECTION, OR ADDRESSING INTERRUPT 00860000 * OCCURRING ON THE BOUNDARY ALIGNMENT ERROR INSTR. 00880000 * TABLES/WORK AREAS- 'PIESAVE' - SAVE AREA FOR THE PROGRAM 00900000 * INTERRUPTION ELEMENT WHICH EXISTS ON 00920000 * ENTRY TO THE BOUNDARY ALIGNMENT 00940000 * ROUTINE. 00960000 * REGISTER SAVE AREAS 00980000 * ATTRIBUTES - SERIALLY REUSABLE 01000000 * NOTES- 01020000 * THE ROUTINE IS BROUGHT INTO CORE BY A LOAD MACRO 01040000 * ON THE FIRST OCCURRENCE OF A SPECIFICATION 01060000 * INTERRUPT IN THE PROBLEM PROGRAM. 01080000 * THE CALLING OF THIS ROUTINE AT EXECUTION TIME IS 01100000 * DEPENDENT ON A SYSGEN OPTION SPECIFIED IN THE 01120000 * MODULE IHCUOPT WHICH IS LINK EDITED WITH IBCOM. 01140000 * THE NUMBER OF BOUNDARY ALIGNMENT MESSAGES ISSUED 01160000 * IS ALSO AN OPTION SPECIFIED IN IHCUOPT. 01180000 * 01200000 IHCADJST CSECT 01220000 USING *,BASE 01240000 B ADJBGN 01260000 DC X'07' 01280000 DC CL7'BNDRADJ' 01300000 * 01320000 ADJBGN MVC RETURN(24),0(1) GET PARAMETERS HWRE 01360014 ST 2,ADFIOCS SAVE A(FIOCS=) 01400000 L 1,PIEADDR HWRE 01415014 LM 2,13,8(15) RESTORE REGS USED BY ARITH HWRE 01420014 TM 11(1),X'01' 01440000 BO INSTEND INSTR ON WRONG BOUNDARY- ABEND 01460000 MVI SWITCH1,X'00' RESET SWITCHES 01480000 MVI SWITCH2,X'00' 01500000 L WORK1,8(0,1) OBTAIN INSTRUCTION WHICH 01520000 N WORK1,ADRMSK CAUSED SPEC. INTERRUPT AND 01540000 SH WORK1,HFOUR HOLD IN WORK1 01560000 TM 8(1),X'40' ILC NOT = 2, ABEND 01580000 BO SPECERR 01600000 MVC INSTRWA,0(WORK1) MOVE INSTR TO WORK AREA 01620000 * TEST OP CODE OF INSTRUCTION TO DETERMINE IF IT IS ONE 01640000 * FOR WHICH BOUNDARY VIOLATION IS HANDLED. 01660000 CLI INSTRWA,X'80' 01680000 BNL RSTEST TEST IF LM,STM RS INSTRUCTION MAINT 01700000 CLI INSTRWA,X'5F' TEST INSTRUCTION TYPE 01720000 BNH FIXPT FIXED PT 01740000 * INSTRUCTION IS FLOATING POINT 01760000 MVI FLPTSW,FLOAT SET SW TO SPECIFY FL PT 01780000 * TEST IF FLOAT PT REGISTER USED 01800000 TM INSTRWA+1,B'10010000' 01820000 BNZ SPECEND IMPROPER REGISTER - ABEND 01840000 BOUND10 TM INSTRWA,X'0F' TEST OP CODE = STORE 01860000 BZ STSWSET STORE INSTR 01880000 TM INSTRWA,B'00000010' 01900000 BO CCSWSET BIT 2 NOT = 0 01920000 TM INSTRWA,B'00000001' 01940000 BZ BOUND20 BIT 1 =0 01960000 TM INSTRWA,B'00000100' 01980000 BZ CCSWSET BIT 4 = 0 02000000 BOUND20 MVC PIESAVE,0(1) PLACE CURRENT PIE IN SAVE AREA 02020000 MVC REEXEC(2),INSTRWA MOVE OP,R1 OF INST TO AREA 02040000 CLI RSSW,LMSTM MAINT 02046000 BE SAVERG3 SAVE R3FIELD OF INSTRUCTION MAINT 02052000 NI REEXEC+1,X'F0' USED FOR REEXECUTION 02060000 SAVERG3 L WORK2,AINT6SW MAINT 02065000 CLI 0(WORK2),X'00' 4648 02070013 BNE NOMSG 4648 02075013 L WORK2,ADROPT LOAD REG FOR REFERENCE TO IHCUOPT 02080000 CLI 5(WORK2),X'FF' IS ERROR HANDLING INCLUDED? 02086016 BNE WRTMSG YES, BRANCH 02092016 CLI 6(WORK2),X'00' TEST IF MSG TO BE WRITTEN 02102016 BZ NOMSG BRANCH IF NO MSG TO BE WRITTEN 02120000 IC WORK3,6(WORK2) 02140016 BCTR WORK3,0 DECREMENT MSG COUNT AND PLACE 02160000 STC WORK3,6(WORK2) NEW COUNT IN IHCUOPT 02180016 * WRITE BOUNDARY ERROR MESSAGE BY WAY OF A 02200000 * LINKAGE INTO IBCOM 02220000 * 02240000 WRTMSG EQU * 02260016 L 15,AARITH LOAD BASE REG FOR ARITH 02280000 MVC ALRTLNK+2(2),SALERTA+2 GET LINK ADDR FOR ALERTA 02300000 CNOP 0,4 02320000 ALRTLNK BAL 14,0(0) 02340000 L BASE,8(14) RESTABLISH PROPER BASE IN 14 02360000 B NEXT 02380000 DC A(BOUND) 02400000 NEXT EQU * 02420000 NOMSG EQU * 02460000 LR WORK3,BASE SAVE CONTENTS OF BASE REG 02480000 SPIE PAEXCPT,(4,5) 02500000 LR BASE,WORK3 RESTORE BASE REG CONTENTS 02520000 ST 1,PREVPICA SAVE PREVIOUS PICA ADDRESS 02540000 * CALCULATE X2+B2+D2 OF INSTRUCTION TO OBTAIN EFFECTIVE 02560000 * ADDRESS OF OPERAND 2. 02580000 L 2,PR2SAVE RESTORE MAIN PROG CONTENTS OF R2 02600000 L WORK2,INSTRWA 02620000 N WORK2,DISPMSK LOAD WORK2 WITH D2 02640000 SR WORK1,WORK1 02660000 CLI RSSW,LMSTM IS THIS A LM OR STM INSTRUCT MAINT 02666000 BE BOUND50 YES,BRANCH (NO X2 FLD TO COMP) MAINT 02672000 IC WORK1,INSTRWA+1 LOAD WORK1 WITH X2 02680000 N WORK1,REGMSK 02700000 BZ BOUND50 X2 IS ZERO, BRANCH TO TEST B2 02720000 CH WORK1,H14 02740000 BE BOUND100 X2=14 02760000 BH BOUND110 X2>14 , =15 02780000 CH WORK1,HONE 02800000 BE BOUND120 X2=1 02820000 EX WORK1,ADD ADD CONTENTS OF X2 TO D2 02840000 BOUND50 IC WORK1,INSTRWA+2 LOAD WORK1 WITH B2 02860000 SRA WORK1,4 02880000 BZ BOUND60 B2 IS ZERO 02900000 CH WORK1,H14 02920000 BE BOUND130 B2=14 02940000 BH BOUND140 B2>14, =15 02960000 CH WORK1,HONE 02980000 BE BOUND150 B2=1 03000000 EX WORK1,ADD ADD IN CONTENTS OF B2 03020000 * WORK2 NOW CONTAINS EFFECTIVE ADDR OF OPERAND 2 03040000 BOUND60 ST WORK2,EFFADR SAVE ADDRESS 03060000 CLI RSSW,LMSTM IS THIS LM OR STM? MAINT 03066000 BE COMPUTEL YES,COMPUTE # OF REGS TO MOVE MAINT 03072000 LA WORK1,7 DEFAULT LENTH OF DATA MVC=8 MAINT 03078000 MOVEDATA STH WORK1,LENGTH SAVE LENGTH OF DATA FLD MAINT 03084000 EX WORK1,MVCDATA MOVE DATA TO DBL-WORD BOUND MAINT 03090000 BOUND70 LR WORK3,BASE SAVE CONTENTS OF BASE REG 03100000 SPIE EXCPTN,(4,7,9,11,12,13,15) 03120000 LR BASE,WORK3 RESTORE BASE REG CONTENTS 03140000 CLI FLPTSW,FLOAT 03160000 BE REEXEC INSTR IS FLOAT PT-GO TO REEXEC 03180000 LM 15,2,PR15SAVE RESTORE MAIN PROG REGS EXCEPT 14 03200000 CLI RSSW,LMSTM LM OR STM INSTRUCTION? MAINT 03206000 BE REEXEC YES, BRANCH MAINT 03212000 TM INSTRWA+1,X'F0' TEST R1 = REG 15 03220000 BO REEXEC YES 03240000 TM INSTRWA+1,X'E0' TEST R1 OF INSTR = REG 14 03260000 BNO REEXEC NO 03280000 OI REG14SW,REG14 YES. SET REGISTER 14 SWITCH 03300000 MVI REEXEC+1,X'00' NO- USE REG 0 AS R1 OF INSTR 03320000 L 0,PR14SAVE LOAD 0 WITH CONTENTS OF 14 03340000 TM MDSW,MPYDIV IS INSTR MPY OR DIV 03360000 BNO REEXEC NO- GO TO REEXECUTE 03380000 L 1,PR15SAVE YES-LOAD REG 1 WITH CONTENTS OF 15 03400000 * SIMULATION OF INSTRUCTION WHICH CAUSED BOUNDARY ERROR. 03420000 * THE OP CODE AND R1 FIELDS OF THE FOLLOWING INSTRUCTION 03440000 * WILL BE REPLACED BY THOSE OF THE SIMULATED INSTRUCTION 03460000 * EXCEPT WHEN R1 = REGISTER 14. IN THAT CASE REGISTER 0 03480000 * WILL BE USED (WITH REGISTER 1 IN THE CASE OF A FULL 03500000 * WORD MULTIPLY OR DIVIDE.) 03520000 REEXEC A 0,TEMP DUMMY INSTRUCTION 03540000 ST 15,SAVER15 SAVE CONTENTS OF 15 03560000 BALR 15,0 SAVE NEW COND CODE SETTING 03580000 ST 15,CCSAVE 03600000 L 15,SAVER15 RESTORE CONTENTS OF 15 03620000 CLI FLPTSW,FLOAT IS INSTR GLOATING PT 03640000 BE CCTEST YES 03660000 CLI REG14SW,REG14 NO-TEST MPY/DIV + REG14 SWS 03680000 BL RESETALL NEITHER REG 14 NOR 15 INDICATED 03700000 BE RESET14 ONLY REG 14 INDICATED 03720000 ST 1,PR15SAVE BOTH REG 14 AND 15-REPLACE 15 03740000 RESET14 ST 0,PR14SAVE REPLACE 14 03760000 RESETPIE L WORK2,PIEADDR PLACE NEW REGISTER CONTENTS IN 03780000 MVC 12(20,WORK2),PR14SAVE PIE 03800000 CCTEST CLI CCSW,CCON WAS COND CODE AFFECTED 03820000 BNE STTEST NO 03840000 L WORK2,PIEADDR 03860000 MVC 8(1,WORK2),CCSAVE YES MOVE NEW CC TO PIE 03880000 STTEST CLI STSW,STORE IS INSTR A STORE 03900000 BNE SPIEREST NO 03920000 L WORK2,EFFADR YES- MOVE DATA TO PROPER 03940000 LH WORK1,LENGTH LOCATION IN MAIN PROGRAM MAINT 03950000 EX WORK1,STINST GET PROPER LGTH OF DATA FLD MAINT 03960000 SPIEREST L 1,PREVPICA ISSUE SPIE TO RESTORE ORIGINAL 03980000 SPIE MF=(E,(1)) PICA. 04000000 L 14,RETURN 04020000 BR 14 RETURN TO SUPERVISOR 04040000 * 04060000 * 04080000 FIXPT MVI FLPTSW,FIX SET SW TO INDICATE FIXED POINT 04100000 * TEST OP CODE OF INSTRUCTION TO DETERMINE IF IT IS A STORE 04120000 * TYPE, IF THE CONDITION CODE IS AFFECTED WHEN INSTRUCTION 04140000 * IS EXECUTED, IF ANY OTHER SPECIFICATION ERRORS EXIST. 04160000 CLI INSTRWA,X'50' 04180000 BE STSWSET =50 04200000 BL FIXPT20 <50 04220000 CLI INSTRWA,X'5C' >50 04240000 BE FIXPT10 =5C 04260000 BL FIXPT30 <5C 04280000 CLI INSTRWA,X'5D' >5C 04300000 BNE CCSWSET NOT =5D 04320000 * INSTR IS FULL WORD MPY OR DIV 04340000 FIXPT10 OI MDSW,MPYDIV SET MPY/DIV SWITCH 04360000 TM INSTRWA+1,X'10' TEST R1 OF INSTR FOR ODD REG 04380000 BO SPECEND ODD REGISTER -ABEND 04400000 B BOUND20 04420000 FIXPT20 CLI INSTRWA,X'4E' 04440000 BE STSWSET =4E 04460000 BH BOUND20 >4E , =4F 04480000 CLI INSTRWA,X'44' 04500000 BE SPECEND =44, ABEND 04520000 B BOUND10 04540000 FIXPT30 CLI INSTRWA,X'58' 04560000 BE BOUND20 04580000 * EXECUTION OF INSTR AFFECTS COND CODE -SET 04600000 * SWITCH TO INDICATE NEW CC MUST BE SAVED 04620000 * FOLLOWING REEXECUTION OF INSTR 04640000 CCSWSET OI CCSW,CCON 04660000 B BOUND20 04680000 * INSTR IS A STORE (CVD,ST,STH,STD, OR STE) 04700000 STSWSET OI STSW,STORE SET STORE SWITCH 04720000 B BOUND20 04740000 BOUND100 AL WORK2,PR14SAVE ADD CONTENTS OF X2 FROM R14 IN PIE 04760000 B BOUND50 04780000 BOUND110 AL WORK2,PR15SAVE ADD CONTENTS OF X2 FROM R15 IN PIE 04800000 B BOUND50 04820000 BOUND120 AL WORK2,PR1SAVE ADD CONTENTS OF X2 FROM R1 IN PIE 04840000 B BOUND50 04860000 BOUND130 AL WORK2,PR14SAVE 04880000 B BOUND60 04900000 BOUND140 AL WORK2,PR15SAVE ADD CONTENTS OF B2 FROM R15 IN PIE 04920000 B BOUND60 04940000 BOUND150 AL WORK2,PR1SAVE ADD CONTENTS OF B2 FROM R1 IN PIE 04960000 B BOUND60 04980000 RESETALL STM 15,2,PR15SAVE REPLACE 15-2 05000000 B RESETPIE 05020000 RSTEST EQU * MAINT 05020800 CLI INSTRWA,X'98' IS THE OP CODE FOR A LM? MAINT 05021600 BE RSSWSET YES,BRANCH TO SET SWITCH MAINT 05022400 CLI INSTRWA,X'90' IS THE OP CODE FOR A STM? MAINT 05023200 BNE SPECEND NO,INSTRUCTION OUT OF RANGE MAINT 05024000 MVI STSW,STORE SET STORE SWITCH MAINT 05024800 RSSWSET MVI RSSW,LMSTM SET SWITCH TO INDICATE RS INST MAINT 05025600 MVI FLPTSW,FIX INDICATE INST. IS FIXED POINT MAINT 05026400 B BOUND20 MAINT 05027200 COMPUTEL EQU * MAINT 05028000 SR WORK1,WORK1 MAINT 05028800 IC WORK1,INSTRWA+1 PICK UP R1 AND R3 FIELD OF INST MAINT 05029600 N WORK1,R1MSK ISOLATE THE R1 FIELD MAINT 05030400 SRA WORK1,4 MVC R1 TO LOW ORDER BYTE OF REG MAINT 05031200 STH WORK1,R1SAVE MAINT 05032000 IC WORK1,INSTRWA+1 MAINT 05032800 N WORK1,REGMSK ISOLATE R3 FIELD MAINT 05033600 *COMPUTE NUMBER OF REGS(N) INVOLVED IN THE LM OR STM MAINT 05034400 SH WORK1,R1SAVE N=R3-R1+1 MAINT 05035200 AH WORK1,HONE MAINT 05036000 SLA WORK1,2 N*4=LENGTH IN BYTES OF DATA FLD MAINT 05036800 B MOVEDATA TO BE MOVED MAINT 05037600 * 05040000 * ISSUE SPIE MACRO TO ELIMINATE SPECIAL INTERRUPT HANDLING. THEN 05060000 * FORCE ABEND BY REEXECUTING INSTRUCTION WHICH CAUSED 05080000 * THE SPECIFICATION INTERRUPT. 05100000 * 05120000 SPECERR TM 8(1),X'80' TEST ILC TO GET INSTR LENGTH. 05140000 BZ SPECERR1 BRANCH IF INSTR IS 2 BYTES 05160000 SH WORK1,HTWO MODIFY ADDR FOR 6 BYTE INSTR 05180000 B SPECEND 05200000 SPECERR1 AH WORK1,HTWO MODIFY ADDR FOR 2 BYTE INSTR 05220000 * WORK1 CONTAINS ADDR OF INSTR WHICH CAUSED SPEC INT. 05240000 SPECEND ST WORK1,PSWSAVE+4 05260000 L 1,PIEADDR RESET PSW ADDR IN PIE TO INSTR 05280000 MVC 9(3,1),PSWSAVE+5 WHICH CAUSED INTERRUPT. 05300000 INSTEND L 2,RETURN LOAD RETURN ADDR 05320000 SR 1,1 ZERO REG 59714 1/2 05340022 SPIE MF=(E,(1)) SPIE DELETE 59714 2/2 05350022 BR 2 RETURN TO SUPERVISOR 05360000 * 05380000 * 05400000 BOUND EQU IHCADJST 05420000 * SAVE AREA FOR PROG INTERRUPT ELEMENT (PIE) 05440000 DS 0D 05460000 PIESAVE DS 0CL32 05480000 PICASAVE DS F 05500000 PSWSAVE DS 2F 05520000 PR14SAVE DS F 05540000 PR15SAVE DS F 05560000 PR0SAVE DS F 05580000 PR1SAVE DS F 05600000 PR2SAVE DS F 05620000 * 05640000 DS 0F 05660000 RETURN DS F RETURN ADDRESS (TO SUPERVISOR) 05680000 AARITH DS F A(ARITH) IN IBCOM 05700000 SALERTA DS F S(ALERTA) IN IBCOM 05720000 PIEADDR DS F ADDRESS OF PROGRAM INTERUPTION ELEMENT (PIE) 05740000 ADROPT DS F A(IHCUOPT) FROM IBCOM 05780000 AINT6SW DS F ADCON OF INT6SW IN IHCFCVTH(FROM IBCOM) 4648 05790013 ADFIOCS DS F A(FIOCS) FROM IBCOM HWRE 05795014 EFFADR DS F EFFECTIVE ADDR OF INSTR (D2+B2+X2) 05800000 PREVPICA DS F PREVIOUS PICA ADDRESS 05820000 CCSAVE DS F SAVE AREA FOR COND CODE SETTING 05840000 SAVER15 DS F TEMP SAVE AREA FOR R15 05860000 SAVER3 DS F TEMP SAVE AREA FOR R3 05880000 SAVEMPR8 DS F SAVE AREA FOR MAIN PROG CONTENTS OF REG 8 HWRE 05886014 SAVEBR8 DS F SAVE AREA FOR CONTENTS OF ARITH BASE REG 8 HWRE 05892014 * 05900000 * 05920000 DS 0D 05940000 TEMP DS 4D WORK AREA FOR CONTENTS OF OPERAND2 MAINT 05960000 * 05980000 * 06000000 DS 0F 06020000 INSTRWA DS F WORK AREA FOR INSTR CAUSING SPEC INTERPT 06040000 * REGISTER DEFINITIONS 06060000 R0 EQU 0 REGISTER 0 06080000 R1 EQU 1 REGISTER 1 06100000 BASE EQU 14 BASE REGISTER 06120000 WORK1 EQU 15 WORK REGISTER 06140000 WORK2 EQU 1 WORK REGISTER 06160000 WORK3 EQU 2 WORK REGISTER 06180000 * 06200000 DS 0F 06220000 ADRMSK DC X'00FFFFFF' MASK FOR 24 BIT ADDRESS 06240000 DISPMSK DC X'00000FFF' MASK FOR DISPLACEMENT 06260000 REGMSK DC X'0000000F' 06280000 R1MSK DC X'000000F0' MAINT 06290000 HFOUR DC H'4' 06300000 H14 DC H'14' 06320000 HONE DC H'1' 06340000 HTWO DC H'2' 06360000 LENGTH DS H MAINT 06366000 R1SAVE DS H MAINT 06372000 * SWITCHES 06380000 * 06400000 FLPTSW DC X'00' SWITCH SET TO 00 IF FIXED PT, 01 IF FL PT 06420000 * COND CODE SW = FIRST HALF OF BYTE 06440000 * SETTING - BITS 0-2 ALWAYS ZERO 06460000 * BIT 3 0 IF INSTR DOES NOT AFFECT CC 06480000 * 1 IF INSTR DOES AFFECT CC 06500000 * STORE SWITCH = SECOND HALF OF BYTE 06520000 * SETTING - BITS 4-6 ALWAYS ZERO 06540000 * BIT 7 0 IF INSTR IS NOT STORE TYPE 06560000 * 1 IF INSTR IS STORE TYPE 06580000 SWITCH1 DC X'00' COND CODE SWITCH AND STORE SWITCH 06600000 CCSW EQU SWITCH1 06620000 STSW EQU SWITCH1 06640000 * REGISTER 14 SWITCH = FIRST HALF OF BYTE 06660000 * SETTING- BITS 0-2 ALWAYS ZERO 06680000 * BIT 3 0 IF R1 OF INSTR NOT REGISTER 14 06700000 * 1 IF R1 OF INSTR EQUALS REGISTER 14 06720000 * MULTIPLY/DIVIDE SWITCH 06740000 * SETTING- BITS 4-6 ALWAYS ZERO 06760000 * BIT 7 0 IF INSTR NOT FULL WORD MPY OR DIV 06780000 * 1 IF INSTR IS FULL WORD MPY OR DIV 06800000 SWITCH2 DC X'00' REGISTER SWITCH AND MULTIPLY/DIV SWITCH 06820000 REG14SW EQU SWITCH2 06840000 MDSW EQU SWITCH2 06860000 RSSW DC X'00' LM,ST, INSTRUCTION SWITCH MAINT 06870000 * 06880000 ADD ALR WORK2,0 06900000 MVCDATA MVC TEMP(0),0(WORK2) DATA MOVED TO DBL WORD BOUND MAINT 06906000 STINST MVC 0(0,WORK2),TEMP PUT DATA IN PROPER LOC IN MAIN MAINT 06912000 * CODES FOR SWITCH SETTINGS 06920000 FIX EQU X'00' 06940000 FLOAT EQU X'01' 06960000 STORE EQU X'01' 06980000 CCON EQU X'10' 07000000 MPYDIV EQU X'01' 07020000 REG14 EQU X'10' 07040000 LMSTM EQU X'FF' LM,STM SWITCH SET MAINT 07050000 * 07060000 * INTERRUPT HANDLER FOR INTERRUPTS WHICH MAY OCCUR ON 07080000 * REEXECUTION OF THE BOUNDARY ALIGNMENT ERROR INSTRUCTION. 07100000 * 07120000 DS 0F 07140000 EXCPTN ST 14,16(0,15) SAVE REG 14 07160000 L BASE,12(0,15) REESTABLISH 14 AS BASE REG 07180000 B BEGIN 07200000 DC A(BOUND) 07220000 REGSAVE DS F SAVE AREA FOR REG 14 07240000 BEGIN EQU * 07260000 CLI 7(1),X'07' TEST FOR DATA,PROTECT EXCPT 07280000 BNH PROC4 YES- GO TO WR MSG AND ABEND 07300000 STM 0,1,SALERTA SAVE REGS 0,1 07320000 CLI CCSW,CCON DID EXEC OF INSTR AFFECT CC 07340000 BE RESETAD YES -PIE CONTAINS PROPER CC 07360000 MVC 8(1,1),PSWSAVE+4 NO- MOVE CC FROM OLD PIE TO NEW 07380000 RESETAD MVC 9(3,1),PSWSAVE+5 RESTORE OLD PSW ADDR IN PIE 07400000 CLI FLPTSW,FLOAT 07420000 BE EXCPTN30 INSTR IS FLOAT POINT 07440000 CLI REG14SW,REG14 FIX PT- TEST MPY/DIV + REG14 SWS 07460000 BL EXCPTN40 NEITHER REG 14 NOT REG 15 INDICATED 07480000 BE EXCPTN10 ONLY REG 14 INDICATED 07500000 MVC 16(4,1),24(1) BOTH REG 14 AND 15-SET NEW 15 IN PIE 07520000 MVC 24(4,1),PR1SAVE RESTORE OLD REG 1 07540000 EXCPTN10 MVC 12(4,1),20(1) SET NEW 14 IN PIE 07560000 MVC 20(4,1),PR0SAVE RESTORE OLD REG 0 07580000 EXCPTN20 L 1,PREVPICA ISSUE SPIE TO RESTORE ORIGINAL PICA 07600000 SPIE MF=(E,(1)) 07620000 L 15,AARITH LOAD R15 WITH ADDR OF ARITH 07640000 LM 0,1,SALERTA RESTORE REGISTERS 07660000 L 14,REGSAVE 07680000 B 4(0,15) GO TO ARITH TO PROCESS INTERRUPT 07700000 EXCPTN30 MVC 12(20,1),PR14SAVE PLACE REGS FROM OLD PIE IN NEW 07720000 B EXCPTN20 07740000 EXCPTN40 MVC 12(4,1),PR14SAVE RESTORE OLD REG 14 INTO PIE 07760000 B EXCPTN20 07780000 * 07800000 * INTERRUPT HANDLER FOR DATA OR PROTECTION INTERRUPTS WHICH MAY 07820000 * OCCUR DURING FETCHING OF MISALIGNED DATA PRIOR TO 07840000 * REEXECUTING BOUNDARY ALIGNEMNT ERROR INSTRUCTION. 07860000 * 07880000 CNOP 0,4 07900000 PAEXCPT ST 14,16(15) SAVE REG 14 07920000 L BASE,12(15) REESTABLISH PROPER BASE IN 14 07940000 B PROCESS 07960000 DC A(BOUND) 07980000 REG14SAV DS F 08000000 PROCESS EQU * 08020000 MVC RETURN,REG14SAV SAVE RETURN ADDR TO SUPERVISOR 08040000 PROC2 ST 1,PIEADDR SAVE ADDR OF PIE 08060000 MVC 9(3,1),PSWSAVE+5 REPLACE CURRENT PSW ADDR WITH 08080000 * MAIN PROGRAM ADDRESS 08100000 MVC 12(20,1),PR14SAVE REPLACE CURRENT PIE REGS WITH 08120000 * MAIN PROG REGS 08140000 * WRITE ERROR MESSAGE BY WAY OF LINK INTO IBCOM 08160000 * 08180000 L 15,AARITH LOAD BASE REG FOR ARITH 08220000 MVC MSGLNK+2(2),SALERTA+2 GET LINK ADDR FOR ALERTA 08240000 CNOP 0,4 08260000 MSGLNK BAL 14,0(0) 08280000 L BASE,8(14) REESTABLISH PROPER BASE 08300000 B PROC3 08320000 DC A(BOUND) 08340000 PROC3 EQU * 08360000 L R1,ADFIOCS 08380000 BALR R0,R1 08400000 DC AL1(4) 08420000 DC AL1(0) 08440000 L WORK1,PSWSAVE+4 SUB 4 FROM PSW ADDR IN SAVED 08480000 N WORK1,ADRMSK PIE TO GET ADDR OF INSTR 08500000 SH WORK1,HFOUR WHICH CAUSED SPEC INTERRUPT 08520000 B SPECEND BRANCH TO FORCE ABEND 08540000 * 08560000 PROC4 MVC RETURN,REGSAVE SAVE RETURN ADDR TO SUPERVISOR 08580000 B PROC2 HANDLE DATA EXCEPTION 08600000 END 08620000 ./ ADD SSI=00012013,NAME=IHCCGOTO,SOURCE=0 * THIS ROUTINE IMPLEMENTS COMPUTED GOTO 00020000 * USING IN-LINE ARGUMENT LIST AS 00040000 * GENERATED BY P25 00060000 * REGISTER USAGE 00080000 * 15= BASE REGISTER 00100000 * 2= CONTAINS INTEGER AND RESULTING 00120000 * BRANCH ADDRESS 00140000 * 3= WORK AND INDEX REGISTER 00160000 * 14= POINTS TO ARGUMENT DESIGNATING NO. 00180000 * OF BRANCH ADDRESSES, FOLLOWED BY 00200000 * BRANCH TABLE INCREMENTS 00220000 * CALL USES BALR 14,15 00240000 IHCCGOTO START 0 00260000 ENTRY CGOTO# 00280000 USING *,15 IF INTEGER 00300000 CGOTO# LTR 2,2 IS 0 OR NEG. 00320000 BC 12,OUT BRANCHES OUT 00340000 CH 2,0(14) IF EQ OR LESS 00360000 BC 12,CALC THAN LIMIT 00380000 OUT LH 3,0(14) GOES TO CALC. OUT 00400000 SLA 3,1 CALCULATES NEXT EX 00420000 BC 15,6(3,14) INST AND EXITS 00440000 CALC SLA 2,1 MULT INT BY 2 00460000 MVC FUDGE(4),2(14) 00480000 L 3,FUDGE 00500000 AH 3,4(2,14) ADD INCREMENT 00520000 L 2,0(3) PUT BR ADD IN 2 00540000 BCR 15,2 BRANCH 00560000 FUDGE DS 1F 00580000 END 00600000 ./ ADD SSI=01013622,NAME=IHCCLABS,SOURCE=0 CLAB TITLE 'COMPLEX ABSOLUTE VALUE FUNCTION (LONG)' 01000018 IHCCLABS CSECT 02000018 * 03000018 * COMPLEX ABSOLUTE VALUE FUNCTION (LONG) 04000018 * 1. WRITE /X+IY/ = U+IV, WHERE U IS THE REAL PART 05000018 * OF THE ANSWER, AND V IS THE IMAGINARY PART OF 06000018 * THE ANSWER. 07000018 * 2. LET Z1 = MAX(/X/,/Y/) AND Z2 = MIN(/X/,/Y/). 08000018 * 3. THEN U = 2*Z1*SQRT(0.25+(Z2/(2*Z1))**2), AND V = 0. 09000018 SPACE 10000018 EXTRN DSQRT 11000018 ENTRY CDABS 12000018 SPACE 13000018 GRA EQU 1 ARGUMENT POINTER 14000018 GRS EQU 13 SAVE AREA POINTER 15000018 GRR EQU 14 RETURN REGISTER 16000018 GRL EQU 15 LINK REGISTER 17000018 GR0 EQU 0 SCRATCH REGISTERS 18000018 GR1 EQU 1 19000018 FR0 EQU 0 ANSWER REGISTERS 20000018 FR2 EQU 2 21000018 FR6 EQU 6 SCRATCH REGISTER 22000018 ISNSQ EQU X'302' IDENTIFIER NUMBER FOR DSQRT CALL 23000018 SPACE 24000018 USING *,GRL 25000018 CDABS BC 15,CLABS 26000018 DC AL1(5) 27000018 DC CL5'CDABS' 28000018 SPACE 29000018 CLABS STM GRR,GRA,12(GRS) SAVE REGISTERS 30000018 L GR1,0(GRA) OBTAIN ARGUMENT 31000018 LD FR6,0(GR1) REAL PART. FR6 UNCHANGED BY DSQRT CALL 32000018 LD FR2,8(GR1) IMAGINARY PART 33000018 LPER FR6,FR6 FORCE SIGNS POSITIVE 34000018 LPER FR2,FR2 35000018 SPACE 36000018 CDR FR6,FR2 A = MAX(/X/,/Y/), B = MIN(/X/,/Y/) 37000018 BC 10,READY IF NECESSARY SWITCH REGISTERS SO THAT 38000018 LDR FR0,FR2 IN ALL CASES FR6 CONTAINS A AND FR2 39000018 LDR FR2,FR6 CONTAINS B 40000018 LDR FR6,FR0 41000018 SPACE 42000018 READY LDR FR0,FR6 IF CHARACTERISTICS ARE DIFFERENT BY 43000018 SWR FR0,FR2 15 OR MORE,OR B=0, THE ANSWER IS A. 44000018 CDR FR0,FR6 THIS IS DONE TO AVOID ANY 45000018 BC 8,EXIT INTERMEDIATE UNDERFLOW 46000018 DDR FR2,FR6 D = B/A 47000018 HDR FR2,FR2 TAKE SQRT OF 0.25+D*D/4 48000018 MDR FR2,FR2 THIS IS A MORE ACCURATE PROCEDURE 49000018 AW FR2,QUART THAN SQRT OF 1+D*D 50000018 SPACE 51000018 LR GRR,GRS SWITCH SAVE AREA POINTERS 52000018 LA GRS,AREA 53000018 ST GRR,4(GRS) 54000018 ST GRS,8(GRR) 55000018 STD FR2,BUFF 56000018 LA GRA,ABUFF 57000018 L GRL,ADSQRT CALL DSQRT SUBROUTINE 58000018 BALR GRR,GRL 59000018 BC 0,ISNSQ 60000018 USING *-4,GRR 61000018 L GRS,AREA+4 RESTORE REGISTERS 62000018 LM GRR,GRA,12(GRS) RESTORE GRA IN PREPARATION FOR POSSIBLE 63000018 USING CDABS,GRL FLOATING POINT OVERFLOW 64000018 DROP GRR 65000018 SPACE 66000018 CE FR6,THRESH IF A IS VERY SMALL, AVOID PREMATURE 67000018 BC 4,SMALL UNDERFLOW BY CHANGING THE ORDER OF 68000018 MDR FR0,FR6 MULTIPLICATION 69000018 ADR FR0,FR0 70000018 SPACE 71000018 EXIT SDR FR2,FR2 72000018 MVI 12(GRS),X'FF' 73000018 BCR 15,GRR RETURN 74000018 SPACE 75000018 SMALL ADR FR6,FR6 76000018 MDR FR0,FR6 77000018 BC 15,EXIT 78000018 SPACE 79000018 DS 0F 80000018 ABUFF DC X'80' 81000018 DC AL3(BUFF) 82000018 ADSQRT DC A(DSQRT) 83000018 AREA DS 7F 84000018 BUFF DS D 85000018 QUART DC X'4040000000000001' 0.25 WITH ROUNDING FUDGE 86000018 THRESH DC X'00200000' 87000018 END 88000018 ./ ADD SSI=21460007,NAME=IHCCLAS,SOURCE=0 IHCCLAS CSECT 00020000 * 00040000 * COMPLEX MULTIPLY-DIVIDE SUBROUTINE (LONG) 00060000 * GR1 POINTS TO ARGUMENT LIST WHICH LISTS ADDRESSES OF 00080000 * REAL PARTS OF BOTH OPERANDS. IMAGINARY PART OF EACH 00100000 * OPERAND MUST BE LOCATED IMMEDIATELY FOLLOWING ITS 00120000 * REAL PART 00140000 SPACE 00160000 ENTRY CDMPY# 00180000 ENTRY CDDVD# 00200000 SPACE 00220000 GR0 EQU 0 SCRATCH REGISTERS 00240000 GR1 EQU 1 00260000 GR2 EQU 14 00280000 GRA EQU 1 ARGUMENT POINTER 00300000 GRS EQU 13 SAVE AREA POINTER 00320000 GRR EQU 14 RETURN REGISTER 00340000 GRL EQU 15 LINK REGISTER 00360000 FR0 EQU 0 ANSWER REGISTERS 00380000 FR2 EQU 2 00400000 FR4 EQU 4 SCRATCH REGISTERS 00420000 FR6 EQU 6 00440000 SPACE 00460000 USING *,15 00480000 CDMPY# B 12(0,15) ENTRY FOR MULTIPLICATION 00500000 DC AL1(6) 00520000 DC CL6'CDMPY#' 00540000 STM GRR,GRL,12(GRS) SAVE REGISTERS 00560000 MVI FLAG,1 SAVE REGISTERS AND SET FLAG 00580000 LA GRL,CDDVD#-CDMPY#(GRL) 00600000 USING CDDVD#,GRL ADJUST BASE REGISTER BLD PUMP 00620000 BC 15,JOIN 00640000 SPACE 00660000 CDDVD# B 12(0,15) ENTRY FOR DIVISION 00680000 DC AL1(6) 00700000 DC CL6'CDDVD#' 00720000 STM GRR,GRL,12(GRS) SAVE REGISTERS 00740000 MVI FLAG,0 SAVE REGISTERS AND RESET FLAG 00760000 JOIN L GR2,0(GRA) OBTAIN OPERANDS 00780000 LD FR0,0(GR2) A 00800000 LD FR2,8(GR2) B 00820000 L GR2,4(GRA) 00840000 LD FR4,0(GR2) C 00860000 LD FR6,8(GR2) D 00880000 STD FR4,C 00900000 STD FR6,D 00920000 TM FLAG,1 IF DIVID, JUMP 00940000 BC 8,DVD 00960000 SPACE 00980000 MDR FR6,FR2 MULTIPLICATION 01000000 MDR FR2,FR4 01020000 LDR FR4,FR0 (A+BI)*(C+DI) = (AC-BD)+(AD+BC)I 01040000 MD FR4,D 01060000 MD FR0,C 01080000 SDR FR0,FR6 01100000 ADR FR2,FR4 01120000 RETURN L GR2,12(GRS) RETURN 01140000 MVI 12(GRS),X'FF' 01160000 BCR 15,GRR 01180000 SPACE 01200000 DVD LPDR FR4,FR4 DIVISION 01220000 LPDR FR6,FR6 01240000 CDR FR4,FR6 IF /C/ GREATER THAN /D/, OK 01260000 LD FR4,C 01280000 LD FR6,D OTHERWISE SWITCH C AND D BY USING 01300000 BC 2,OK 01320000 LDR FR6,FR0 A+BI B-AI 01340000 LDR FR0,FR2 ---- = ---- 01360000 LCDR FR2,FR6 C+DI D-CI 01380000 LCDR FR6,FR4 01400000 LD FR4,D 01420000 SPACE 01440000 OK DDR FR0,FR4 OBTAIN A'=A/C, B'=B/C, D'=D/C 01460000 DDR FR2,FR4 01480000 DDR FR6,FR4 A+BI A'+B'I A'+B'D' B'-A'D' 01500000 LDR FR4,FR6 ---- = ------ = -------+-------I 01520000 MDR FR6,FR6 C+DI 1+D'I 1+D'D' 1+D'D' 01540000 AD FR6,ONE 01560000 STD FR6,C 01580000 LDR FR6,FR4 01600000 MDR FR4,FR2 01620000 MDR FR6,FR0 01640000 ADR FR0,FR4 01660000 SDR FR2,FR6 01680000 DD FR0,C 01700000 DD FR2,C 01720000 BC 15,RETURN 01740000 SPACE 01760000 FLAG DS C 01780000 C DS D 01800000 D DS D 01820000 ONE DC X'4110000000000000' 01840000 END 01860000 ./ ADD SSI=01013261,NAME=IHCCLEXP,SOURCE=0 CLEX TITLE 'COMPLEX EXPONENTIAL FUNCTION (LONG)' 00010000 IHCCLEXP CSECT 00020000 * 00040000 *C108000,013900-014000 A43096 00044021 *A012200,012400 A43096 00048021 *D012300 A43096 00052021 * 00056021 * COMPLEX EXPONENTIAL FUNCTION (LONG) 00060000 * EXP(X+IY) = E**X * COS(Y) + I*E**X * SIN(Y) 00080000 * STATUS - CHANGE LEVEL 01 15JULY71 RELEASE 21 00090021 SPACE 00100000 EXTRN IBCOM# 00120000 EXTRN IHCERRM 00130016 EXTRN DEXP 00140000 EXTRN DSIN 00160000 EXTRN DCOS 00180000 ENTRY CDEXP ENTRY POINT NAME 00200000 SPACE 00220000 GR2 EQU 2 00226016 RG3 EQU 3 00232016 GR1 EQU 1 SCRATCH REGISTERS 00240000 GR3 EQU 14 00260000 GRA EQU 1 ARGUMENT POINTER 00280000 GRB EQU 2 BASE REGISTER (TEMPORARY) 00300000 GRS EQU 13 SAVE AREA POINTER 00320000 GRR EQU 14 RETURN REGISTER 00340000 GRL EQU 15 LINK REGISTER 00360000 SPACE 00380000 FR0 EQU 0 ANSWER REGISTER (REAL PART) 00400000 FR2 EQU 2 ANSWER REGISTER (IMAG PART) 00420000 FR6 EQU 6 SCRATCH REGISTER 00430018 SPACE 00440000 ISNEX EQU X'308' IDENTIFIER NO. FOR DEXP CALL 00460000 ISNSN EQU X'30A' IDENTIFIER NO. FOR DSIN CALL 00480000 ISNCN EQU X'30C' IDENTIFIER NO. FOR DCOS CALL 00500000 SPACE 00520000 USING *,GRL 00530018 CDEXP BC 15,CLEXP 00540000 DC AL1(5) 00550018 DC CL5'CDEXP' 00560018 SPACE 00570000 CLEXP STM GRR,GRB,12(GRS) SAVE REGISTERS 00580018 LR GRB,GRL 00640000 USING CDEXP,GRB GRB TEMPORARY BASE REGISTER 00660000 DROP GRL 00680000 LR GRL,GRS SWITCH SAVE AREA POINTERS 00700000 LA GRS,AREA GRS POINTS TO CURRENT SAVE AREA 00720000 ST GRL,4(GRS) GRL POINTS TO PREVIOUS SAVE AREA 00740000 ST GRS,8(GRL) 00760000 SPACE 00780000 BEGIN EQU * 00790016 L GR3,0(GRA) 00800000 LD FR0,0(GR3) PICK UP X (REAL PART) IN FR0 00820000 LD FR2,8(GR3) AND Y (IMAG PART) IN FR2 00840000 STD FR2,BUFF1 Y IN TEMPORARY STORAGE BUFF1 00860000 LPER FR2,FR2 /Y/ IN FR2 TO BE SCREENED 00880000 CE FR2,YMAX 00900000 BC 10,ERROR2 IF /Y/ GE PI*2**50, ERROR2 00920000 CE FR0,XMAX X TO BE SCREENED 00940000 BC 2,ERROR1 IF X GRT THAN 174.673, ERROR1 00960000 SPACE 00980000 L GRL,ADEXP CALL DEXP SUBROUTINE 01000000 BALR GRR,GRL E**X IN FR0 01020000 BC 0,ISNEX 01040000 SPACE 01060000 SINCOS EQU * 01070016 STD FR0,BUFF2 STORE E**X IN BUFF2 FOR LATER MULT A43096 01080021 SPACE 01100000 LA GRA,ABUFF1 CALL DSIN SUBROUTINE 01120000 L GRL,ADSIN 01140000 BALR GRR,GRL SIN(Y) IN FR0 01160000 BC 0,ISNSN 01180000 SPACE 01200000 MD FR0,BUFF2 E**X*SIN(Y), SAVE A43096 01220021 STD FR0,BUFF3 IN BUFF3 A43096 01240021 SPACE 01260000 LA GRA,ABUFF1 CALL DCOS SUBROUTINE 01280000 L GRL,ADCOS 01300000 BALR GRR,GRL COS(Y) IN FR0 01320000 BC 0,ISNCN 01340000 SPACE 01360000 L GRS,AREA+4 RESTORE FOR POSSIBLE UNDERFLOW 01370018 SPACE 01380000 MD FR0,BUFF2 E**X*COS(Y),REAL PART, READY IN FR0 A43096 01390021 LD FR2,BUFF3 E**X*SIN(Y),IMAG PART, READY IN FR2 A43096 01400021 SPACE 01420000 EXIT EQU * 01430016 LM GRR,GRB,12(GRS) 01460000 MVI 12(GRS),X'FF' 01480000 BCR 15,GRR 01500000 SPACE 01520000 ERROR1 LA GR1,LIST1 POINT TO LIST TO FORM MSG281 01524016 MVI MSG+5,X'F1' SET TO IHC281I 01528016 SR GRR,GRR ERROR CODE FOR ERROR1=0 01532016 B ERRORS 01536016 ERROR2 LA GR1,LIST2 01540016 MVI MSG+5,X'F2' SET TO IHC282I 01544016 LA GRR,8 ERROR CODE FOR ERROR2=8 01548016 SPACE 01552016 ERRORS MVC TYPE(4),4(GR1) SET MSG TO REAL OR IMAG 01556016 MVC SUFFIX(21),8(GR1) INSERT END PART OF MSG 01560016 STD FR0,BUFF2 STORE REAL PART 01564016 ST GR1,ERRLIST+8 STORE ADDR OF ERRNUM IN ERRLIST 01568016 L GRL,ACOM 01572016 STM GR2,GR3,12(GRS) SAVE BASE AND REG3 01576018 LA RG3,MSGDATA AREA IN MSG FOR DATA 01580016 LA GR2,BUFF2(GRR) ADDR OF DATA IN ERROR 01584016 EX 0,90(GRL) FCVDO 01588016 BALR 0,1 01592016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 01596016 SPACE 01600016 LA RG3,AHEXDATA(RG3) AREA IN MSG FOR HEX DATA 01604016 EX 0,78(GRL) FCVZO 01608016 BALR 0,1 01612016 DC X'0810' LL=8 WW=16 01616016 LM GR2,GR3,12(GRS) RESTORE BASE AND REG3 01620018 L GRL,AERRMON 01624016 LA GR1,ERRLIST 01628016 LR 0,GRR SAVE ERROR CODE SWITCH 01632016 BALR GRR,GRL TO ERROR MONITOR 01636016 SPACE 01640016 LA GRA,ERRLIST+12 POINT TO NEW DATA 01644016 CLI RETCODE+3,X'00' DID USER FIX DATA 01648016 BNZ BEGIN YES, START AGAIN 01652016 LD FR0,INFINY STANDARD FIXUP FOR ERROR1 01656016 * IS SUBSTITUTING LARGEST NUMBER 01660016 * MACHINE HOLDS FOR E**X 01664016 LTR 0,0 TEST ERROR TYPE SWITCH 01668016 BZ SINCOS 0=ERROR1 STANDARD FIXUP= 01672016 L GRS,AREA+4 RESTORE SAVE AREA POINTER 01674000 SDR FR0,FR0 INFINY*(COS(Y)+I*SIN(Y)) 01676016 SDR FR2,FR2 STANDARD FIXUP FOR ERROR2 01680000 B EXIT 0.0+0.0I 01684016 SPACE 01700000 BUFF2 DS D FOR CALC AND REAL PART IF ERROR 01720016 BUFF1 DS D FOR CALC AND IMAG PART IF ERROR 01740016 BUFF3 DS D A43096 01760021 INFINY DC X'7FFFFFFFFFFFFFFF' 01790016 ACOM DC V(IBCOM#) 01800016 AREA DS 18F 01810016 XMAX DC X'42AEAC4F' 174.673 01820000 YMAX DC X'4DC90FDA' PI*2**50 01840018 ABUFF1 DC X'80' 01860000 DC AL3(BUFF1) 01880000 ADEXP DC A(DEXP) 01900000 ADSIN DC A(DSIN) 01920000 ADCOS DC A(DCOS) 01940000 AERRMON DC V(IHCERRM) 01940716 RETCODE DS F 01941416 ERRLIST DC A(MSGLNG) *PARM FOR ERMON 01942116 DC A(RETCODE) * 01942816 DS F *FOR ADDR OF ERRNUM 01943516 DC X'80' * 01944216 DC AL3(BUFF2) * 01944916 EJECT 01945616 MSGLNG DC A(ENDMSG-MSG) 01946316 MSG DC C'IHC28*I CDEXP ' *MSG SKELETON 01947016 TYPE DS 4C * 01947716 DC C' ARG=' * 01948416 MSGDATA DS 23C * 01949116 DC C'(HEX=' * 01949816 HEXDATA DS 16C * 01950516 DC C') ' * 01951216 SUFFIX DS 21C * 01951916 ENDMSG EQU * 01952616 LIST1 DC F'281' ERRNUM1 01953316 DC C'REAL' 01954016 DC CL21'GT 174.673' 01954716 LIST2 DC F'282' ERRNUM2 01955416 DC C'IMAG' 01956116 DC C'ABS VALUE GE PI*2**50' 01956816 AHEXDATA EQU HEXDATA-MSGDATA 01957516 END 01960000 ./ ADD SSI=01010850,NAME=IHCCLLOG,SOURCE=0 CLLG TITLE 'COMPLEX LOGARITHMIC FUNCTION (LONG)' 00020018 IHCCLLOG CSECT 00040018 * 00060018 * COMPLEX LOGARITHMIC FUNCTION (LONG) 00080018 * 1. WRITE LOG(X+IY) = U+IV, WHERE U IS THE REAL PART 00100018 * OF THE ANSWER, AND V IS THE IMAGINARY PART. 00120018 * 2. THEN U = LOG(/X+IY), AND V = ATAN2(Y/X). 00140018 * 3. WRITE LOG(/X+IY/) = LOG(X**2+Y**2)/2 = 00160018 * LOG(S**2((X/S)**2+(Y/S)**2))/2 = 00180018 * LOG((X/S)**2+(Y/S)**2)/2+LOG(S), WHERE 00200018 * S IS A POWER OF 16, SUCH THAT, MAX(X,Y)/S 00220018 * IS BETWEEN 1 AND 1/16 OR BETWEEN 1 AND 16. 00240018 SPACE 00260018 EXTRN DLOG 00280018 EXTRN DATAN2 00300018 ENTRY CDLOG 00320018 EXTRN IBCOM# 00340018 EXTRN IHCERRM 00360018 SPACE 00380018 GRA EQU 1 ARGUMENT POINTER 00400018 GRB EQU 2 BASE REGISTER 00420018 GRS EQU 13 SAVE AREA POINTER 00440018 GRR EQU 14 RETURN REGISTER 00460018 GRL EQU 15 LINK REGISTER 00480018 GR0 EQU 0 SCRATCH REGISTERS 00500018 GR1 EQU 1 00520018 GR2 EQU 14 00540018 FR0 EQU 0 ANSWER REGISTERS 00560018 FR2 EQU 2 00580018 FR4 EQU 4 SCRATCH REGISTER 00600018 ISNAT EQU X'310' IDENTIFIER NUMBER FOR DATAN2 CALL 00620018 ISNLG EQU X'312' IDENTIFIER NUMBER FOR DLOG CALL 00640018 SPACE 00660018 USING *,GRL 00680018 CDLOG BC 15,CLLOG 00700018 DC AL1(5) 00720018 DC CL5'CDLOG' 00740018 SPACE 00760018 CLLOG STM GRR,GRB,12(GRS) SAVE REGISTERS 00780018 MERGE LR GRB,GRL 00860000 DROP GRL 00880000 LR GRL,GRS SWITCH SAVE AREA POINTERS 00900000 USING CDLOG,GRB TEMPORARY BASE REGISTER 00920000 LA GRS,AREA 00940000 ST GRL,4(GRS) 00960000 ST GRS,8(GRL) 00980000 SPACE 01000000 BEGIN EQU * 01010016 L GR2,0(GRA) OBTAIN ARGUMENT 01020018 LD FR0,0(GR2) REAL PART 01030018 LD FR2,8(GR2) IMAGINARY PART 01040018 ST GR2,ADYOX+4 SAVE ARGUMENT POINTER FOR DATAN2 CALL 01050018 LA GR2,8(GR2) 01060018 ST GR2,ADYOX 01070018 MVI ADYOX+4,X'80' 01080018 SPACE 01090018 LPER FR0,FR0 FORCE X POSITIVE 01100018 LPER FR2,FR2 FORCE Y POSITIVE 01110018 CDR FR0,FR2 A = MAX(/X/,/Y/), B = MIN(/X/,/Y/) 01120018 BC 10,SKIP1 IF NECESSARY SWITCH REGISTERS SO THAT 01130018 LDR FR4,FR0 IN ALL CASES FR0 CONTAINS A AND FR2 01140018 LDR FR0,FR2 CONTAINS B 01150018 LDR FR2,FR4 01160018 SPACE 01170018 SKIP1 SWR FR2,FR0 GIVE B SAME CHARACTERISTIC AS A 01180018 AWR FR2,FR0 01190018 STE FR0,BUFF1 01200018 STE FR2,BUFF1+4 01210018 SR GR0,GR0 01220018 LA GR2,65 01230018 IC GR0,BUFF1 01240018 SR GR0,GR2 S = 16**T 01250018 SLA GR0,2 4*T IN GR0 01260018 BC 10,SKIP2 IF A LESS THAN 1, T = CHAR(A)-64 01270018 LPR GR0,GR0 GIVE /X/ AND /Y/ CHARACTERISTIC OF 64 01280018 AL GR0,MFLOAT OTHERWISE, T = CHAR(A)-65 AND 01290018 LA GR2,64 GIVE /X/ AND /Y/ CHARACTERISTIC OF 65 01300018 SPACE 01310018 SKIP2 STC GR2,BUFF1 01320018 STC GR2,BUFF1+4 01330018 O GR0,CH46 FLOAT T 01340018 ST GR0,INTEG 01350018 LE FR0,BUFF1 01360018 LE FR2,BUFF1+4 01370018 MDR FR0,FR0 01380018 MDR FR2,FR2 01390018 ADR FR0,FR2 01400018 BC 8,ERROR ERROR IF /X/=/Y/=0 01410018 STD FR0,BUFF1 01420018 LA GRA,ADYOX 01430018 L GRL,ADATN2 OBTAIN ATAN2(Y/X) 01440018 BALR GRR,GRL 01450018 BC 0,ISNAT 01460018 STD FR0,BUFF2 01470018 SPACE 01480018 LA GRA,ADBUF1 01490018 L GRL,ADLOG OBTAIN LOG((X/S)**2+(Y/S)**2) 01500018 BALR GRR,GRL 01510018 BC 0,ISNLG 01520018 LD FR4,INTEG 01530018 MD FR4,LOG2 LOG(S) = 4*T*LOG(2) 01540018 HDR FR0,FR0 01550018 ADR FR0,FR4 FR0 HAS LOG(/X+IY/), REAL ANS PART 01560018 LD FR2,BUFF2 FR2 HAS ATAN2(Y/X) 01570018 SPACE 01620000 EXIT L GRS,AREA+4 RETURN FORMALITIES 01640000 LM GRR,GRB,12(GRS) 01660000 MVI 12(GRS),X'FF' 01680000 BCR 15,GRR 01700000 SPACE 01720000 ERROR STD FR0,DATA1 STORE DATA FOR USER FIXUP 01727016 STD FR0,DATA2 01734016 LA GR1,ERRLIST PARM FOR ERMON 01741016 L GRL,AERRMON 01748016 BALR GRR,GRL 01755016 SPACE 01762016 LA GRA,ERRLIST+12 01769016 CLI RETCODE+3,X'00' DID USER FIX DATA 01776016 BNZ BEGIN YES- CALCULATE WITH NEW DATA 01783016 SDR FR2,FR2 IMAG PART IS ZERO 01790016 LD FR0,NEGINF REAL PART IS LARGEST NEG NUM 01797016 B EXIT FOR STANDARD FIXUP 01804016 SPACE 3 01820000 BUFF1 DS D 01830018 BUFF2 DS D 01840018 DATA1 EQU BUFF2 01850018 DATA2 DS D 01872016 NEGINF DC X'FFFFFFFFFFFFFFFF' STANDARD FIX FOR REAL 01876016 INTEG DC X'0000000000000000' 01880018 LOG2 DC X'40B17217F7D1CF7B' LOG(2) BASE E +FUDGE 1 01884018 MFLOAT DC X'7FFFFFFC' 01888018 CH46 DC X'46000000' 01892018 AREA DS 18F 01900016 ADYOX DS 2F 01920000 ADATN2 DC A(DATAN2) 02000000 ADLOG DC A(DLOG) 02020000 ERRLIST DC A(MSGLNG) *PARM LIST FOR ERMON 02023016 DC A(RETCODE) * 02026016 DC A(ERRNUM) * 02029016 DC X'80' 02030018 DC AL3(DATA1) 02031018 ADBUF1 DC X'80' * 02032018 DC AL3(BUFF1) * 02035018 AERRMON DC V(IHCERRM) 02038016 ERRNUM DC F'283' 02041016 RETCODE DS F 02044016 EJECT 02047016 MSGLNG DC A(ENDMSG-MSG) 02050016 MSG DC C'IHC283I CDLOG ARGUMENT=0.D0+0.D0I' 02053016 ENDMSG EQU * 02056016 END 02060000 ./ ADD SSI=01013623,NAME=IHCCLSCN,SOURCE=0 CLSC TITLE 'COMPLEX SINE-COSINE FUNCTION (LONG)' 00010018 IHCCLSCN CSECT 00020000 * 00040000 * COMPLEX SINE-COSINE ROUTINE (LONG) 00060000 * SIN(X+IY) = SIN(X)*COSH(Y) + I*COS(X)*SINH(Y) 00080000 * COS(X+IY) = COS(X)*COSH(Y) - I*SIN(X)*SINH(Y) 00100000 SPACE 00120000 EXTRN IBCOM# 00140000 EXTRN IHCERRM 00150016 EXTRN DSIN 00160000 EXTRN DCOS 00180000 EXTRN DEXP 00200000 ENTRY CDSIN 00220000 ENTRY CDCOS 00240000 SPACE 00260000 GR0 EQU 0 SCRATCH REGISTERS 00280000 GR1 EQU 1 00300000 GR2 EQU 2 00320000 GR3 EQU 3 00330016 GRA EQU 1 ARGUMENT POINTER 00340000 GRS EQU 13 SAVE AREA POINTER 00360000 GRT EQU 3 PREVIOUS SAVE AREA POINTER 00380000 GRR EQU 14 RETURN REGISTER 00400000 GRL EQU 15 LINK REGISTER 00420000 GRB EQU 2 BASE REGISTER (FOR THE MOST PART) 00440000 FR0 EQU 0 ANSWER REGISTERS 00460000 FR2 EQU 2 00480000 FR4 EQU 4 SCRATCH REGISTER 00500000 ISN1 EQU X'314' 00520000 ISN2 EQU X'316' 00540000 ISN3 EQU X'318' 00560000 SPACE 00580000 USING *,GRL 00590018 CDCOS BC 15,CLCOS 00600018 DC AL1(5) 00610018 DC CL5'CDCOS' 00620018 SPACE 00630018 CLCOS STM GRR,GRT,12(GRS) SAVE REGOSTERS 00640018 MVI SWITCH+1,X'00' MAKE SWITCH INTO NOP 00650018 BAL GRL,JOIN 00660018 SPACE 00670018 USING *,GRL 00680018 CDSIN BC 15,CLSIN 00690018 DC AL1(5) 00700018 DC CL5'CDSIN' 00710018 SPACE 00720018 CLSIN STM GRR,GRT,12(GRS) SAVE REGISTERS 00730018 MVI SWITCH+1,X'F0' MAKE SWITCH UNCONDITIONAL 00740018 SPACE 00900000 JOIN LR GRT,GRS SWITCH SAVE AREA POINTERS 00920000 LA GRS,AREA AND GO THROUGH ENTRY FORMALITIES 00940000 ST GRS,8(GRT) 00960000 ST GRT,AREA+4 00980000 LR GRB,GRL 00985016 USING CDSIN,GRB SWITCH BASE REGISTERS 00990016 DROP GRL 00995016 BEGIN L GRR,0(GRA) ADDR OF ARGUMENT 01015016 LD FR0,0(GRR) OBTAIN REAL PART 01035016 LD FR2,8(GRR) OBTAIN IMAG PART 01055016 STD FR2,Y SAVE Y 01075016 SPACE 01120000 LPER FR0,FR0 IF /X/ GREATER THAN PI*2**50, ERROR 01240000 CE FR0,XMAX 01260000 BC 10,ERROR1 01280000 L GRL,ADSIN OBTAIN SIN(X) 01300000 BALR GRR,GRL 01320000 BC 0,ISN1 01340000 STD FR0,SINX 01360000 L GRA,24(GRT) RESTORE ARGUMENT POINTER 01380000 L GRL,ADCOS AND COMPUTE COS(X) 01400000 BALR GRR,GRL 01420000 BC 0,ISN2 01440000 STD FR0,COSX 01460000 SPACE 01462016 LD FR2,Y OBTAIN REAL 01464016 LPER FR2,FR2 FORCE Y POSITIVE 01466016 CE FR2,YMAX 01468016 BC 2,ERROR2 IF /Y/ GREATER THAN 174.673, ERROR 01470016 STD FR2,YABS ABS VALUE OF Y 01472016 SPACE 01480000 LA GRA,AYABS OBTAIN EXP(/Y/) IN FR0 01500000 L GRL,ADEXP 01520000 BALR GRR,GRL 01540000 BC 0,ISN3 01560000 SPACE 01580000 LR GRS,GRT RESTORE FOR POSSIBLE UNDERFLOW 01590018 SPACE 01600018 LD FR4,ONE OBTAIN EXP(-/Y/) IN FR4 01610018 DDR FR4,FR0 01620018 LD FR2,YABS 01630018 CE FR2,LIM1 01640018 BC 4,SMALL IF /Y/ LESS THAN 0.48121183, JUMP 01650018 SDR FR0,FR4 OTHERWISE COMPUTE SINH(/X/) AS 01660018 HDR FR2,FR0 (EXP(/Y/)-EXP(-/Y/))/2 01670018 SPACE 01680018 MERGE LDR FR0,FR2 SINH(/Y/) IN FR2 01690018 ADR FR0,FR4 COSH(Y) = EXP(-/Y/)+SINH(/Y/) IN FR0 01780000 COMPUT EQU * 01790016 TM Y,X'80' 01800000 BC 8,*+6 01820000 LNER FR2,FR2 SINH(Y) IN FR2 01840000 SWITCH BC 0,CSINE IF CDSIN ENTRY, JUMP 01870018 SPACE 01900000 MD FR0,COSX COMBINE 4 QUANTITIES TO 01920000 MD FR2,SINX OBTAIN COS(X+IY) IN FR0, FR2 01940000 LCER FR2,FR2 01960000 BC 15,EXIT 01980000 SPACE 02000000 CSINE MD FR0,SINX COMBINE 4 QUANTITIES TO 02020000 MD FR2,COSX OBTAIN SIN(X+IY) IN FR0, FR2 02040000 SPACE 02060000 EXIT EQU * 02080018 LM GRR,GRT,12(GRS) RESTORE OTHER GENERAL REGISTERS 02100000 MVI 12(GRS),X'FF' RETURN 02120000 BCR 15,GRR 02140000 SPACE 02160000 SMALL CE FR2,LIM2 IF /Y/ SMALLER THAN 16*-7, SINH(/Y/)=/Y/ 02170018 BC 4,MERGE 02180018 MDR FR2,FR2 COMPUTE SINH(/Y/) FOR SMALL /Y/ 02190018 LDR FR0,FR2 BY USE OF MINIMAX POLYNOMIAL 02200018 MD FR0,C5 OF DEGREE 5 02210018 AD FR0,C4 02220018 MDR FR0,FR2 02230018 AD FR0,C3 02240018 MDR FR0,FR2 02250018 AD FR0,C2 02260018 MDR FR0,FR2 02270018 AD FR0,C1 02280018 MDR FR2,FR0 02290018 MD FR2,YABS 02300018 AD FR2,YABS 02310018 BC 15,MERGE 02320018 SPACE 02460000 ERROR1 LA GR1,LIST1 POINT TO LIST FOR IHC284I 02463016 MVI MSG+5,X'F4' 02466016 SR GRR,GRR ERROR CODE FOR ERROR2 IS 0 02469016 B ERRORS 02472016 SPACE 02475016 ERROR2 LA GR1,LIST2 ERROR LIST FOR ERROR2 IHC285I 02478016 LA GRR,8 ERROR CODE IS 8 02481016 MVI MSG+5,X'F5' 02484016 SPACE 02487016 * STANDARD FIXUP FOR IHC285I IS AS FOLLOWS 02490016 * IF Y GT ZERO, CDSIN=(*/2)(DSIN(X)+DCOS(X)*I) 02493016 * CDCOS=(*/2)(DCOS(X)-DSIN(X)*I) 02496016 * 02499016 * IF Y LT ZERO, CDSIN=(*/2)(DSIN(X)-DCOS(X)*I) 02502016 * CDCOS=(*/2)(DCOS(X)+DSIN(X)*I) 02505016 * WHERE * IS THE LARGEST NUMBER IN THE MACHINE 02508016 * 02511016 ERRORS L GRT,24(GRT) GET ADDRESS OF ARGUMENT LIST 02514016 L GRT,0(GRT) GET ADDRESS OF ARGUMENT 02517016 MVC YABS(8),0(GRT) PUT ARG IN AREA FOR USER TO FIX 02520016 MVC TYPE(4),4(GR1) SET MSG TO 'REAL' OR 'IMAG' 02523016 MVC SUFFIX(11),8(GR1) INSERT END PART OF MSG 02526016 ST GR1,ERRLIST+8 STORE ADDR OF ERRNUM IN ERRLIST 02529016 L GRL,ACOM ADDR OF IBCOM# 02532016 ST GR2,12(GRS) SAVE ADDRESSABILITY 02535016 LA GR3,MSGDATA AREA IN MSG FOR CONVERTED DATA 02538016 LA GR2,YABS(GRR) ADDR OF REAL PART IF CODE=0 02541016 * ADDR OF IMAG PART IF CODE=8 02544016 EX 0,90(GRL) FCVDO 02547016 BALR 0,1 02550016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 02553016 LA GR3,AHEXDATA(GR3) AREA IN MSG FOR HEX DATA 02556016 EX 0,78(GRL) FCVZO 02559016 BALR 0,1 02562016 DC X'0810' LL=8 WW=16 02565016 SPACE 02568016 L GR2,12(GRS) RESTORE ADDRESSABILITY 02571016 L GRL,AERRMON 02574016 LA GR1,ERRLIST POINT TO PARM LIST 02577016 LR GR0,GRR SAVE ERROR CODE 02580016 BALR GRR,GRL TO IHCERRM 02583016 SPACE 02586016 LA GR1,ERRLIST+12 NEW ARG LIST 02589016 L GRT,4(GRS) PREV SAVE AREA 02592016 ST GR1,24(GRT) STORE NEW POINTER IN SAVE AREA 02595016 * FOR COMPUTATION WITH NEW DATA 02598016 CLI RETCODE+3,X'00' DID USER FIX DATA 02601016 BNZ BEGIN YES-START AGAIN 02604016 SPACE 02607016 LR GRS,GRT RESTORE SAVE AREA POINTER 02608018 SDR FR0,FR0 02610016 SDR FR2,FR2 IHC284I STANDARD FIXUP IS 0.+0.I 02613016 LTR GR0,GR0 WAS ERROR IHC284I 02616016 BZ EXIT YES-EXIT WITH 0.+0.I 02619016 SPACE 02622016 LD FR0,HALFINFY 02625016 LDR FR2,FR0 SET MULTIPLIER TO INFINITY OVER 2 02628018 B COMPUT SUBSTITUTE HALFINFY FOR SINH(Y) 02631016 * AND COSH(Y) 02634016 SPACE 02680000 SINX DS D 02700000 COSX DS D 02720000 YABS DS D 02740000 Y DS D 02750016 ONE DC X'4110000000000000' 02760000 C5 DC X'3A6C11A069B2EA82' 0.2516174082560345E-7 02780018 C4 DC X'3C2E3BA8BC90245F' 0.2755704132663989E-5 02800018 C3 DC X'3DD00D01083D72C5' 0.1984127016066868E-3 02820018 C2 DC X'3F222222221F51A6' 0.8333333333173353E-2 02840018 C1 DC X'402AAAAAAAAAAB66' 0.1666666666666693 02860018 HALFINFY DC X'7F7FFFFFFFFFFFFF' LARGEST NUMBER IN MACHINE 02886016 * DIVIDED BY 2. 02892016 XMAX DC X'4DC90FDA' 02902018 YMAX DC X'42AEAC4F' 02912018 LIM1 DC X'407B30B3' 02922018 LIM2 DC X'3A100000' 02932018 AREA DS 18F 02960016 ADSIN DC A(DSIN) 03020000 ADCOS DC A(DCOS) 03040000 ADEXP DC A(DEXP) 03060000 ACOM DC A(IBCOM#) 03080000 RETCODE DS F 03081016 AERRMON DC V(IHCERRM) 03082016 ERRLIST DC A(MSGLNG) 03083016 DC A(RETCODE) 03084016 DS F FOR ADDR OF ERROR NUMBER 03085016 AYABS DC X'80' PARM FOR DEXP AND ERROR 03086016 DC AL3(YABS) MONITOR 03087016 EJECT 03088016 LIST1 DC F'284' 03089016 DC C'REAL' 03090016 DC C'GE PI*2**50' 03091016 LIST2 DC F'285' 03092016 DC C'IMAG' 03093016 DC CL11'GT 174.673' 03094016 MSGLNG DC A(ENDMSG-MSG) 03095016 MSG DC C'IHC28*I CDSIN-CDCOS /' 03096016 TYPE DS 4C 03097016 DC C' ARG/=/' 03098016 MSGDATA DS 23C 03099016 DC C'(HEX=' 03100016 HEXDATA DS 16C 03101016 DC C')/, ' 03102016 SUFFIX DS 11C 03103016 ENDMSG EQU * 03104016 AHEXDATA EQU HEXDATA-MSGDATA 03105016 FLAG DS C 03106016 END 03120000 ./ ADD SSI=01013622,NAME=IHCCLSQT,SOURCE=0 CLSR TITLE 'COMPLEX SQUARE ROOT FUNCTION (LONG)' 00700018 IHCCLSQT CSECT 01400018 * 02100018 * COMPLEX SQUARE ROOT FUNCTION (LONG) 02800018 * 1. THE PRINCIPLE BRANCH OF THE SQUARE ROOT IS TAKEN, 03500018 * I.E., THE REAL PART OF THE ANSWER IS POSITIVE. 04200018 * 2. WRITE SQRT(X+IY) = U+IV, WHERE U IS REAL, AND V IS 04900018 * IMAGINARY. IF X=Y=0, U=V=0. 05600018 * 3. IF X IS NON-NEGATIVE, U = SQRT((/X/+/X+IY/)/2) AND 06300018 * V = Y/(2*U). 07000018 * 4. IF X IS NEGATIVE, U = Y/(2*V) AND 07700018 * V = SIGN(Y)*SQRT((/X/+/X+IY/)/2). 08400018 SPACE 09100018 EXTRN DSQRT 09800018 ENTRY CDSQRT 10500018 SPACE 11200018 GRA EQU 1 ARGUMENT POINTER 11900018 GRB EQU 3 TEMPORARY BASE REGISTER 12600018 GRS EQU 13 SAVE AREA POINTER 13300018 GRR EQU 14 RETURN REGISTER 14000018 GRL EQU 15 LINK REGISTER 14700018 GR0 EQU 0 SCRATCH REGISTERS 15400018 GR1 EQU 1 16100018 GR2 EQU 2 16800018 FR0 EQU 0 ANSWER REGISTERS 17500018 FR2 EQU 2 18200018 FR4 EQU 4 SCRATCH REGISTERS 18900018 FR6 EQU 6 19600018 ISNSQ1 EQU X'304' IDENTIFIER NUMBER FOR 1ST DSQRT CALL 20300018 ISNSQ2 EQU X'306' IDENTIFIER NUMBER FOR 2ND DSQRT CALL 21000018 SPACE 21700018 USING *,GRL 22400018 CDSQRT BC 15,CLSQRT 23100018 DC AL1(6) 23800018 DC CL7'CDSQRT' 24500018 SPACE 25200018 CLSQRT STM GRR,GRB,12(GRS) SAVE REGISTERS 25900018 LR GRB,GRL 26600018 USING CDSQRT,GRB GRB TEMPORARY BASE REGISTER 27300018 DROP GRL 28000018 LR GRL,GRS 28700018 LA GRS,AREA GRS NOW POINTS TO CURRENT SAVE AREA 29400018 ST GRL,4(GRS) GRL POINTS TO PREVIOUS SAVE AREA 30100018 ST GRS,8(GRL) 30800018 L GR2,0(GRA) OBTAIN ARGUMENT 31500018 LD FR6,0(GR2) REAL PART. FR6 UNCHANGED BY DSQRT CALL 32200018 LD FR2,8(GR2) IMAGINARY PART 32900018 LPER FR6,FR6 FORCE SIGNS POSITIVE 33600018 LPER FR2,FR2 34300018 LDR FR4,FR6 SAVE /X/ IN FR4 35000018 CDR FR6,FR2 A = MAX(/X/,/Y/), B = MIN(/X/,/Y/) 35700018 BC 10,READY IF NECESSARY SWITCH REGISTERS SO THAT 36400018 LDR FR6,FR2 IN ALL CASES FR6 CONTAINS A AND FR2 37100018 LDR FR2,FR4 CONTAINS B 37800018 READY LDR FR0,FR6 IF CHARACTERISTICS ARE DIFFERENT BY 38500018 SWR FR0,FR2 14 OR MORE, OR B=0, JUMP. 39200018 CDR FR0,FR6 THIS IS DONE TO AVOID ANY 39900018 L GRL,ADSQRT 40600018 BC 8,PURE INTERMEDIATE UNDERFLOW 41300018 DDR FR2,FR6 D = B/A 42000018 HDR FR2,FR2 TAKE SQRT OF 0.25+D*D/4 42700018 MDR FR2,FR2 THIS IS A MORE ACCURATE PROCEDURE 43400018 AW FR2,QUART THAN SQRT OF 1+D*D 44100018 STD FR2,BUFF 44800018 LA GRA,ABUFF CALL DSQRT SUBROUTINE 45500018 BALR GRR,GRL F = SQRT(0.25+D*D/4) 46200018 BC 0,ISNSQ1 /X+IY/ IS 2*A*F 46900018 LD FR2,0(GR2) 47600018 LPER FR2,FR2 /X/ 48300018 CE FR2,LLIM 49000018 BC 4,XSMALL IF A IS VERY SMALL, AVOID PREMATURE 49700018 HDR FR2,FR2 UNDERFLOW BY SPECIAL HANDLING 50400018 MDR FR0,FR6 (/X/)/2 IN FR2, A*F IN FR0 51100018 CE FR0,HLIM IF A IS NEAR OVERFLOW THRESHOLD, 51800018 BC 10,ABIG ALSO GIVE SPECIAL TREATMENT 52500018 JOIN1 LD FR6,ONE 53200018 JOIN2 ADR FR0,FR2 (/X/)/2+A*F, (/X/)+2*A*F, 53900018 STD FR0,BUFF OR (/X/)/4+A*F/2 NOW READY 54600018 LA GRA,ABUFF 55300018 BALR GRR,GRL CALL DSQRT AGAIN 56000018 BC 0,ISNSQ2 56700018 LD FR2,8(GR2) Y 57400018 LE FR4,0(GR2) X 58100018 L GRS,AREA+4 RESTORE GENERAL REGISTERS IN PREPARATION 58800018 LM GRR,GRB,12(GRS) FOR POSSIBLE DIVISION UNDERFLOW 59500018 USING CDSQRT,GRL 60200018 DROP GRB 60900018 MDR FR0,FR6 SQRT((/X/+/X+IY/)/2) READY IN FR0 61600018 BC 8,EXIT IF FR0 IS 0, THEN X=Y=0 62300018 DDR FR2,FR0 63000018 HDR FR2,FR2 63700018 LTER FR4,FR4 64400018 BC 10,EXIT IF X GRT OR = 0, ANSWER IS READY 65100018 LDR FR4,FR0 IF X LST 0, GIVE V SAME SIGN AS Y 65800018 LPDR FR0,FR2 66500018 LTER FR2,FR2 67200018 BC 10,*+6 67900018 LNER FR4,FR4 68600018 LDR FR2,FR4 69300018 SPACE 70000018 EXIT MVI 12(GRS),X'FF' 70700018 BCR 15,GRR RETURN 71400018 SPACE 72100018 USING CDSQRT,GRB 72800018 DROP GRL 73500018 XSMALL ADR FR6,FR6 CASE WHEN X IS VERY SMALL, OR SMALL 74200018 MDR FR0,FR6 RELATIVE TO Y. /X/ IN FR2, 2*A*F IN 74900018 JOIN3 LD FR6,R2OV2 FR0, 1/SQRT2 IN FR6 75600018 BC 15,JOIN2 76300018 SPACE 77000018 ABIG HDR FR0,FR0 CASE WHEN A IS VERY NEAR OVERFLOW 77700018 HDR FR2,FR2 THRESHHOLD. (/X/)/4 IN FR2, A*F/2 78400018 LD FR6,R2OV2 IN FR0 79100018 ADR FR6,FR6 SQRT2 IN FR6 79800018 BC 15,JOIN2 80500018 SPACE 81200018 PURE CDR FR0,FR4 CASE WHEN B IS NEGLIGIBLE RELATIVE TO A 81900018 BC 8,JOIN1 A=X, PURE REAL, A=(/X/+/X+IY/)/2 82600018 BC 15,JOIN3 A=Y, PURE IMAG, A=/X/+/X+IY/ 83300018 SPACE 84000018 DS 0F 84700018 ABUFF DC X'80' 85400018 DC AL3(BUFF) 86100018 ADSQRT DC A(DSQRT) 86800018 AREA DS 7F 87500018 HLIM DC X'7F800000' 88200018 BUFF DS D 88900018 QUART DC X'4040000000000001' 0.25 WITH ROUNDING FUDGE 89600018 ONE DC X'4110000000000000' 90300018 R2OV2 DC X'40B504F333F9DE65' 1/SQRT2 91000018 LLIM DC X'00200000' 91700018 END 92400018 ./ ADD SSI=01013622,NAME=IHCCSABS,SOURCE=0 CSAB TITLE 'COMPLEX ABSOLUTE VALUE FUNCTION (SHORT)' 01000018 IHCCSABS CSECT 02000018 * 03000018 * COMPLEX ABSOLUTE VALUE FUNCTION (SHORT) 04000018 * 1. WRITE /X+IY/ = U+IV, WHERE U IS THE REAL PART 05000018 * OF THE ANSWER, AND V IS THE IMAGINARY PART OF 06000018 * THE ANSWER. 07000018 * 2. LET Z1 = MAX(/X/,/Y/) AND Z2 = MIN(/X/,/Y/). 08000018 * 3. THEN U = 2*Z1*SQRT(0.25+(Z2/(2*Z1))**2), AND V = 0. 09000018 SPACE 10000018 EXTRN SQRT 11000018 ENTRY CABS 12000018 SPACE 13000018 GRA EQU 1 ARGUMENT POINTER 14000018 GRS EQU 13 SAVE AREA POINTER 15000018 GRR EQU 14 RETURN REGISTER 16000018 GRL EQU 15 LINK REGISTER 17000018 GR0 EQU 0 SCRATCH REGISTERS 18000018 GR1 EQU 1 19000018 FR0 EQU 0 ANSWER REGISTERS 20000018 FR2 EQU 2 21000018 FR6 EQU 6 SCRATCH REGISTER 22000018 ISNSQ EQU X'202' IDENTIFIER NUMBER FOR SQRT CALL 23000018 SPACE 24000018 USING *,GRL 25000018 CABS BC 15,CSABS 26000018 DC AL1(4) 27000018 DC CL5'CABS' 28000018 SPACE 29000018 CSABS STM GRR,GRA,12(GRS) SAVE REGISTERS 30000018 L GR1,0(GRA) OBTAIN ARGUMENT 31000018 LE FR6,0(GR1) REAL PART. FR6 UNCHANGED BY SQRT CALL 32000018 LE FR2,4(GR1) IMAGINARY PART 33000018 LPER FR6,FR6 FORCE SIGNS POSITIVE 34000018 LPER FR2,FR2 35000018 SPACE 36000018 CER FR6,FR2 A = MAX(/X/,/Y/), B = MIN(/X/,/Y/) 37000018 BC 10,READY IF NECESSARY SWITCH REGISTERS SO THAT 38000018 LER FR0,FR2 IN ALL CASES FR6 CONTAINS A AND FR2 39000018 LER FR2,FR6 CONTAINS B 40000018 LER FR6,FR0 41000018 SPACE 42000018 READY LER FR0,FR6 IF CHARACTERISTICS ARE DIFFERENT BY 43000018 SUR FR0,FR2 7 OR MORE, OR B=0, THE ANSWER IS A. 44000018 CER FR0,FR6 THIS IS DONE TO AVOID ANY 45000018 BC 8,EXIT INTERMEDIATE UNDERFLOW 46000018 DER FR2,FR6 D = B/A 47000018 HER FR2,FR2 TAKE SQRT OF 0.25+D*D/4 48000018 MER FR2,FR2 THIS IS A MORE ACCURATE PROCEDURE 49000018 AU FR2,QUART THAN SQRT OF 1+D*D 50000018 SPACE 51000018 LR GRR,GRS SWITCH SAVE AREA POINTERS 52000018 LA GRS,AREA 53000018 ST GRR,4(GRS) 54000018 ST GRS,8(GRR) 55000018 STE FR2,BUFF 56000018 LA GRA,ABUFF 57000018 L GRL,ASQRT CALL SQRT SUBROUTINE 58000018 BALR GRR,GRL 59000018 BC 0,ISNSQ 60000018 USING *-4,GRR 61000018 DROP GRL 62000018 L GRS,AREA+4 RESTORE REGISTERS 63000018 LM GRR,GRA,12(GRS) RESTORE GRA IN PREPARATION FOR POSSIBLE 64000018 USING CABS,GRL FLOATING POINT OVERFLOW 65000018 DROP GRR 66000018 SPACE 67000018 CE FR6,THRESH IF A IS VERY SMALL, AVOID PREMATURE 68000018 BC 4,SMALL UNDERFLOW BY CHANGING THE ORDER OF 69000018 MER FR0,FR6 MULTIPLICATION 70000018 AER FR0,FR0 71000018 SPACE 72000018 EXIT SER FR2,FR2 73000018 MVI 12(GRS),X'FF' 74000018 BCR 15,GRR RETURN 75000018 SPACE 76000018 SMALL AER FR6,FR6 77000018 MER FR0,FR6 78000018 BC 15,EXIT 79000018 SPACE 80000018 DS 0F 81000018 ABUFF DC X'80' 82000018 DC AL3(BUFF) 83000018 ASQRT DC A(SQRT) 84000018 AREA DS 7F 85000018 BUFF DS F 86000018 QUART DC X'40400001' 0.25 WITH ROUNDING FUDGE 87000018 THRESH DC X'00200000' 88000018 END 89000018 ./ ADD SSI=00052069,NAME=IHCCSAS,SOURCE=0 IHCCSAS CSECT 00020000 * 00040000 * COMPLEX MULTIPLY-DIVIDE SUBROUTINE (SHORT) 00060000 * GR1 POINTS TO ARGUMENT LIST WHICH LISTS ADDRESSES OF 00080000 * REAL PARTS OF BOTH OPERANDS. IMAGINARY PART OF EACH 00100000 * OPERAND MUST BE LOCATED IMMEDIATELY FOLLOWING ITS 00120000 * REAL PART 00140000 SPACE 00160000 ENTRY CMPY# 00180000 ENTRY CDVD# 00200000 SPACE 00220000 GR0 EQU 0 SCRATCH REGISTERS 00240000 GR1 EQU 1 00260000 GR2 EQU 14 00280000 GRA EQU 1 ARGUMENT POINTER 00300000 GRS EQU 13 SAVE AREA POINTER 00320000 GRR EQU 14 RETURN REGISTER 00340000 GRL EQU 15 LINK REGISTER 00360000 FR0 EQU 0 ANSWER REGISTERS 00380000 FR2 EQU 2 00400000 FR4 EQU 4 SCRATCH REGISTERS 00420000 FR6 EQU 6 00440000 SPACE 00460000 USING *,15 00480000 CMPY# B 10(0,15) 00500000 DC AL1(5) 00520000 DC CL5'CMPY#' 00540000 STM GRR,GRL,12(GRS) SAVE REGISTERS 00560000 MVI FLAG,1 SAVE REGISTERS AND SET FLAG 00580000 LA GRL,CDVD#-CMPY#(GRL) 00600000 USING CDVD#,GRL ADJUST BASE REGISTER BLD PUMP 00620000 BC 15,JOIN 00640000 SPACE 00660000 CDVD# B 10(0,15) 00680000 DC AL1(5) 00700000 DC CL5'CDVD#' 00720000 STM GRR,GRL,12(GRS) SAVE REGISTERS 00740000 MVI FLAG,0 SAVE REGISTERS AND RESET FLAG 00760000 JOIN L GR2,0(GRA) OBTAIN OPERANDS 00780000 LE FR0,0(GR2) A 00800000 LE FR2,4(GR2) B 00820000 L GR2,4(GRA) 00840000 LE FR4,0(GR2) C 00860000 LE FR6,4(GR2) D 00880000 STE FR4,C 00900000 STE FR6,D 00920000 TM FLAG,1 IF DIVID, JUMP 00940000 BC 8,DVD 00960000 SPACE 00980000 MER FR6,FR2 MULTIPLICATION 01000000 MER FR2,FR4 01020000 LER FR4,FR0 (A+BI)*(C+DI) = (AC-BD)+(AD+BC)I 01040000 ME FR4,D 01060000 ME FR0,C 01080000 SER FR0,FR6 01100000 AER FR2,FR4 01120000 RETURN L GR2,12(GRS) RETURN 01140000 MVI 12(GRS),X'FF' 01160000 BCR 15,GRR 01180000 SPACE 01200000 DVD LPER FR4,FR4 DIVISION 01220000 LPER FR6,FR6 01240000 CER FR4,FR6 IF /C/ GREATER THAN /D/, OK 01260000 LE FR4,C 01280000 LE FR6,D OTHERWISE SWITCH C AND D BY USING 01300000 BC 2,OK 01320000 LER FR6,FR0 A+BI B-AI 01340000 LER FR0,FR2 ---- = ---- 01360000 LCER FR2,FR6 C+DI D-CI 01380000 LCER FR6,FR4 01400000 LE FR4,D 01420000 SPACE 01440000 OK DER FR0,FR4 OBTAIN A'=A/C, B'=B/C, D'=D/C 01460000 DER FR2,FR4 01480000 DER FR6,FR4 A+BI A'+B'I A'+B'D' B'-A'D' 01500000 LER FR4,FR6 ---- = ------ = -------+-------I 01520000 MER FR6,FR6 C+DI 1+D'I 1+D'D' 1+D'D' 01540000 AE FR6,ONE 01560000 STE FR6,C 01580000 LER FR6,FR4 01600000 MER FR4,FR2 01620000 MER FR6,FR0 01640000 AER FR0,FR4 01660000 SER FR2,FR6 01680000 DE FR0,C 01700000 DE FR2,C 01720000 BC 15,RETURN 01740000 SPACE 01760000 FLAG DS C 01780000 C DS F 01800000 D DS F 01820000 ONE DC X'41100000' 01840000 END 01860000 ./ ADD SSI=01013623,NAME=IHCCSEXP,SOURCE=0 CSEX TITLE 'COMPLEX EXPONENTIAL FUNCTION (SHORT)' 00010018 IHCCSEXP CSECT 00020000 * 00040000 * COMPLEX EXPONENTIAL ROUTINE (SHORT) 00060000 * EXP(X+IY) = E**X * COS(Y) + I*E**X * SIN(Y) 00080000 SPACE 00100000 EXTRN IBCOM# 00120000 EXTRN IHCERRM 00130016 EXTRN EXP 00140000 EXTRN SIN 00160000 EXTRN COS 00180000 ENTRY CEXP ENTRY POINT NAME 00200000 SPACE 00220000 RG0 EQU 0 00305016 RG2 EQU 2 00310016 RG3 EQU 3 00315016 GRA EQU 1 ARGUMENT POINTER 00325018 GRB EQU 2 TEMPORARY BASE REGISTER 00335018 GRS EQU 13 SAVE AREA POINTER 00345018 GRR EQU 14 RETURN REGISTER 00355018 GRL EQU 15 LINK REGISTER 00365018 GR0 EQU 0 SCRATCH REGISTERS 00375018 GR1 EQU 1 00385018 GR2 EQU 14 00395018 FR0 EQU 0 ANSWER REGISTERS 00405018 FR2 EQU 2 00415018 FR6 EQU 6 SCRATCH REGISTER 00425018 ISNEX EQU X'208' IDENTIFIER NUMBER FOR EXP CALL 00435018 ISNSN EQU X'20A' IDENTIFIER NUMBER FOR SIN CALL 00445018 ISNCN EQU X'20C' IDENTIFIER NUMBER FOR COS CALL 00455018 SPACE 00465018 USING *,GRL 00475018 CEXP BC 15,CSEXP 00485018 DC AL1(4) 00495018 DC CL5'CEXP' 00505018 SPACE 00515018 CSEXP STM GRR,GRB,12(GRS) SAVE REGISTERS 00525018 LR GRB,GRL 00640000 USING CEXP,GRB GRB TEMPORARY BASE REGISTER 00660000 DROP GRL 00680000 LR GRL,GRS SWITCH SAVE AREA POINTERS 00700000 LA GRS,AREA GRS POINTS TO CURRENT SAVE AREA 00720000 ST GRL,4(GRS) GRL POINTS TO PREVIOUS SAVE AREA 00740000 ST GRS,8(GRL) 00760000 SPACE 00780000 BEGIN EQU * 00790016 L GR2,0(GRA) OBTAIN ARGUMENT 00800018 LE FR0,0(GR2) REAL PART (X) 00810018 LE FR2,4(GR2) IMAGINARY PART (Y) 00820018 SPACE 00860000 STE FR2,BUFF1 Y IN TEMPORARY STORAGE BUFF1 00880000 LPER FR2,FR2 /Y/ IN FR2 TO BE SCREENED 00900000 CE FR2,YMAX 00920000 BC 10,ERROR2 IF /Y/ GE PI*2**18, ERROR2 00940000 CE FR0,XMAX X TO BE SCREENED 00960000 BC 2,ERROR1 IF X GRT THAN 174.673, ERROR1 00980000 SPACE 01000000 L GRL,AEXP CALL EXP SUBROUTINE 01020000 BALR GRR,GRL E**X IN FR0 01040000 BC 0,ISNEX 01060000 SPACE 01080000 SINCOS EQU * 01090016 LER FR6,FR0 SAVE E**X. FR6 UNCHANGED BY SIN AND COS 01100018 SPACE 01110018 LA GRA,ABUFF1 CALL SIN SUBROUTINE 01120018 L GRL,ASIN 01130018 BALR GRR,GRL SIN(Y) IN FR0 01140018 BC 0,ISNSN 01150018 STE FR0,BUFF2 01160018 SPACE 01170018 LA GRA,ABUFF1 CALL COS SUBROUTINE 01180018 L GRL,ACOS 01190018 BALR GRR,GRL COS(Y) IN FR0 01200018 BC 0,ISNCN 01210018 SPACE 01220018 L GRS,AREA+4 RESTORE SAVEAREA POINTER 01230018 LER FR2,FR6 E**X IN FR2 01240018 MER FR0,FR2 E**X*COS(Y), REAL PART, READY IN FR0 01250018 ME FR2,BUFF2 E**X*SIN(Y), IMAG PART, READY IN FR2 01260018 SPACE 01440000 EXIT EQU * 01450016 LM GRR,GRB,12(GRS) 01480000 MVI 12(GRS),X'FF' 01500000 BCR 15,GRR 01520000 SPACE 01540000 ERROR1 LA GR1,ERRLIST1 01544016 SR GRR,GRR ERROR TYPE SWITCH=0 ERROR1 01548016 B ERRORS 01552016 SPACE 01556016 ERROR2 LA GR1,ERRLIST2 01560016 LA GRR,4 ERROR TYPE SWITCH=4 ERROR2 01564016 SPACE 01568016 ERRORS STE FR0,BUFF2 STORE REAL PART 01572016 L GRL,ACOM 01576016 STM GR1,RG3,12(GRS) SAVE REGS 1,2,3 FOR CONVERSION 01580016 LA RG3,AMSGDATA(GR1) PLACE IN MSG FOR CONVERTED DATA 01584016 LA RG2,BUFF2(GRR) DATA IN ERROR REAL IF SWITCH=0 01588016 * IMAG IF SWITCH=4 01592016 EX 0,86(GRL) FCVEO 01596016 BALR 0,1 01600016 DC X'040E0700' LL=4 WW=14 DD=7 SS=0 01604016 LA RG3,AHEXDATA(RG3) POINT TO HEX DATA IN MSG 01608016 EX 0,78(GRL) FCVZO 01612016 BALR 0,1 01616016 DC X'0408' LL=4 WW=8 01620016 LM GR1,RG3,12(GRS) RESTORE REGS(ERRLIST,BASE,CODE) 01624016 SPACE 01628016 L GRL,AERRMON 01632016 LR RG0,GRR SAVE ERROR TYPE SWITCH 01636016 BALR GRR,GRL 01640016 SPACE 01644016 LA GRA,ERRLIST1+12 POINT TO NEW DATA 01648016 CLI RETCODE+3,X'00' DID USER FIX DATA 01652016 BNZ BEGIN YES-START AGAIN 01656016 LE FR0,INFINY 01660016 * STANDARD FIXUP FOR ERROR1 IS 01664016 * SUBSTITUTING LARGEST NUMBER 01668016 * MACHINE HOLDS FOR E**X 01672016 LTR RG0,RG0 TEST ERROR TYPE SWITCH 01676016 BZ SINCOS RECOMPUTE USING 01680016 * INFINY*(COS(Y)+I*SIN(Y)) ERROR1 01684016 L GRS,AREA+4 01686018 SER FR0,FR0 STANDARD FIXUP FOR ERROR2 IS 01688016 SER FR2,FR2 0.0+0.0I 01692016 B EXIT 01696016 SPACE 3 01720000 AREA DS 18F 01750016 BUFF2 DS F 01780000 BUFF1 DS F BUFF2 MUST BE BEFORE BUFF1 01784016 * FOR ERROR-REAL PART 01788016 * IN BUFF2, IMAG PART 01792016 * IN BUFF1 01796016 XMAX DC X'42AEAC4F' 174.673 01816018 YMAX DC X'45C90000' PI*2**18 APPROXIMATELY (SIN, COS MAX) 01836018 ABUFF1 DC X'80' 01880000 DC AL3(BUFF1) 01900000 AEXP DC A(EXP) 01920000 ASIN DC A(SIN) 01940000 ACOS DC A(COS) 01960000 ACOM DC A(IBCOM#) 01980000 INFINY DC X'7FFFFFFF' 01980616 ERRNUM1 DC F'271' 01981216 ERRNUM2 DC F'272' 01981816 RETCODE DS F 01982416 AERRMON DC V(IHCERRM) 01983016 ERRLIST1 DC A(MSGLNG1) 01983616 DC A(RETCODE) 01984216 DC A(ERRNUM1) 01984816 DC X'80' 01985416 DC AL3(BUFF2) 01986016 MSGLNG1 DC A(ENDMSG1-MSG1) 01986616 MSG1 DC C'IHC271I CEXP REAL ARG=' 01987216 MSGDATA1 DS 14C 01987816 DC C'(HEX=' 01988416 HEXDATA1 DS 8C 01989016 DC C'), GT 174.673' 01989616 ENDMSG1 EQU * 01990216 ERRLIST2 DC A(MSGLNG2) 01990816 DC A(RETCODE) 01991416 DC A(ERRNUM2) 01992016 DC X'80' 01992616 DC AL3(BUFF2) 01993216 MSGLNG2 DC A(ENDMSG2-MSG2) 01993816 MSG2 DC C'IHC272I CEXP IMAG ARG=' 01994416 DS 14C 01995016 DC C'(HEX=' 01995616 DS 8C 01996216 DC C'), ABS VALUE GE PI*2**18' 01996816 ENDMSG2 EQU * 01997416 AMSGDATA EQU MSGDATA1-ERRLIST1 01998016 AHEXDATA EQU HEXDATA1-MSGDATA1 01998616 END 02000000 ./ ADD SSI=01013624,NAME=IHCCSLOG,SOURCE=0 CSLG TITLE 'COMPLEX LOGARITHMIC FUNCTION (SHORT)' 00020018 IHCCSLOG CSECT 00040018 * 00060018 * COMPLEX LOGARITHMIC FUNCTION (SHORT) 00080018 * 1. WRITE LOG(X+IY) = U+IV, WHERE U IS THE REAL PART 00100018 * OF THE ANSWER, AND V IS THE IMAGINARY PART. 00120018 * 2. THEN U = LOG(/X+IY), AND V = ATAN2(Y/X). 00140018 * 3. WRITE LOG(/X+IY/) = LOG(X**2+Y**2)/2 = 00160018 * LOG(S**2((X/S)**2+(Y/S)**2))/2 = 00180018 * LOG((X/S)**2+(Y/S)**2)/2+LOG(S), WHERE 00200018 * S IS A POWER OF 16, SUCH THAT, MAX(X,Y)/S 00220018 * IS BETWEEN 1 AND 1/16 OR BETWEEN 1 AND 16. 00240018 SPACE 00260018 EXTRN IHCERRM 00280018 EXTRN ALOG 00300018 EXTRN ATAN2 00320018 EXTRN IBCOM# 00340018 ENTRY CLOG 00360018 SPACE 00380018 GRA EQU 1 ARGUMENT POINTER 00400018 GRB EQU 2 BASE REGISTER 00420018 GRS EQU 13 SAVE AREA POINTER 00440018 GRR EQU 14 RETURN REGISTER 00460018 GRL EQU 15 LINK REGISTER 00480018 GR0 EQU 0 SCRATCH REGISTERS 00500018 GR1 EQU 1 00520018 GR2 EQU 14 00540018 FR0 EQU 0 ANSWER REGISTERS 00560018 FR2 EQU 2 00580018 FR4 EQU 4 SCRATCH REGISTERS 00600018 FR6 EQU 6 00620018 ISNAT EQU X'210' IDENTIFIER NUMBER FOR ATAN2 CALL 00640018 ISNLG EQU X'212' IDENTIFIER NUMBER FOR LOG CALL 00660018 SPACE 00680018 USING *,GRL 00700018 CLOG BC 15,CSLOG 00720018 DC AL1(4) 00740018 DC CL5'CLOG' 00760018 SPACE 00780018 CSLOG STM GRR,GRB,12(GRS) SAVE REGISTERS 00800018 MERGE LR GRB,GRL 00860000 USING CLOG,GRB TEMPORARY BASE REGISTER 00880000 DROP GRL 00900000 LR GRL,GRS SWITCH SAVE AREA POINTERS 00920000 LA GRS,AREA 00940000 ST GRL,4(GRS) 00960000 ST GRS,8(GRL) 00980000 BEGIN EQU * 00990016 L GR2,0(GRA) OBTAIN ARGUMENT 01000018 LE FR0,0(GR2) REAL PART 01010018 LE FR2,4(GR2) IMAGINARY PART 01020018 ST GR2,ADYOX+4 SAVE ARGUMENT POINTER FOR ATAN2 CALL 01030018 LA GR2,4(GR2) 01040018 ST GR2,ADYOX 01050018 MVI ADYOX+4,X'80' 01060018 SPACE 01070018 LPER FR0,FR0 FORCE X POSITIVE 01080018 LPER FR2,FR2 FORCE Y POSITIVE 01090018 CER FR0,FR2 A = MAX(/X/,/Y/), B = MIN(/X/,/Y/) 01100018 BC 10,SKIP1 IF NECESSARY SWITCH REGISTERS SO THAT 01110018 LER FR4,FR0 IN ALL CASES FR0 CONTAINS A AND FR2 01120018 LER FR0,FR2 CONTAINS B 01130018 LER FR2,FR4 01140018 SPACE 01150018 SKIP1 SUR FR2,FR0 GIVE B SAME CHARACTERISTIC AS A 01160018 AUR FR2,FR0 01170018 STE FR0,BUFF 01180018 STE FR2,INTEG 01190018 SR GR0,GR0 01200018 LA GR2,65 01210018 IC GR0,BUFF 01220018 SR GR0,GR2 S = 16**T 01230018 SLA GR0,2 4*T IN GR0 01240018 BC 10,SKIP2 IF A LESS THAN 1, T = CHAR(A)-64 01250018 LPR GR0,GR0 GIVE /X/ AND /Y/ CHARACTERISTIC OF 64 01260018 AL GR0,MFLOAT OTHERWISE, T = CHAR(A)-65 AND 01270018 LA GR2,64 GIVE /X/ AND /Y/ CHARACTERISTIC OF 65 01280018 SPACE 01290018 SKIP2 STC GR2,BUFF 01300018 STC GR2,INTEG 01310018 LE FR0,BUFF 01320018 LE FR2,INTEG 01330018 O GR0,CH46 FLOAT T 01340018 ST GR0,INTEG 01350018 MER FR0,FR0 01360018 MER FR2,FR2 01370018 AER FR0,FR2 01380018 BC 8,ERROR ERROR IF /X/=/Y/=0 01390018 SPACE 01400018 STE FR0,BUFF 01410018 LA GRA,ADYOX 01420018 L GRL,ADATN2 OBTAIN ATAN2(Y/X) 01430018 BALR GRR,GRL 01440018 BC 0,ISNAT 01450018 LER FR6,FR0 FR6 UNCHANGED BY LOG 01460018 SPACE 01470018 LA GRA,ADBUFF 01480018 L GRL,ADLOG OBTAIN LOG((X/S)**2+(Y/S)**2) 01490018 BALR GRR,GRL 01500018 BC 0,ISNLG 01510018 LE FR4,INTEG 01520018 ME FR4,LOG2 LOG(S) = 4*T*LOG(2) 01530018 HER FR0,FR0 01540018 ADR FR0,FR4 FR0 HAS LOG(/X+IY/), REAL ANS PART 01550018 LER FR2,FR6 FR2 HAS ATAN2(Y/X) 01560018 SPACE 01570018 EXIT L GRS,AREA+4 RETURN FORMALITIES 01580018 LM GRR,GRB,12(GRS) 01590018 MVI 12(GRS),X'FF' 01600018 BCR 15,GRR 01610018 SPACE 01720000 ERROR STE FR0,DATA1 01728016 STE FR0,DATA2 01736016 LA 1,ERRLIST 01744016 L 15,AERRMON 01752016 BALR 14,15 01760016 LA GRA,ERRLIST+12 01768016 CLI RETCODE+3,X'00' DID USER FIX DATA 01776016 BNZ BEGIN YES- RECALCULATE NEW DATA 01784016 SER FR2,FR2 IMAG PART = 0 01792016 LE FR0,NEGINF REAL PART LARGEST NEGATIVE NUMBER 01800016 B EXIT 01808016 SPACE 3 01820000 AREA DS 18F 01900016 ERRLIST DC A(MSGLNG) 01923016 DC A(RETCODE) 01926016 DC A(ERRNUM) 01929016 DC X'80' 01932016 DC AL3(DATA1) 01935016 BUFF DS F 01942018 INTEG DS F 01949018 LOG2 DC X'40B17219' 01956018 ACOM DC A(IBCOM#) 01963018 ADYOX DS 2F 01970018 ADBUFF DC X'80' 01977018 DC AL3(BUFF) 01984018 ADATN2 DC A(ATAN2) 01991018 ADLOG DC A(ALOG) 01998018 MFLOAT DC X'7FFFFFFC' 02005018 CH46 DC X'46000000' 02012018 DATA1 DS F FOR REAL PART 02019018 DATA2 DS F FOR IMAG PART 02026018 SPACE 2 02042016 AERRMON DC V(IHCERRM) 02044016 RETCODE DS F 02046016 ERRNUM DC F'273' 02048016 NEGINF DC X'FFFFFFFF' STANDARD FIXUP FOR REAL PART 02050016 MSGLNG DC A(ENDMSG-MSG) 02052016 MSG DC C'IHC273I CLOG ARGUMENT=0.0+0.0I' 02054016 ENDMSG EQU * 02056016 END 02060000 ./ ADD SSI=01013623,NAME=IHCCSSCN,SOURCE=0 CSSC TITLE 'COMPLEX SINE-COSINE FUNCTION (SHORT)' 00010018 IHCCSSCN CSECT 00020000 * 00040000 * COMPLEX SINE-COSINE ROUTINE (SHORT) 00060000 * SIN(X+IY) = SIN(X)*COSH(Y) + I*COS(X)*SINH(Y) 00080000 * COS(X+IY) = COS(X)*COSH(Y) - I*SIN(X)*SINH(Y) 00100000 SPACE 00120000 EXTRN IBCOM# 00140000 EXTRN IHCERRM 00150016 EXTRN SIN 00160000 EXTRN COS 00180000 EXTRN EXP 00200000 ENTRY CSIN 00220000 ENTRY CCOS 00240000 SPACE 00260000 GR0 EQU 0 SCRATCH REGISTERS 00280000 GR1 EQU 1 00300000 GR2 EQU 2 00320000 GR3 EQU 3 00330016 GRA EQU 1 ARGUMENT POINTER 00340000 GRS EQU 13 SAVE AREA POINTER 00360000 GRT EQU 3 PREVIOUS SAVE AREA POINTER 00380000 GRR EQU 14 RETURN REGISTER 00400000 GRL EQU 15 LINK REGISTER 00420000 GRB EQU 2 BASE REGISTER (FOR THE MOST PART) 00440000 FR0 EQU 0 ANSWER REGISTERS 00460000 FR2 EQU 2 00480000 FR4 EQU 4 SCRATCH REGISTER 00500000 ISN1 EQU X'214' 00520000 ISN2 EQU X'216' 00540000 ISN3 EQU X'218' 00560000 SPACE 00580000 USING *,GRL 00590018 CCOS BC 15,CSCOS 00600018 DC AL1(4) 00610018 DC CL5'CCOS' 00620018 SPACE 00630018 CSCOS STM GRR,GRT,12(GRS) SAVE REGOSTERS 00640018 MVI SWITCH+1,X'00' MAKE SWITCH INTO NOP 00650018 BAL GRL,JOIN 00660018 SPACE 00670018 USING *,GRL 00680018 CSIN BC 15,CSSIN 00690018 DC AL1(4) 00700018 DC CL5'CSIN' 00710018 SPACE 00720018 CSSIN STM GRR,GRT,12(GRS) SAVE REGISTERS 00730018 MVI SWITCH+1,X'F0' MAKE SWITCH UNCONDITIONAL 00740018 SPACE 00900000 JOIN LR GRT,GRS SWITCH SAVE AREA POINTERS 00920000 LA GRS,AREA AND GO THROUGH ENTRY FORMALITIES 00940000 ST GRS,8(GRT) 00960000 ST GRT,AREA+4 00980000 LR GRB,GRL SWITCH BASE REGS 00990016 DROP GRL 01000016 USING CSIN,GRB 01010016 SPACE 01020016 BEGIN EQU * 01030016 L GRR,0(GRA) 01040016 LE FR0,0(GRR) REAL PART 01050016 LE FR2,4(GRR) IMAGINARY PART 01060016 STE FR0,YABS SAVE REAL PART 01070016 STE FR2,Y SAVE SIGN OF Y 01080016 LPER FR0,FR0 ABS VALUE OF X 01090016 CE FR0,XMAX 01100016 BC 10,ERROR1 IF /X/ GE PI*2**18, ERROR 01110016 SPACE 01120016 L GRL,ADSIN OBTAIN SIN(X) 01130016 BALR GRR,GRL 01140016 BC 0,ISN1 01150016 STE FR0,SINX 01160016 L GRA,24(GRT) RESTORE ARGUMENT POINTER 01170016 L GRL,ADCOS COMPUTE COS(X) 01180016 BALR GRR,GRL 01190016 BC 0,ISN2 01200016 STE FR0,COSX 01210016 SPACE 01220016 LE FR2,Y 01230016 LPER FR2,FR2 ABS VALUE OF Y 01240016 CE FR2,YMAX 01250016 BC 2,ERROR2 IF /Y/ GT 174.673, ERROR 01260016 STE FR2,YABS 01270016 SPACE 01480000 LA GRA,AYABS OBTAIN EXP(/Y/) IN FR0 01500000 L GRL,ADEXP 01520000 BALR GRR,GRL 01540000 BC 0,ISN3 01560000 SPACE 01580000 LR GRS,GRT RESTORE SAVE AREA POINTER 01590018 LE FR4,ONE OBTAIN EXP(-/Y/) IN FR4 01600000 DER FR4,FR0 01620000 LE FR2,YABS 01640000 CE FR2,LIM1 01660018 BC 4,SMALL IF /Y/ LESS TAN 0.3465736, JUMP 01680018 SER FR0,FR4 OTHERWISE COMPUTE SINH(/X/) AS 01700018 HER FR2,FR0 (EXP(/Y/)-EXP(-/Y/))/2 01720018 SPACE 01740018 MERGE LER FR0,FR2 SINH(/Y/) IN FR2 01760018 AER FR0,FR4 COSH(Y) = EXP(-/Y/)+SINH(/Y/) IN FR0 01780000 COMPUT EQU * 01790016 TM Y,X'80' 01800000 BC 8,*+6 01820000 LNER FR2,FR2 SINH(Y) IN FR2 01840000 SWITCH BC 0,CSINE IF CSIN ENTRY, JUMP 01870018 SPACE 01900000 ME FR0,COSX COMBINE 4 QUANTITIES TO 01920000 ME FR2,SINX OBTAIN COS(X+IY) IN FR0, FR2 01940000 LCER FR2,FR2 01960000 BC 15,EXIT 01980000 SPACE 02000000 CSINE ME FR0,SINX COMBINE 4 QUANTITIES TO 02020000 ME FR2,COSX OBTAIN SIN(X+IY) IN FR0, FR2 02040000 SPACE 02060000 EXIT LM GRR,GRT,12(GRS) 02070018 MVI 12(GRS),X'FF' 02080018 BCR 15,GRR RETURN 02090018 SPACE 02100018 SMALL CE FR2,LIM2 IF /Y/ SMALLER THAN 16*-3, SINH(/Y/)=/Y/ 02110018 BC 4,MERGE 02120018 MER FR2,FR2 COMPUTE SINH(/Y/) FOR SMALL /Y/ 02130018 LER FR0,FR2 BY USE OF MINIMAX POLYNOMIAL 02140018 ME FR0,C2 OF DEGREE 2 02150018 AE FR0,C1 02160018 MER FR2,FR0 02170018 ME FR2,YABS 02180018 AE FR2,YABS 02190018 BC 15,MERGE 02200018 SPACE 02340000 ERROR1 LA GRR,ERRLIST1 /X/GE PI*2**18 02344016 SR GR3,GR3 CODE FOR ERROR1 02348016 B ERRORS 02352016 SPACE 02356016 ERROR2 LA GRR,ERRLIST2 /Y/ GT 174.673 02360016 LA GR3,4 CODE FOR ERROR2 02364016 SPACE 02368016 ERRORS EQU * X IN REAL,Y IN IMAG 02372016 L GRL,ACOM ADDRESS OF IBCOM 02376016 STM GRB,GR3,12(GRS) SAVE ADDRESSABILITY AND CODE 02380016 LA GR2,REAL(GR3) CODE=0, DATA IS REAL 02384016 * CODE =4, DATA IS IMAGINARY 02388016 LA GR3,AMSGDATA(GRR) PLACE IN MESSAGE FOR DATA 02392016 EX 0,86(GRL) FCVEO 02396016 BALR 0,1 02400016 DC X'040E0700' LL=4 WW=14 DD=7 SS=0 02404016 SPACE 02408016 LA GR3,AHEXDATA(GR3) HEXDATA FOR MSG 02412016 EX 0,78(GRL) FCVZO 02416016 BALR 0,1 02420016 DC X'0408' LL=4 WW=8 02424016 SPACE 02428016 LR GR1,GRR ERROR PARM LIST ADDR 02432016 LM GRB,GR3,12(GRS) REG2=USING, REG3=ERROR CODE 02436016 L 15,AERRMON 02440016 BALR 14,15 02444016 LR GRR,GR3 SAVE ERROR CODE 02448016 L GRT,4(GRS) USER SAVE AREA 02452016 LA GRA,ERRLIST1+12 POINT TO NEW DATA 02456016 ST GRA,24(GRT) STORE NEW ARG POINTER IN USER 02460016 * SAVE AREA FOR RECOMPUTATION 02464016 CLI RETCODE+3,X'00' DID USER FIX DATA 02468016 BNZ BEGIN 02472016 SPACE 02476016 SER FR0,FR0 IHC274I-STANDARD FIXUP IS 02480016 SER FR2,FR2 0.0+0.0I 02484016 LR GRS,GRT RESTORE GRS FOR EXIT 02486018 LTR GRR,GRR TEST ERROR CODE 02488016 BZ EXIT CODE=0,ERROR1, 0.0+0.0I 02492016 LE FR0,HALFINFY 02496016 LER FR2,FR0 SUBSTITUTE INFINITY OVER 2 FOR 02498018 * MULTIPLYING FACTOR 02500018 B COMPUT 02504016 SPACE 02520000 ACOM DC A(IBCOM#) 02540000 ADSIN DC A(SIN) 02560000 ADCOS DC A(COS) 02580000 ADEXP DC A(EXP) 02600000 AREA DS 18F 02640016 SINX DS F 02680000 COSX DS F 02700000 YABS DS F 02710016 Y DS F 02720000 REAL EQU YABS 02724016 IMAG EQU Y 02728016 AERRMON DC V(IHCERRM) 02732016 RETCODE DS F 02736016 ERRNUM1 DC F'274' 02740016 ERRNUM2 DC F'275' 02744016 HALFINFY DC X'7F7FFFFF' LARGEST NUMBER IN MACHINE 02748016 * DIVIDED BY 2. 02752016 XMAX DC X'45C90000' PI*2**18 APPROXIMATELY (SIN, COS MAX) 02762018 YMAX DC X'42AEAC4F' 02772018 LIM1 DC X'4058B90C' 02782018 LIM2 DC X'3E100000' 02792018 ONE DC X'41100000' 02802018 C2 DC X'3F2244F1' 0.83665295E-2 02812018 C1 DC X'402AAA96' 0.16666544 02822018 ERRLIST1 DC A(MSGLNG1) 02880616 DC A(RETCODE) 02881216 DC A(ERRNUM1) 02881816 DC X'80' 02882416 DC AL3(REAL) 02883016 EJECT 02883616 MSGLNG1 DC A(ENDMSG1-MSG1) 02884216 MSG1 DC C'IHC274I CSIN-CCOS /REAL ARG/=/' 02884816 MSGDATA DS 14C 02885416 DC C'(HEX=' 02886016 HEXDATA DS 8C 02886616 DC C')/, GE PI*2**18' 02887216 ENDMSG1 EQU * 02887816 SPACE 02888416 ERRLIST2 DC A(MSGLNG2) 02889016 DC A(RETCODE) 02889616 DC A(ERRNUM2) 02890216 AYABS DC X'80' 02890816 DC AL3(YABS) 02891416 MSGLNG2 DC A(ENDMSG2-MSG2) 02892016 MSG2 DC C'IHC275I CSIN-CCOS /IMAG ARG/=/' 02892616 DS 14C 02893216 DC C'(HEX=' 02893816 DS 8C 02894416 DC C')/, GT 174.673' 02895016 ENDMSG2 EQU * 02895616 AMSGDATA EQU MSGDATA-ERRLIST1 02896216 AHEXDATA EQU HEXDATA-MSGDATA 02896816 FLAG DS C 02900000 END 02920000 ./ ADD SSI=01013622,NAME=IHCCSSQT,SOURCE=0 CSSR TITLE 'COMPLEX SQUARE ROOT FUNCTION (SHORT)' 00700018 IHCCSSQT CSECT 01400018 * 02100018 * COMPLEX SQUARE ROOT FUNCTION (SHORT) 02800018 * 1. THE PRINCIPLE BRANCH OF THE SQUARE ROOT IS TAKEN, 03500018 * I.E., THE REAL PART OF THE ANSWER IS POSITIVE. 04200018 * 2. WRITE SQRT(X+IY) = U+IV, WHERE U IS REAL, AND V IS 04900018 * IMAGINARY. IF X=Y=0, U=V=0. 05600018 * 3. IF X IS NON-NEGATIVE, U = SQRT((/X/+/X+IY/)/2) AND 06300018 * V = Y/(2*U). 07000018 * 4. IF X IS NEGATIVE, U = Y/(2*V) AND 07700018 * V = SIGN(Y)*SQRT((/X/+/X+IY/)/2). 08400018 SPACE 09100018 EXTRN SQRT 09800018 ENTRY CSQRT 10500018 SPACE 11200018 GRA EQU 1 ARGUMENT POINTER 11900018 GRB EQU 3 TEMPORARY BASE REGISTER 12600018 GRS EQU 13 SAVE AREA POINTER 13300018 GRR EQU 14 RETURN REGISTER 14000018 GRL EQU 15 LINK REGISTER 14700018 GR0 EQU 0 SCRATCH REGISTERS 15400018 GR1 EQU 1 16100018 GR2 EQU 2 16800018 FR0 EQU 0 ANSWER REGISTERS 17500018 FR2 EQU 2 18200018 FR4 EQU 4 SCRATCH REGISTERS 18900018 FR6 EQU 6 19600018 ISNSQ1 EQU X'204' IDENTIFIER NUMBER FOR 1ST SQRT CALL 20300018 ISNSQ2 EQU X'206' IDENTIFIER NUMBER FOR 2ND SQRT CALL 21000018 SPACE 21700018 USING *,GRL 22400018 CSQRT BC 15,CSSQRT 23100018 DC AL1(5) 23800018 DC CL5'CSQRT' 24500018 SPACE 25200018 CSSQRT STM GRR,GRB,12(GRS) SAVE REGISTERS 25900018 LR GRB,GRL 26600018 USING CSQRT,GRB GRB TEMPORARY BASE REGISTER 27300018 DROP GRL 28000018 LR GRL,GRS 28700018 LA GRS,AREA GRS NOW POINTS TO CURRENT SAVE AREA 29400018 ST GRL,4(GRS) GRL POINTS TO PREVIOUS SAVE AREA 30100018 ST GRS,8(GRL) 30800018 L GR2,0(GRA) OBTAIN ARGUMENT 31500018 LE FR6,0(GR2) REAL PART. FR6 UNCHANGED BY SQRT CALL 32200018 LE FR2,4(GR2) IMAGINARY PART 32900018 LPER FR6,FR6 FORCE SIGNS POSITIVE 33600018 LPER FR2,FR2 34300018 LER FR4,FR6 SAVE /X/ IN FR4 35000018 CER FR6,FR2 A = MAX(/X/,/Y/), B = MIN(/X/,/Y/) 35700018 BC 10,READY IF NECESSARY SWITCH REGISTERS SO THAT 36400018 LER FR6,FR2 IN ALL CASES FR6 CONTAINS A AND FR2 37100018 LER FR2,FR4 CONTAINS B 37800018 SPACE 38500018 READY LER FR0,FR6 IF CHARACTERISTICS ARE DIFFERENT BY 39200018 SUR FR0,FR2 6 OR MORE, OR B=0, JUMP. 39900018 CER FR0,FR6 THIS IS DONE TO AVOID ANY 40600018 L GRL,ASQRT INTERMEDIATE UNDERFLOW 41300018 BC 8,PURE 42000018 DER FR2,FR6 D = B/A 42700018 HER FR2,FR2 TAKE SQRT OF 0.25+D*D/4 43400018 MER FR2,FR2 THIS IS A MORE ACCURATE PROCEDURE 44100018 AU FR2,QUART THAN SQRT OF 1+D*D 44800018 STE FR2,BUFF 45500018 LA GRA,ABUFF CALL SQRT SUBROUTINE 46200018 BALR GRR,GRL F = SQRT(0.25+D*D/4) 46900018 BC 0,ISNSQ1 /X+IY/ IS 2*A*F 47600018 LER FR2,FR4 FR4 TRANSPARENT TO SQRT 48300018 CE FR2,LLIM 49000018 BC 4,XSMALL IF A IS VERY SMALL, AVOID PREMATURE 49700018 HER FR2,FR2 UNDERFLOW BY SPECIAL HANDLING 50400018 MER FR0,FR6 (/X/)/2 IN FR2, A*F IN FR0 51100018 CE FR0,HLIM IF A IS NEAR OVERFLOW THRESHOLD, 51800018 BC 10,ABIG ALSO GIVE SPECIAL TREATMENT 52500018 SPACE 53200018 JOIN1 LE FR6,ONE 53900018 JOIN2 AER FR0,FR2 (/X/)/2+A*F, (/X/)+2*A*F, 54600018 STE FR0,BUFF OR (/X/)/4+A*F/2 NOW READY 55300018 LA GRA,ABUFF 56000018 BALR GRR,GRL CALL SQRT AGAIN 56700018 BC 0,ISNSQ2 57400018 LE FR2,4(GR2) Y 58100018 LE FR4,0(GR2) X 58800018 L GRS,AREA+4 RESTORE GENERAL REGISTERS IN PREPARATION 59500018 LM GRR,GRB,12(GRS) FOR POSSIBLE DIVISION UNDERFLOW 60200018 USING CSQRT,GRL 60900018 DROP GRB 61600018 MER FR0,FR6 SQRT((/X/+/X+IY/)/2) READY IN FR0 62300018 BC 8,EXIT IF FR0 IS 0, THEN X=Y=0 63000018 DER FR2,FR0 63700018 HER FR2,FR2 64400018 LTER FR4,FR4 65100018 BC 10,EXIT IF X GRT OR = 0, ANSWER IS READY 65800018 LER FR4,FR0 IF X LST 0, GIVE V SAME SIGN AS Y 66500018 LPER FR0,FR2 67200018 LTER FR2,FR2 67900018 BC 10,*+6 68600018 LNER FR4,FR4 69300018 LER FR2,FR4 70000018 SPACE 70700018 EXIT MVI 12(GRS),X'FF' 71400018 BCR 15,GRR RETURN 72100018 SPACE 72800018 USING CSQRT,GRB 73500018 DROP GRL 74200018 XSMALL AER FR6,FR6 CASE WHEN X IS VERY SMALL, OR SMALL 74900018 MER FR0,FR6 RELATIVE TO Y. /X/ IN FR2, 2*A*F IN 75600018 JOIN3 LE FR6,R2OV2 FR0, 1/SQRT2 IN FR6 76300018 BC 15,JOIN2 77000018 SPACE 77700018 ABIG HER FR0,FR0 CASE WHEN A IS VERY NEAR OVERFLOW 78400018 HER FR2,FR2 THRESHHOLD. (/X/)/4 IN FR2, A*F/2 79100018 LE FR6,R2OV2 IN FR0 79800018 AER FR6,FR6 SQRT2 IN FR6 80500018 BC 15,JOIN2 81200018 SPACE 81900018 PURE CER FR0,FR4 CASE WHEN B IS NEGLIGIBLE RELATIVE TO A 82600018 BC 8,JOIN1 A=X, PURE REAL, A=(/X/+/X+IY/)/2 83300018 BC 15,JOIN3 A=Y, PURE IMAG, A=/X/+/X+IY/ 84000018 SPACE 84700018 DS 0F 85400018 ABUFF DC X'80' 86100018 DC AL3(BUFF) 86800018 ASQRT DC A(SQRT) 87500018 AREA DS 7F 88200018 BUFF DS F 88900018 QUART DC X'40400001' 0.25 WITH ROUNDING FUDGE 89600018 ONE DC X'41100000' 90300018 R2OV2 DC X'40B504F3' 1/SQRT2 91000018 HLIM DC X'7F800000' 91700018 LLIM DC X'00200000' 92400018 END 93100018 ./ ADD SSI=21460004,NAME=IHCDBUG,SOURCE=0 TITLE ' IHCDBUG - FOR FULL FORTRAN (G AND H) ' 00020013 IHCDBUG START 00040000 * 071000,071400,074000,133000,134800,138400,154800, 28107 00043020 * 155200-155400 28107 00046020 * 144200 31929 00049020 *A053100 A49520 00050021 *C077800-078800,133100-133200 A49520 00051021 *A136420-136540,154830 A49520 00052021 EXTRN ADCON# 9036 00055013 ENTRY DEBUG# 00060000 EXTRN IHCUATBL 00080000 EXTRN FIOCS# 00100000 *********************************************************************** 00120000 * 00130021 * STATUS - CHANGE LEVEL 05 21MAY72 RELEASE 21.6 00140021 * 00160000 *FUNCTION/OPERATION. IHCDBUG IS A MEMBER OF THE FORTRAN IV (G) 00180000 * OBJECT LIBRARY (SYS1.FORTLIB). IT SUPPORTS THE DEBUG LANGUAGE 00200000 * FACILITY, IN THAT ALL DEBUG LANGUAGE STATEMENTS CAUSE ONE 00220000 * OR MORE CALLS TO BE MADE TO THIS ROUTINE, WHICH IN TURN CALLS 00240000 * FIOCS TO PERFORM ACTUAL OUTPUT OPERATIONS. 00260000 * 00280000 *ENTRY POINTS. 00300000 * THERE IS ONE EXTERNAL ENTRY TO THIS ROUTINE - DEBUG#. THIS NAME 00320000 * IS GIVEN TO THE INITIAL WORD OF A TRANSFER VECTOR. THE GENERAL 00340000 * FORM OF A CALL IS THEREFORE - 00360000 * 00380000 * L 15,=V(DEBUG#) 00400000 * BAL 14,D(15) 00420000 * 00440000 * WHERE 'D' VARIES ACCORDING TO THE FUNCTION TO BE PERFORMED. THE 00460000 * FOLLOWING TABLE LISTS THE VARIOUS POSSIBLE VALUES, AND THE 00480000 * CORRESPONDING ROUTINE NAMES AND FUNCTIONS. 00500000 * 00520000 * 1----------------------------------------------------------1 00540000 * 1 ROUTINE 1 D 1 FUNCTION 1 00560000 * 1----------1-----1-----------------------------------------1 00580000 * 1 1 1 1 00600000 * 1 TRACE 1 0 1 PASS STATEMENT LABEL FOR F6OW TRACING 1 00620000 * 1 SUBTREN 1 4 1 PASS SUBPROGRAM NAME ON ENTRY 1 00640000 * 1 SUBTREX 1 8 1 PASS *RETURN* ON SUBPROGRAM EXIT 1 00660000 * 1 UNIT 1 12 1 INITIALIZE FOR OUTPUT ON SPECIFIED UNIT 1 00680000 * 1 INITSCLR 1 16 1 PASS DATA ON INITIALIZED SCALAR 1 00700000 * 1 INITARIT 1 20 1 PASS DATA ON INITIALIZED ARRAY ELEMENT 1 00720000 * 1 INITARAY 1 24 1 PASS DATA ON INITIALIZED ARRAY 1 00740000 * 1 SUBCHK 1 28 1 PASS DATA ON REFERENCED ARRAY ELEMENT 1 00760000 * 1 TRACEON 1 32 1 TURN ON TRACE SWITCH 1 00780000 * 1 TRACEOFF 1 36 1 TURN OFF TRACE SWITCH 1 00800000 * 1 DISPLAY 1 40 1 EFFECT DISPLAY OF LISTED ITEMS 1 00820000 * 1 STARTIO 1 44 1 PREPARE FOR I/O OPERATION 1 00840000 * 1 ENDIO 1 48 1 END I/O OPERATION 1 00860000 * 1 1 1 1 00880000 * 1----------------------------------------------------------1 00900000 * 00920000 *INPUT. 00940000 * INPUT CONSISTS OF PARAMETERS PASSED IN THE CALLING SEQUENCES 00960000 * GENERATED BY THE FORTRAN COMPILER 00980000 * 01000000 *OUTPUT. 01020000 * OUTPUT CONSISTS OF DEBUGGING INFORMATION OF VARIOUS KINDS, 01040000 * LISTED ON THE DATA SET SPECIFIED BY THE *UNIT* PARAMETER, OR 01060000 * IN DEFAULT, ON THE SYSGEN-DEFINED *STANDARD OUTPUT* DATA SET. 01080000 * 01100000 *EXTERNAL ROUTINES. 01120000 * THE IHCFIOSH MODULE (FIOCS#) IS USED TO INTERFACE WITH DATA 01140000 * MANAGEMENT. 01160000 * 01180000 * THE IHCFCVTH MODULE (ADCON#) IS USED FOR CONVERSION OF REAL DATA 01186013 * 01192013 *EXITS. 01200000 * NORMAL - RETURN IS TO THE CALLING ROUTINE VIA REGISTER 14 01220000 * ERROR - THERE ARE NO ERROR EXITS 01240000 * 01260000 *TABLES/WORK AREAS. 01280000 * 'DBUFFER' - A 70-BYTE PRE-ASSEMBLED OUTPUT BUFFER, PASSED TO 01300000 * FIOCS FOR OUTPUTTING 01320000 * NOTE. THE CONTENTS OF DBUFFER ARE NOT PASSED TO 01340000 * ----- FIOCS WHILE OBJECT PROGRAM I/O OPERATIONS 01360000 * ARE IN PROGRESS. RATHER, ADDITIONAL WORK- 01380000 * SPACE IS OBTAINED BY MEANS OF A *GETMAIN* 01400000 * MACRO-INSTRUCTION (256 BYTES PER REQUEST), 01420000 * AND SUCCESSIVE LINES ACCUMULATED THEREIN. 01440000 * WHEN THE I/O OPERATION HAS TERMINATED, 01460000 * THEN LINES ARE MOVED BACK THROUGH DBUFFER 01480000 * TO FIOCS, AND THE STORAGE IS RELINQUISHED 01500000 * BY MEANS OF A *FREEMAIN* MACRO-INSTRUCTION. 01520000 * 01540000 *ATTRIBUTES. 01560000 * THIS MODULE IS NOT RE-ENTRANT, BUT IS SERIALLY RE-USABLE. 01580000 * 01600000 *NOTES. 01620000 * CALLING SEQUENCES TO DEBUG# ARE LOGICALLY SIMILAR TO THOSE TO 01640000 * IHCFCOMH. 01660000 * 01680000 * IN REFERENCE TO CALLING SEQUENCES 01684013 * IF TAG=0, ADDRESS IS THAT OF THE ITEM 01688013 * IF TAG NOT =0, ADDRESS IS A POINTER TO THE THE ADDRESS OF THE ITEM 01692013 * 01696013 *********************************************************************** 01700000 SPACE 2 01720000 * REGISTER DEFINITIONS 01740000 SPACE 01760000 LOCCALL EQU 1 01780000 COUNTER EQU 2 01800000 ADDRESS EQU 3 01840000 POINTER EQU 4 01880000 SIZE EQU 4 01900000 BRANCH EQU 5 01920000 CHAR EQU 5 01940000 ALTERN EQU 6 01960000 TABLEXR EQU 6 01980000 MULT1 EQU 6 02020000 MULT2 EQU 7 02040000 TEMP EQU 7 02060000 TEMP1 EQU 8 02080000 REM EQU 8 02120000 QUOT EQU 9 02140000 INDEX EQU 9 9036 02160013 LOCN EQU 9 9036 02180013 REM1 EQU 10 02200000 LOCRET EQU 10 9036 02210013 DATALOC EQU 11 02220000 BASE EQU 11 02240000 LENGTH EQU 12 02260000 CALLER EQU 12 02280000 SAVREG EQU 13 2082 02310014 R EQU 14 02340000 L EQU 15 02360000 SPACE 2 02380000 EJECT 02460000 DEBUG# EQU * 02480000 SPACE 02500000 USING *,L 02520000 SPACE 2 02540000 * TRANSFER VECTOR 02560000 SPACE 02580000 B TRACE 02600000 B SUBTREN 02620000 B SUBTREX 02640000 B UNIT 02660000 B INITSCLR 02680000 B INITARIT 02700000 B INITARAY 02720000 B SUBCHK 02740000 B TRACEON 02760000 B TRACEOFF 02780000 B DISPLAY 02800000 B STARTIO 02820000 B ENDIO 02840000 EJECT 02860000 * 1. TRACE 02880000 * CALL ARGS -- 02900000 * DC F'LABEL' 02920000 SPACE 02940000 TRACE TM TRACFLAG,X'F0' IF TRACEFLAG IS ON CONTINUE. 02960018 BZ 4(0,R) IF OFF RETURN. 02980018 STM 0,13,SAVE 03000000 LA POINTER,DBUFFER+7 03020000 MVC DBUFFER+1(6),=CL6'TRACE ' TRACEFLAG OFF MESSAGE. 03040018 L COUNTER,0(0,R) 4 BYTE LABEL. 03060018 BAL LOCCALL,OUTINT CONVERT LABEL TO EBCDIC. 03080018 LA R,4(0,R) RETURN POINT. 03100018 B OUTBUFFR OUTPUT MESSAGE. 03120018 SPACE 5 03140000 * 2. SUBTRACE ENTRY 03160000 * CALL ARGS -- 03180000 * C(LOCN) -- R13 -- = ADR(SUBPROGRAM SAVE AREA) 03200000 * WORD 2 OF SUBPROGRAM SAVE AREA IS ADR(SAVE AREA) 03220000 * WORD 5 OF SAVE AREA IS ADR(L1) 03240000 * BYTE 5 OF L1 IS CHAR COUNT (6) 03260000 * BYTES 6 TO 11 OF L1 IS 'NAME ' 03280000 SPACE 03300000 SUBTREN STM 0,13,SAVE 03320000 LA POINTER,DBUFFER+16 03340000 MVC DBUFFER+1(9),=CL9'SUBTRACE ' 4 WORDS OF DBUFFER CONTAIN 03360018 L LOCN,4(0,SAVREG) 'SUBTRACE' AND THE 6 BYTE 2082 03380018 L LOCN,16(0,LOCN) NAME OF THE PROGRAM. 03400018 MVC DBUFFER+10(6),5(LOCN) 03420018 B OUTBUFFR OUTPUT MESSAGE. 03440018 SPACE 5 03460000 * 3. SUBTRACE RETURN 03480000 SPACE 03500000 SUBTREX STM 0,13,SAVE 03520000 LA POINTER,DBUFFER+18 18 BYTE MESSAGE. 03540018 MVC DBUFFER+1(17),=CL17'SUBTRACE *RETURN*' 03560000 B OUTBUFFR OUTPUT MESSAGE. 03580018 SPACE 5 03600000 * 4. UNIT 03620000 * CALL ARGS -- 03640000 * DC F'UNIT' 03660000 SPACE 03680000 UNIT MVC DSRN(4),0(R) UNIT NUMBER ARGUMENT. 03700018 B 4(0,R) RETURN. 03720018 SPACE 5 03740000 * 5. INITIALIZE SCALAR 03760000 * CALL ARGS -- 03780000 * DC CL8'NAME' 03800000 * DC XL1'L',XL0.4'T',XL0.4'X',XL0.4'B',XL1.4'D' 03820000 SPACE 03840000 INITSCLR MVZ DATATYPE(1),9(R) SAVE DATA TYPE. 03850018 MVN LADATLOC+1(1),9(R) INDEX BASE AND 03860018 MVC LADATLOC+2(2),10(R) DISPLACEMENT. 03870018 STM 0,13,SAVE PLACE ADDR OF 03880018 EX 0,LADATLOC SCALAR IN DATALOC. 03890018 SR LENGTH,LENGTH 9036 03900018 IC LENGTH,8(0,R) LENGTH OF SCALAR. 9036 03910018 BAL LOCCALL,OUTNAME PLACE SCALAR NAME IN DBUFFER. 03920018 LA R,12(0,R) RETURN ADDRESS. 03930018 B OUTITEM 04000000 SPACE 5 04020000 * 6. INITIALIZE ARRAY ITEM 04040000 * CALL ARGS -- 04060000 * DC CL8'NAME ' 04080000 * DC XL1'L',XL0.4'T',XL0.4'X',XL0.4'B',XL1.4'D' 04100000 * DC XL1'TAG',AL3(ADDRESS) 04120000 * 04125013 * THIS ROUTINE PUTS THE ADDRESS OF THE ARRAY ITEM IN DATALOC, THE 04130013 * SUBSCRIPT NUMBER IN COUNTER, AND THE TYPE OF DATA IN DATA TYPE. 04135013 SPACE 04140000 INITARIT MVZ DATATYPE(1),9(R) SAVE DATA TYPE. 04160018 MVN LADATLOC+1(1),9(R) INDEX BASE AND 04180018 MVC LADATLOC+2(2),10(R) DISPLACEMENT. 04200018 STM 0,13,SAVE 04220000 EX 0,LADATLOC 04223016 SR LENGTH,LENGTH 9036 04226013 IC LENGTH,8(0,R) LENGTH OF ARRAY ELEMENT. 9036 04236018 BAL LOCCALL,OUTNAME WRITE NAME OF ARRAY. 04246018 MVI 0(POINTER),C'(' LEFT PAREN OF SUBSCRIPT. 04256018 LA POINTER,1(0,POINTER) DBUFFER POINTER. 04266018 LR QUOT,DATALOC ELEMENT LOCATION. 04276018 L ADDRESS,12(0,R) TAG AND ADDRESS. 04286018 CLI 12(R),X'00' IF TAG NOT EQUAL TO ZERO 04296018 BE *+8 ADDR IS POINTER TO LOCATION OF 04306018 L ADDRESS,0(0,ADDRESS) FIRST ARRAY ELEMENT. 04316018 SR QUOT,ADDRESS 04420000 SR REM,REM 04440000 SR ADDRESS,ADDRESS 04460000 IC ADDRESS,8(0,R) LENGTH 04480018 DR REM,ADDRESS ELEM NUMBER=((ELEM LOC - FIRST 04500018 LA COUNTER,1(0,QUOT) ARRAY LOC)/ELEM SIZE) + 1. 04520018 BAL LOCCALL,OUTINT CONVERT ELEM NUM TO EBCDIC. 04540018 MVI 0(POINTER),C')' RIGHT PAREN OF SUBSCRIPT. 04560018 LA POINTER,1(0,POINTER) 04580018 LA R,16(0,R) RETURN POINT. 04600018 B OUTITEM ARRAY ELEMENT IN DBUFFER. 04620018 SPACE 5 04640000 * 7. INITIALIZE ARRAY (SHORT LIST) 04660000 * CALL ARGS 04680000 * DC CL8'NAME ' 04700000 * DC XL1'00',AL3(ADDRESS) 04720000 * DC XL1'L',XL0.4'T',XL2.4'00000' 04740000 * DC AL4(ELEMENTS) 04760000 * 04762013 * THIS ROUTINE SETS UP PARAMETERS FOR INITARIT. IT CONTROLS AN 04764013 * ENTIRE ARRAY RATHER THAN ONE ITEM. THE REGISTERS WILL CONTAIN 04766013 * THE FOLLOWING INDEX=ADDRESS OF BYTE AFTER AREA TO BE CONSIDERED, 04768013 * LENGTH=LENGTH OF ARRAY ITEM, 04770013 * BASE=ADDRESS OF CURRENT ITEM 04772013 SPACE 04780000 INITARAY CLI IOFLAG,X'00' 04800000 BNE INITAR4 04820000 STM INDEX,R,SAVE+14*4 9036 04840013 MVC INARNAME(8),0(R) NAME OF ARRAY. 04850018 MVC INARTAGS(1),12(R) LENGTH OF ARRAY. 04860018 MVZ INARTAGS+1(1),13(R) TYPE CODE. 04870018 SR REM1,REM1 9036 04910013 IC REM1,12(R) LENGTH OF ONE ITEM 9036 04920013 LR LENGTH,REM1 9036 04930013 L BASE,16(R) 9036 04940013 L BASE,0(BASE) NUMBER OF ELEMENTS 9036 04950013 MR REM1,REM1 LENGTH OF ARRAY 9036 04960013 LR INDEX,BASE 9036 04970013 L BASE,8(R) ADDRESS OF BEGINNING OF ARRAY 9036 04980013 AR INDEX,BASE ADDR OF BYTE AFTER ARRAY IN CORE 9036 04990013 ST BASE,INARADR 05080000 CNOP 0,4 05100000 INARLOOP BAL R,INITARIT 05120000 INARNAME DS 8C 6 BYTE NAME OF ARRAY. 05140018 INARTAGS DC XL4'0000B000' LENGTH AND TYPE. 05160018 INARADR DS A END ADDRESS OF ARRAY. 05180018 AR BASE,LENGTH ADDRESS OF END OF ITEM. 05200018 CR BASE,INDEX 05220018 BL INARLOOP CHECK FOR END OF ARRAY. 05240018 LM INDEX,R,SAVE+14*4 9036 05260018 B 20(0,R) RETURN. 05280018 INITAR4 STM 0,14,SAVE 05300018 MVI ARRAYSW,X'FF' SHOW PROCESSING AN ARRAY 49520 05310021 MVI DBUFFER+1,X'FF' HEX 'FF' FOLLOWED BY ADDRESS OF 05320018 MVC DBUFFER+2(3),SAVE+14*4+1 ARGUMENT LIST. 05340018 LA POINTER,DBUFFER+5 05360018 LA R,20(0,R) RETURN ADDRESS. 05380018 B OUTBUFFR 05400000 SPACE 5 05420000 * 8. SUBSCRIPT CHECK 05440000 * CALL ARGS -- 05460000 * DC CL8'NAME ' 05480000 * DC XL1'L',XL0.4'T',XL0.4'X',XL0.4'B',XL1.4'D' 05500000 * DC XL1'TAG',AL3(ADDRESS) 05520000 * DC AL4(ELEMENTS) 05540000 SPACE 05560000 SUBCHK MVN LADATLOC+1(1),9(R) 05580018 MVC LADATLOC+2(2),10(R) 05600018 STM 0,13,SAVE 05620000 EX 0,LADATLOC ADDR OF ARRAY IN DATALOC. 05640018 L ADDRESS,12(0,R) ADDR OF FIRST ELEMENT. 05660018 CLI 12(R),X'00' CHECK FOR VALID ADDRESS. 05680018 BE *+8 05700000 L ADDRESS,0(0,ADDRESS) ELEMENT. 05720018 L SIZE,16(0,R) POINTER TO NUMBER OF ELEMENTS. 05740018 L SIZE+1,0(0,SIZE) NUMBER OF ELEMENTS. 05760018 SR MULT1,MULT1 05780018 IC MULT1,8(0,R) LENGTH OF EACH ELEMENT. 05800018 MR SIZE,MULT1 LENGTH OF ARRAY. 05820018 SR DATALOC,ADDRESS 05840018 CLR DATALOC,SIZE+1 IS ARRAY ELEMENT LESS THAN OR 05860018 BNL SUBCHKOT EQUAL TO MAX ARRAY LOCATION. 05880018 LM 0,13,SAVE 05900018 B 20(0,R) RETURN. 05920018 SUBCHKOT MVC DBUFFER+1(7),=CL7'SUBCHK ' OUTSIDE BOUNDARY MESSAGE. 05940018 LA POINTER,DBUFFER+8 05960000 BAL LOCCALL,OUTNAME+4 05980000 MVI 0(POINTER),C'(' LEFT PAREN OF SUBSCRIPT. 06000018 LA POINTER,1(0,POINTER) 06020000 SR REM1,REM1 06040000 SR COUNTER,COUNTER 06060000 IC COUNTER,8(0,R) LENGTH. 06080018 DR REM1,COUNTER 06100000 LA COUNTER,1(0,DATALOC) 06120000 BAL LOCCALL,OUTINT PLACE IN DBUFFER. 06140018 MVI 0(POINTER),C')' RIGHT PAREN OF SUBSCRIPT. 06160018 LA POINTER,1(0,POINTER) 06180018 LA R,20(0,R) RETURN POINT. 06200018 B OUTBUFFR 06220000 SPACE 5 06240000 * 9. TRACE ON 06260000 SPACE 06280000 TRACEON OI TRACFLAG,X'F0' TURN TRACEFLAG ON. 06300018 BR R EXIT. 06320018 SPACE 5 06340000 * 10. TRACE OFF 06360000 SPACE 06380000 TRACEOFF NI TRACFLAG,X'0F' TURN TRACEFLAG OFF. 06400018 BR R EXIT. 06420018 SPACE 5 06440000 * 11. DISPLAY 06460000 * CALL ARGS -- 06480000 * DC AL4(NAMELIST) 06500000 * DC AL4(NAMELIST OUTPUT ROUTINE) 06520000 SPACE 06540000 DISPLAY STM 0,14,SAVE 06560000 CLI IOFLAG,X'00' IF I/O FLAG IS ON PLACE 06580018 BE DISPLAY2 MESSAGE IN DBUFFER. 06600018 MVC DBUFFER+1(26),=CL26'DISPLAY DURING I/O SKIPPED' 06620018 LA POINTER,DBUFFER+27 NEXT AVAILABLE BYTE. 06640018 LA R,8(0,R) RETURN POINT. 06660018 B OUTBUFFR OUTPUT MESSAGE. 06680018 DISPLAY2 SR COUNTER,COUNTER TEST DSRN 06700018 A COUNTER,DSRN FOR ZERO. 06720018 BNZ DISPLAY1 IF ZERO OBTAIN SYSOUT 06740018 L ADDRESS,=V(IHCUATBL) UNIT NUMBER FROM 4TH 06760018 IC COUNTER,6(0,ADDRESS) BYTE OF UNIT TABLE. 06780018 DISPLAY1 ST COUNTER,NLUNIT 06800018 MVC NLNAME(4),0(R) ADDRESS OF NAMELIST. 06820018 LR COUNTER,L 06840018 L L,4(0,R) ADDR OF NAMELIST OUTPUT ROUTINE. 06860018 L L,0(0,L) 06880000 CNOP 0,4 06900000 BAL R,0(0,L) NAMELIST OUTPUT ROUTINE. 06920018 NLUNIT DS F UNIT NUMBER. 06940018 NLNAME DS A ADDRESS OF NAMELIST. 06960018 LR L,COUNTER 06980000 LM 0,14,SAVE 07000000 B 8(0,R) 07020018 SPACE 5 07040000 * 12. START I/O LIST 07060000 SPACE 07080000 STARTIO MVI BYTECNT+3,X'FB' 28107 07100020 MVI IOFLAG,X'80' 07120000 MVC CURBYTLC(4),=A(SAVESTR1) 28107 07140020 BR R 07160000 SPACE 5 07180000 * 13. END I/O LIST 07200000 SPACE 07220000 ENDIO MVC TEMPFLAG(1),IOFLAG SAVE IOFLAG. 07240018 MVI IOFLAG,X'00' ENABLE FUTURE DEBUG CALLS. 07260018 TM TEMPFLAG,X'40' IF NO INFORMATION IS SAVED 07280018 BCR 8,R RETURN. 07300018 STM 0,14,ENDSAVE 07320000 LR TEMP1,L TEMPORARY BASE REGISTER. 07340018 DROP L 07360000 USING DEBUG#,TEMP1 07380000 OI TRACFLAG,X'08' INDICATE TO WRITE SECT. THAT REG 07386016 * ISTERS ARE SAVED DIFFERENTLY 07392016 CLI SAVESTR1,X'07' 28107 07402020 BE ENDJOB 07420000 TM TEMPFLAG,X'20' 07440000 BO ENDIO10 07460000 L ADDRESS,CURBYTLC LOCATION OF FIRST MAIN BLOCK. 07480018 MVI 0(ADDRESS),X'07' 07500000 ENDIO10 MVC CURBYTLC+1(3),SAVESTRT+1 07520000 LA 13,CALLSAVE 07540000 ENDIO1 LA POINTER,DBUFFER+1 FIRST OUTPUT BYTE. 07560018 ENDIO2 BAL CALLER,FREECHAR EXTRACTS ONE CHAR AT A TIME. 07580018 CH CHAR,=XL2'00FF' 07600018 BE ENDIO4 TEST FOR A FULL ARRAY OUTPUT. 07620018 CH CHAR,=XL2'0015' 07640018 BE ENDIO3 TEST FOR END OF A LINE. 07660018 STC CHAR,0(0,POINTER) FROM FREECHAR TO DBUFFER. 07680018 LA POINTER,1(0,POINTER) NEXT AVAILABLE BYTE. 07700018 B ENDIO2 LOOP. 07720018 ENDIO3 BAL CALLER,OUTPUT WRITE OUT LINE. 07740018 B ENDIO1 RESET POINTER. 07760018 ENDIO4 EQU * 07780021 MVC DBUFFER+5(3),0(TABLEXR) MOVE IN 3 BYTE ARRAY ADDR 49520 07800021 LA TABLEXR,3(TABLEXR) UPDATE PTR IN GETMNED AREA 49520 07820021 ST TABLEXR,CURBYTLC AND SAVE IT 49520 07840021 LA COUNTER,3(COUNTER) UPDTE NUMBER OF BYTES USED 49520 07860021 ST COUNTER,BYTECNT IN GETMND AREA AND SAVE IT 49520 07880021 L ADDRESS,DBUFFER+4 ADDRESS OF ARRAY. 07900018 MVC ENDIO5(20),0(ADDRESS) MOVE FULL ARRAY. 07920018 LR L,TEMP1 07940000 CNOP 0,4 07960000 BAL R,24(0,L) ENTRYPT TO INITIALIZE ARRAY. 07980018 ENDIO5 DS 20C 5 WORD PARAMETER LIST. 08000018 B ENDIO1 END OF I/O FOR THIS ARRAY. 08020018 ENDJOB TM TEMPFLAG,X'20' 08040000 BZ ENDIO7 08060000 MVC DBUFFER+1(25),=CL25'SOME DEBUG OUTPUT MISSING' 08080000 LA POINTER,DBUFFER+26 08100000 BAL CALLER,OUTPUT NO CORE AVAILABLE MESSAGE. 08110018 ENDIO7 LR L,TEMP1 L BECOMES BASE REGISTER. 08120018 NI TRACFLAG,X'F7' TURN SWITCH OFF 08150016 DROP TEMP1 08160000 USING DEBUG#,L 08180000 LM 0,14,ENDSAVE 08200000 BR R RETURN. 08220018 EJECT 08240000 * THIS SECTION PUTS ONE DATA ITEM IN THE DEBUG BUFFER 08260000 * R(DATALOC) = ADDRESS OF DATA ITEM 08280000 SPACE 08300000 OUTITEM MVC 0(3,POINTER),=CL3' = ' 08320000 LA POINTER,3(0,POINTER) 08340000 MVC DECFIELD(4),0(DATALOC) MOVE TO DOUBLE WORD AREA 4648 08350013 SR BRANCH,BRANCH 08360000 IC BRANCH,DATATYPE OBTAIN CODE FROM 08380018 SRL BRANCH,2 4 HIGH ORDER BITS. 08400018 SR COUNTER,COUNTER 08420018 LA ALTERN,X'F8' THESE BITS ARE IN TURN 08440018 NR ALTERN,BRANCH USED FOR A BRANCH ON TYPE. 08460018 SRL ALTERN,1 08520000 B *(ALTERN) 08540000 B OUTLOG LOGICAL DATA. 08560018 B OUTFIXED INTEGER DATA. 08580018 B OUTREAL REAL DATA. 08600018 MVI 0(POINTER),C'(' COMPLEX OR LITERAL DATA. 08620018 LA POINTER,1(0,POINTER) 08640000 SRL LENGTH,1 COMPLEX ARRAY ITEM DIVIDED IN HALF 9036 08650013 BAL LOCRET,OUTFLOAT FIRST CALL TO OUTFLOAT. 9036 08660018 LA 2,0(DATALOC,LENGTH) ADDR OF IMAGINARY COEFFICIENT 9036 08670013 MVI 0(POINTER),C',' SEPARATE REAL FROM COMPLEX. 08680018 LA POINTER,1(0,POINTER) 08700000 BAL LOCRET,IMAGFLT ADDR OF DATA ALREADY SET UP9036 08720013 SLL LENGTH,1 RESTORE LENGTH 9036 08740013 MVI 0(POINTER),C')' 08780000 OUTTOBFR LA POINTER,1(0,POINTER) 08800000 B OUTBUFFR 08820000 OUTLOG MVI 0(POINTER),C'F' AN 'F' INDICATES A ZERO VALUE. 08830018 EX 0,LOADITEM-8(BRANCH) 9036 08850013 LTR COUNTER,COUNTER 08860000 BZ OUTTOBFR 08880000 MVI 0(POINTER),C'T' 'T' INDICATES A NON-ZERO VALUE. 08900018 B OUTTOBFR 08920000 OUTFIXED EX 0,LOADITEM-8(BRANCH) 9036 08930013 BAL LOCCALL,OUTINT 9036 08940013 B OUTBUFFR 08960000 OUTREAL BAL LOCRET,OUTFLOAT 9036 08980013 B OUTBUFFR 09000000 LOADITEM IC COUNTER,DECFIELD 4648 09020013 L COUNTER,DECFIELD 4648 09040013 LH COUNTER,DECFIELD 4648 09060013 L COUNTER,DECFIELD 4648 09080013 EJECT 09220000 * OUTPUT VARIABLE'S NAME POINTED TO BY R 09240000 * CALL -- 09260000 * BAL LOCCALL,OUTNAME 09280000 SPACE 09300000 OUTNAME LA POINTER,DBUFFER+1 BEGINNING OF OUTPUT AREA. 09320018 LR ADDRESS,R ADDRESS OF OUTPUT VARIABLE. 09340018 MVI 6(ADDRESS),C' ' MAXIMUM OF 6 CHARACTERS. 09360018 OUTNAME1 MVC 0(1,POINTER),0(ADDRESS) TRANSFER ONE CHAR AT A TIME. 09380018 LA POINTER,1(0,POINTER) POINT TO NEXT SPACE. 09400018 LA ADDRESS,1(0,ADDRESS) POINT TO NEXT CHARACTER. 09420018 CLI 0(ADDRESS),C' ' ROUTINE EXITS WHEN A BLANK 09440018 BNE OUTNAME1 CHARACTER IS ENCOUNTERED. 09460018 BR LOCCALL RETURN. 09480018 EJECT 09500000 * ROUTINE TO CONVERT AN INTEGER TO EBCDIC AND MOVE IT 09520000 * TO THE DEBUG BUFFER WITH LEADING ZEROS OMITTED 09540000 * A MINUS SIGN IS PREFIXED FOR NEGATIVE VALUES 09560000 * CALL -- 09580000 * BAL LOCCALL,OUTINT 09600000 * C(R2) -- COUNTER = INTEGER TO BE OUTPUT 09620000 SPACE 09640000 OUTINT LTR COUNTER,COUNTER IF THE INTEGER IS A ZERO 09660018 BNZ OUTINT1 PLACE A C'0' 09680018 MVI 0(POINTER),C'0' IN DBUFFER. 09700018 LA POINTER,1(0,POINTER) 09720018 BR LOCCALL RETURN TO TRACE. 09740018 OUTINT1 BP OUTINT2 POSITIVE INTEGER. 09760018 MVI 0(POINTER),C'-' NEGATIVE INTEGER. 09780018 LA POINTER,1(0,POINTER) CONVERT VALUE TO EBCIDIC 09800018 OUTINT2 CVD COUNTER,DECFIELD WITH LEADING ZEROS 09820018 UNPK DECFIELD(16),DECFIELD(8) SUPPRESSED. 09840018 OI DECFIELD+15,C'0' 09860000 LA ADDRESS,DECFIELD 09880000 LA COUNTER,16 09900000 OUTINT3 CLI 0(ADDRESS),C'0' EXIT FROM LOOP AFTER THE FIRST 09920018 BNE OUTINT4 ZERO IS ENCOUNTERED. 09940018 LA ADDRESS,1(0,ADDRESS) NEXT BYTE. 09960018 BCT COUNTER,OUTINT3 LOOP. 09980018 OUTINT4 EX COUNTER,OUTINT5 PLACE IN DBUFFER. 10000018 LA POINTER,0(COUNTER,POINTER) 10020018 BR LOCCALL RETURN. 10040018 OUTINT5 MVC 0(0,POINTER),0(ADDRESS) 10060000 EJECT 10080000 * ROUTINE TO PLACE A FLOATING NUMBER IN THE DEBUG BUFFER. IHCFCVTH 10160013 * IS USED TO CONVERT. 10240013 * 10320013 OUTFLOAT LR TEMP,R 9036 10400013 LR TEMP1,L 9036 10480013 LR 2,DATALOC ADDR OF REAL DATA 9036 10560013 IMAGFLT LR 3,POINTER ADDR OF OUTPUT BUFFER POSITION 9036 10640013 L 1,=V(ADCON#) CONVERSION ROUTINE ENTRY 9036 10720018 L 1,60(1) 9036 10800013 B *(LENGTH) TO SET UP CVTH PARAMETERS 9036 10880013 B SHRTREAL 9036 10960013 LONGREAL BALR 0,1 TO FCVGO 9036 11040013 DC AL1(8) LENGTH OF ITEM 9036 11120013 DC AL1(23) 23 PLACES IN BUFFER FOR D TYPE 9036 11200013 DC AL1(16) DECIMAL PLACES 9036 11280013 DC AL1(0) SCALE FACTOR 9036 11360013 LR R,TEMP 9036 11440013 LR L,TEMP1 9036 11520013 LA POINTER,23(POINTER) 9036 11600013 BR LOCRET RETURN 9036 11680013 SHRTREAL BALR 0,1 TO FCVGO 9036 11760013 DC AL1(4) LENGTH OF ITEM 9036 11840013 DC AL1(14) S0.1234567ES12=14 PLACES 9036 11920013 DC AL1(7) DECIMAL PLACES 9036 12000013 DC AL1(0) SCALE FACTOR 9036 12080013 LR R,TEMP 9036 12160013 LR L,TEMP1 9036 12240013 LA POINTER,14(POINTER) MOVE BUFFER POINTER AFTER NUMBER9036 12320013 BR LOCRET RETURN 9036 12400013 EJECT 12560000 * THIS SECTION OUTPUTS THE DEBUG BUFFER 12580000 SPACE 12600000 OUTBUFFR LA 13,CALLSAVE SAVE RETURN POINT. 12620018 LR TEMP,R SAVE BASE DISPLACEMENT. 12640018 LR TEMP1,L 12660000 DROP L 12680000 USING DEBUG#,TEMP1 NEW BASE REGISTER. 12690018 CLI IOFLAG,X'00' IS I/O FLAG SET? 12700018 BNE QUEUED IF YES CONTINUE. 12710018 L L,=V(IBCOM#) GET IBCOM ADDRESS 12742016 CLI FRTNUSR(L),X'FF' I/O DURING USER FIXUP ? 12744016 BE DOMORE1 NO OK GO ON 12746016 L R,ER904(0,L) YES, GET ADDR OF RTN IN IBCOM 12748016 LM 0,13,SAVE TO OUTPUT MESSAGE 904 AND GO 12750016 BR R THERE(NO RETURN) 12752016 DOMORE1 EQU * 12754016 BAL CALLER,OUTPUT 12760000 EXIT LR R,TEMP RESTORE RETURN POINT. 12780018 LR L,TEMP1 RESTORE BASE REGISTER. 12800018 DROP TEMP1 12820000 USING DEBUG#,L 12840000 LM 0,13,SAVE 12860000 DROP L 12880000 USING DEBUG#,TEMP1 12900000 BR R RETURN. 12920018 QUEUED OI IOFLAG,X'40' INDICATE DEBUG OUTPUT OCCURRED. 12940018 LA ADDRESS,DBUFFER+1 12980000 QUEUED1 TM IOFLAG,X'20' 13000000 BO EXIT CALL ALLOCHAR FOR EACH 13020018 IC CHAR,0(0,ADDRESS) CHARACTER IN DBUFFER. 13040018 BAL CALLER,ALLOCHAR 13060000 LA ADDRESS,1(0,ADDRESS) 13080000 CR ADDRESS,POINTER INDICATE END OF A LINE 13100018 BL QUEUED1 TO ALLOCHAR 13120018 LA CHAR,X'15' WITH AN X'15'. 13140018 BAL CALLER,ALLOCHAR 13160000 B EXIT 13180000 EJECT 13200000 * ONE CHAR TO SAVE AREA FROM R(CHAR) 13220000 SPACE 13240000 ALLOCHAR L COUNTER,BYTECNT 13260000 L TABLEXR,CURBYTLC 13280000 CLI BYTECNT+3,X'FB' 28107 13300020 BNE ALLOC3A 49520 13310021 GETCORE EQU * 49520 13320021 GETMAIN EC,LV=256,A=CURBYTLC 13340000 LTR 15,15 13360000 BZ ALLOC2 13380000 MVI 0(TABLEXR),X'07' 13400000 OI IOFLAG,X'20' 13420000 BR CALLER 13440000 ALLOC2 MVI 0(TABLEXR),X'37' 13460000 MVC 1(4,TABLEXR),CURBYTLC 28107 13480020 SR COUNTER,COUNTER 13500000 L TABLEXR,CURBYTLC 13520000 ALLOC3 STC CHAR,0(0,TABLEXR) 13540000 LA COUNTER,1(0,COUNTER) 13560000 LA TABLEXR,1(0,TABLEXR) 13580000 ST COUNTER,BYTECNT 13600000 ST TABLEXR,CURBYTLC 13620000 BR CALLER 13640000 ALLOC3A EQU * 49520 13642021 CLI ARRAYSW,X'FF' ARE WE PROCESNG ARRAY ADDR 49520 13644021 BNE ALLOC3 NO, BRANCH 49520 13646021 CLI BYTECNT+3,X'F6' FULL ARRAY ADDR WILL FIT? 49520 13648021 BL ALLOC3 YES,CONTINUE 49520 13650021 MVI ARRAYSW,X'00' TURN OFF SWITCH 49520 13652021 B GETCORE BRANCH TO DO GETMAIN 49520 13654021 EJECT 13660000 * ONE CHAR TO R(CHAR) FROM SAVE AREA 13680000 SPACE 13700000 FREECHAR L TABLEXR,CURBYTLC 13720000 CLI 0(TABLEXR),X'37' 13740000 BE FREECHR1 13760000 FREECHR9 CLI 0(TABLEXR),X'07' 13780000 BNE FREECHR4 13800000 OI TEMPFLAG,X'01' 13820000 FREECHR1 MVC CURBYTLC(4),1(TABLEXR) 28107 13840020 FREEMAIN E,LV=256,A=SAVESTRT 13860000 TM TEMPFLAG,X'01' 13880000 BO ENDJOB 13900000 L TABLEXR,CURBYTLC 13920000 ST TABLEXR,SAVESTRT 13940000 B FREECHR9 13960000 FREECHR4 SR CHAR,CHAR 13980000 IC CHAR,0(0,TABLEXR) 14000000 LA TABLEXR,1(0,TABLEXR) 14020000 ST TABLEXR,CURBYTLC 14040000 BR CALLER 14060000 EJECT 14080000 * LINKAGE TO FIOCS# 14100000 SPACE 2 14120000 OUTPUT CLI DSRN+3,X'00' 14140000 BNE OUTPUT1 IF DSRN NOT 0 BRANCH 14150018 L ADDRESS,=V(IHCUATBL) IF DSRN IS ZERO OBTAIN SYSOUT 14160018 MVC DSRN+3(1),6(ADDRESS) NUMBER FROM IHCUATBL + 6 14170018 OUTPUT1 EQU * 14202016 L B,=V(IBCOM#) GET IBCOM ADDRESS 21187 14204018 STM 14,15,FRTNUSR(B) STORE IN IBCOM AREA 21187 14206018 TM TRACFLAG,X'08' FROM ENDIO SECTION? 14210016 BO MOVEND YES , BRANCH 14212016 MVC FRTNUSR+8(8,B),SAVE NO, MOVE REGS 0-1 TO IBCOM 21187 14214018 B MOVEF GO ON 14216016 MOVEND MVC FRTNUSR+8(8,B),ENDSAVE MOVE REGS 0-1 TO IBCOM AREA21187 14218018 MVC FRTNUSR(4,B),ENDSAVE+14*4 MOVE REG 14 TO IBCOM AREA21187 14220018 MOVEF EQU * 14222016 LA 2,DSRN SET DSRN POINTER FOR FIOCS 14226016 L 1,=V(FIOCS#) 14240000 BALR 0,1 14250018 DC XL2'00FF' 14260018 B OUTPUT3 14290016 S POINTER,=A(DBUFFER) NUMBER OF BYTES USED. 14300018 CR POINTER,3 14320000 BNH OUTPUT2 14340000 LR POINTER,3 14360000 OUTPUT2 BCTR POINTER,0 14380000 EX POINTER,OUTPUTA MOVE CONTENTS OF DBUFFER 14400018 LA 2,1(4) TO FIOCS BUFFER 31929 14420020 L 1,=V(FIOCS#) 14440000 BALR 0,1 SECOND CALL TO FI0CS. 14460018 DC XL2'0200' 14480000 NOP 0 14485016 OUTPUT3 L L,=V(IBCOM#) 14490016 MVI FRTNUSR(L),X'FF' RESET I/O ENDED SWITCH IN IBCOM 14495016 BR CALLER RETURN 14505018 OUTPUTA MVC 0(0,2),DBUFFER 14520000 EJECT 14540000 * DATA 14560000 SPACE 2 14565016 FRTNUSR EQU X'7C' OFFSET IN IBCOM TO REG. 14 (SAVD 14570016 ER904 EQU X'6C' OFFSET IN IBCOM TO MSG 904 RTN 14575016 B EQU 1 21187 14577018 SPACE 2 14580000 * 8 BYTE BOUNDARY 14600000 SPACE 14620000 DS 0D 14640000 DECFIELD DS 3D 15000000 DBUFFER DC C' ' 15060000 DS 69C 15080000 SPACE 2 15100000 * 4 BYTE BOUNDARY 15120000 SPACE 15140000 DS 0F 15160000 DSRN DC F'0' 15180000 SAVE DS 20F 9036 15200013 CALLSAVE DS 18F 15220000 ENDSAVE DS 15F 15240000 CURBYTLC DS 1F 15260000 TRACFLAG DC XL1'00' 28107 15264020 IOFLAG DC XL1'00' 28107 15268020 TEMPFLAG DC XL1'00' 28107 15272020 SAVESTR1 DS XL1 28107 15276020 SAVESTRT DS 1F 15280000 BYTECNT DC F'0' 15300000 SPACE 2 15320000 * 2 BYTE BOUNDARY 15340000 SPACE 15360000 LADATLOC LA DATALOC,0 15380000 SPACE 2 15400000 * 1 BYTE BOUNDARY 15420000 SPACE 15440000 DATATYPE DC XL1'00' CODE FORMED IN 4 HIGH ORDER BITS 15482013 ARRAYSW DC X'00' PROCSSNG ARRAY ADDR SWITCH 49520 15483021 *********************************************************************** 15484013 * * CODE * * TYPE * * LENGTH * * 15486013 *********************************************************************** 15488013 * * 2 * LOGICAL * 1 * * 15490013 * * 3 * LOGICAL * 4 * * 15492013 * * 4 * INTEGER * 2 * * 15494013 * * 5 * INTEGER * 4 * * 15496013 * * 6 * REAL * 8 * * 15498013 * * 7 * REAL * 4 * * 15500013 * * 8 * COMPLEX * 8 * * 15502013 * * 9 * COMPLEX * 4 * * 15504013 * * A * LITERAL * - * * 15506013 *********************************************************************** 15508013 SPACE 10 15600000 END 15620000 ./ ADD SSI=21450422,NAME=IHCDIOSE,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 0 20000016 IHCDIOSM 30000016 END 40000016 ./ ADD SSI=01011015,NAME=IHCECOMH,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 1 20000016 IHCIBCOM 30000016 END 40000016 ./ ADD SSI=21450421,NAME=IHCEDIOS,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 1 20000016 IHCDIOSM 30000016 END 40000016 ./ ADD SSI=01011015,NAME=IHCEFIOS,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 1 20000016 IHCFIOSM 30000016 END 40000016 ./ ADD SSI=01013277,NAME=IHCEFNTH,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 1 20000016 IHCARITM 30000016 END 40000016 ./ ADD SSI=01011015,NAME=IHCERRM,SOURCE=0 IHCERRM CSECT 00200016 *C142000 37107 00230020 *A136600,137200,629000 37107 00260020 *A468600-468900,472600-473200 A42666 00280021 *A098300-098600 61491 00290022 * 00300018 * STATUS -- CHANGE LEVEL 6 -- 1 AUGUST 1974 -- RELEASE 21.8 00350022 TITLE ' ERROR MONITOR FOR OBJECT TIME ERROR HANDLING' 00400016 ENTRY ERRMON 00600016 ENTRY IHCERRE 00800016 USING ERRTBL,TB 01000016 USING OPTIONTB,R1 01200016 USING ERRMON,BS 01400016 * 01600016 * REGISTER USAGE 01800016 * 02000016 GRX EQU 2 REGISTER USED FOR FIOCS AND CVT 02200016 GRY EQU 3 REGISTER USED FOR FIOCS AND CVT 02400016 TW EQU 4 ADDRESS OF BUFFER REGISTER 02600016 LN EQU 5 LENGTH OF BUFFER REGISTER 02800016 R1 EQU 6 ADDRESS OF PARAMETER LIST 03000016 W4 EQU 7 03200016 TB EQU 8 ADDRESS OF TABLE ENTRY FOR THE 03400016 * ERROR BEING PROCESSED 03600016 W1 EQU 9 03800016 W2 EQU 10 04000016 W3 EQU 11 04200016 BS EQU 12 BASE REGISTER 04400016 W5 EQU 14 04600016 USING *,15 04800016 ERRMON EQU * 05000016 SAVE (14,12),,ERRMON 05200016 BC 0,0 THE FOURTH BYTE IN THIS NOP SHOULD 05400016 * ALWAYS BE ZERO EXCEPT WHEN FIOCS 05600016 * FINDS AN I/O ERROR OR NO DD FOR THE 05800016 * OBJECT ERROR UNIT. THE BYTE IS THEN 06000016 * SET TO FF AND NO ERROR SUMMARY OCCURS 06200016 B START 06400016 DROP 15 06600016 USING *,15 06800016 IHCERRE L 15,=A(ERRMON) 07000016 TM 19(15),X'FF' ERROR SUMMARY TO BE GIVEN 07200016 BCR 1,14 07400016 USING ERRMON,15 07600016 MVI ENDSW,ON INDICATE ENTRY FOR SUMMARY 07800016 BR 15 08000016 DROP 15 08200016 START EQU * 08400016 LR BS,15 SET UP BASE REGISTER 08600016 LR W1,13 LINK SAVE AREAS TOGETHER 08800016 LA 13,COMMONSV GET OUR SAVE AREA ADDRESS 09000016 ST 13,8(0,W1) 09200016 ST W1,4(0,13) 09400016 LR R1,1 SAVE PARAMETER LIST ADDRESS 09600016 BAL W2,INITFI INITIALIZE FIOCS 09800016 LTR GRX,GRX IS THERE AN AVAILABLE BUFFER 61491 1/2 09830022 BZ COMRET1 NO - EXIT-NO BUFFER TO PRINT 61491 2/2 09860022 MVI 0(GRX),X'40' CLEAR OUT THE BUFFER 09900018 BCTR GRY,0 ADJUST BUFFER LENGTH FOR 10000018 BCTR GRY,0 BLANK MVC 22387 10100018 EX GRY,MOVETOBF 10200018 CLI ENDSW,ON IS THIS CALL FOR A SUMMARY 10600016 BE CLEANTBL YES, BRANCH 10800016 L TB,=V(IHCUOPT) GET ADDRESS OF OPTION TABLE 11000016 L W2,ERNM(0,R1) GET ERROR NUMBER FROM PARAM. LST 11200016 L W2,0(0,W2) 11400016 SR GRX,GRX 11600016 L 15,=V(IBCOM#) 11800016 CHK218 CH W2,CON218 ERROR CONDITION I/O ERROR 12600016 BNE CHKON NO, BRANCH 12800016 MVI FREESW,ON SET INDICATION THAT BUFFER AREA 13000016 * MUST BE FREED LATER 13200016 L GRX,IOERR(0,15) GET I/O ERROR EXIT IF GIVEN 13400016 CHKON EQU * 13600016 CH W2,CON240 IS ENTRY FOR IHC240I 37107 13660020 BE SAVENO YES, BRANCH 37107 13720020 TM ENTRYSW,ON CHECK FOR DUPLICATE ENTRY 13800016 BO DUPENTRY YES,BRANCH 14000016 SAVENO STH W2,ERRORNM SAVE ERROR NUMBER 37107 14200020 MVI ENTRYSW,ON SET ENTRY SWITCH 14400016 SH W2,HLF206 CHECK IF ERROR NUMBER SPECIFIED 14600016 LTR W2,W2 IS WITHIN RANGE OF OPTION 14800016 BNP BADERNO TABLE. I.E. BETWEEN 207 AND N 15000016 C W2,NUMENTR-OPTIONTB(0,TB) WHERE N IS THE FIRST WORD OF 15200016 BH BADERNO OPTION TABLE 15400016 * THIS INSTRUCTION DEPENDS ON FACT THAT THE TABLE SIZE IS 8 15600016 SLL W2,3 INDEX TO TABLE ENTRY FOR THIS NO 15800016 LA TB,0(W2,TB) 16000016 TM NUMERR,X'FF' HAVE 255 ERRORS OCCURRED 16200016 BNO UPD NO, BRANCH 16400016 TM BITS,TW56ER HAVE 256+255 ERRORS OCCURRED 16600016 BO NOUPD YES DO NOT UPDATE COUNT 16800016 OI BITS,TW56ER NO, SET COUNT TO 256 17000016 UPD EQU * 17200016 IC W2,NUMERR GET NUMBER OF ERRORS 17400016 LA W2,1(0,W2) AND UPDATE COUNT BY ONE 17600016 STC W2,NUMERR 17800016 NOUPD EQU * 18000016 LA GRX,0(0,GRX) WAS AN EXIT SPECIFIED. I.E. 18200016 LTR GRX,GRX IF 217 OR 218 WAS THE EXIT GIVEN 18400016 BZ NOSPER NO, BRANCH 18600016 MVI SPER,ON YES, INDICATE SPECIAL EXIT TO 18800016 ST GRX,ENDERR BE TAKEN AND ALSO SAVE THE ADDR. 19000016 B CONTINUE OF THE ADDRES OF THE EXIT 19200016 NOSPER EQU * 19400016 CLI MAXERR,0 ARE ALL ERRORS TO BE ALLOWED 19600016 BE CONTINUE YES, CONTINUE 19800016 CLC MAXERR,NUMERR NO, HAS MAXIMUM NUMBER OF ERRORS 20000016 BH CONTINUE OCCURRED. NO, CONTINUE 20200016 LA 3,CNVRTNM YES, CONVERT CURRENT ERROR 20400016 BAL W5,CNVRT NUMBER AND PLACE IN 900 MESSAGE 20600016 MVC 1(TERMSG,TW),MSGEND WRITE 900 MESSAGE 20800016 BAL W1,WRITE 21000016 B PREXITIB 21200016 CONTINUE EQU * 21400016 LA W2,MESSRTN SET UP RETURN POINT FROM MESSAGE 21600016 MVI PRINTSW,ON WRITING ROUTINE. SET MESS. SW. 21800016 TM BITS,PRNTMSG ALL MESSAGES TO BE PRINTED 22000016 BO PRINTMES YES, GO PRINT MESSAGE 22200016 TM BITS,TW56ER NO, HAVE 256 ERRORS OCCURRED 22400016 BO NOMES YES THEN NO MESSAGE TO BE GIVEN 22600016 CLC MAXMESS,NUMERR HAVE MAXIMUM NUMBER OF MESSAGES 22800016 BNL PRINTMES BEEN PRINTED. NO, PRINT MESS. 23000016 NOMES MVI PRINTSW,OFF YES, SET OFF MESSAGE INDICATOR 23200016 B TRACERTN BRANCH SO THAT NO MESSAGE OR 23400016 * TRACE OCCUR 23600016 MESSRTN TM BITS,PRNTBUF ARE CONTENTS OF BUFFER TO BE 23800016 BZ TSTTRC PRINTED FOR THIS MESSAGE.NO, 24000016 * BRANCH 24200016 L W2,ERNM(0,R1) IS ERROR NUMBER 237 24400016 CLI 3(W2),237 YES BRANCH 24600016 BE SP237 IS THIS ERROR 218(I/O ERROR) 24800016 CLI FREESW,ON NO, BRANCH 25000016 BNE NORMLBUF 25200016 SP237 EQU * 25400016 L W2,IODECB(0,R1) IF I/O ERROR OR WRONG LENGTH 25600016 L W3,12(0,W2) RECORD,GET BUFFER ADDRESS 25800016 L W1,8(0,W2) FROM DECB AND RECORD LENGTH 26000016 USING IHADCB,W1 26200016 LH W4,DCBBLKSI THE DIFFERENCE BETWEEN BLOCKSIZE 26400016 L W2,16(0,W2) AND THE RESIDUAL COUNT IN THE 26600016 SH W4,14(0,W2) IOB. 26800016 B MERGE 27000016 DROP W1 27200016 NORMLBUF L 15,=V(IBCOM#) 27400016 L W3,BUFPTRS(0,15) GET ADDRESS OF BUFFER FROM IBCOM 27600016 LTR W3,W3 (IF ZERO THEN IT IS A PRINT 27800016 BZ TSTTRC BUFFER). STORED BY FIOCS&DIOCS 28000016 L W4,BUFPTRS+4(0,15) GET BUFFER LENGTH FROM IBCOM 28200016 MERGE SH W3,CON4 SET UP FOR TSTZERO ROUTINE 28400016 BAL W2,TSTZERO WRITE BUFFER OUT 28600016 TSTTRC CLI IHC900SW,ON IS THIS ENTRY FOR EXCEEDED COUNT20754 28660017 BE EXCEEDED YES - DONT CHECK ENTRY 20754 28720017 TM BITS,TRACE TRACEBACK REQUESTED WITH MESSAGE 28820017 BZ TRACERTN NO, BRANCH 29000016 BAL W2,TRACEBK YES, GO GIVE TRACEBACK 29200016 TRACERTN EQU * 29400016 L W3,RTCD(0,R1) GET RETURN CODE ADDRESS 29600016 TM USERADDR+3,X'01' USER EXIT REQUESTED? 29800016 BO STNDRD NO, BRANCH 30000016 LA W2,1 YES, SET REURN CODE TO 1(USER 30200016 ST W2,0(0,W3) CAN CHANGE IT DURING EXIT) 30400016 LA 1,4(0,R1) SET UP PARAMETER LIST ADDR 30600016 L 15,USERADDR FOR CALL TO USER AND CALL USER'S 30800016 BALR 14,15 ROUTINE (AS IF IT WERE A FORTRAN 31000016 B PRCMRET 31200016 STNDRD EQU * 31400016 SR W2,W2 IF NO USER EXIT REQUESTED SET 31600016 ST W2,0(0,W3) RETURN CODE TO ZERO 31800016 PRCMRET CLI PRINTSW,ON WERE THE MESSAGE AND TRACE(?) 32000016 BNE COMRET GIVEN. NO, BRANCH 32200016 MVI PRINTSW,OFF YES TURN OFF PRINT SWITCH 32400016 BAL W2,INITFI INITIALIZE FIOCS 32600016 TM 3(W3),X'01' IS STANDARD FIXUP REQUESTED 32800016 BO MESSONE NO, BRANCH 33000016 MVC 1(MESSLN,TW),MESS0 YES, MOVE IN STANDARD FIXUP 33200016 B MSCOM MESSAGE. 33400016 MESSONE MVC 1(MESSLN,TW),MESS1 MOVE IN USER FIXUP MESSAGE 33600016 MSCOM MVC 15(MESSLN2,TW),COMON MOVE MESSAGE TO BUFFER 33800016 BAL W1,WRITE WRITE MESSAGE 34000016 COMRET BAL W2,FRMAIN GO TO FREE BUFFER SPACE IF NECC. 34200016 CLI SPER,ON IS SPECIAL EXIT TO BE TAKEN 34400016 BE SPERXIT YES(217 OF 218) BRANCH 34600016 COMRET1 L 13,4(0,13) NO, GET ADDR OF USER'S SAVEAREA 34800016 COMRET2 EQU * 35000016 MVI ENTRYSW,OFF TURN OFF ENTRY SWITCH 35200016 RETURN (14,12) 35400016 SPERXIT L 15,=V(IBCOM#) 35600016 MVI ENTRYSW,OFF TURN OFF ENTRY SWITCH 35800016 MVI SAVE(15),X'FF' SET IBCOM SWITCH BACJ ON 36000016 SR GRX,GRX SO THAT MESSAGE 904 WILL NOT 36200016 SR GRY,GRY OCCUR ON NEXT I/O. 36400016 STM GRX,GRY,ENDFILE(15) ZERO OUT EXIT ADDRESSES IN IBCOM 36600016 L 14,ENDERR GET EXIT ADDRESS GIVEN 36800016 MVI SPER,OFF TURN OFF SWITCH 37000016 LM 0,13,SAVE+8(15) RESTORE USER'S REGISTERS FROM 37200016 L 14,0(0,14) IBCOM'S SAVEAREA. GET EXIT ADDR. 37400016 BR 14 RETURN TO IT. 37600016 TRACEBK EQU * 37800016 L W1,4(0,13) IN ORDER THAT THE TRACEBACK 38000016 L W3,4(0,W1) WILL START AT ROUTINE FINDING 38200016 ST W3,4(0,13) THE ERROR SET SAVE AREA IN MY 38400016 L 15,=V(IHCTRCH) SAVEAREA. LINK TO THE 38600016 BALR 14,15 TRACEBACK ROUTINE 38800016 ST W1,4(0,13) RESET THE SAVE AREAS TO THEIR 39000016 INITFI MVI PARAMS,X'00' PROPER ORDER. RESET THE 39200016 MVI PARAMS+1,X'FF' PARAMETERS IN CALLING SEQUENCE 39400016 LA GRX,OUTPARM TO FIOCS TO BE FOR AN INIT.CALL 39600016 BAL W1,WRITENT GO TO INITIALIZE FIOCS 39800016 MVI PARAMS,X'02' RESET PARAMETERS FOR A WRITE 40000016 MVI PARAMS+1,X'00' CALL. 40200016 BR W2 RETURN 40400016 PRINTMES EQU * 40600016 L W3,MSG(0,R1) GET ADDRESS OF MESSAGE-4 40800016 L W4,0(0,W3) GET LENGTH OF MESSAGE 41000016 TSTZERO EQU * 41200016 LTR W4,W4 LENGTH ZERO. 41400016 BCR 8,W2 YES, RETURN 41600016 COMP CR W4,LN LENGTH > BUFFER LENGTH 41800016 BH MOVE132 YES, BRANCH 42000016 BCTR W4,0 SET UP FOR EXECUTE, IF NOT 42200016 EX W4,MOVEL132 MOVE MESSAGE TO BUFFER 42400016 BAL W1,WRITE WRITE MESSAGE 42600016 BR W2 RETURN 42800016 MOVEL132 MVC 1(1,TW),4(W3) MOVE INSTRUCTION TO BE EXECUTED 43000016 MOVE132 LR GRY,LN USE BUFFER LENGTH AS LENGTH 43200016 BCTR GRY,0 SET UP FOR EXECUTE 43400016 EX GRY,MOVEL132 MOVE FIRST PART OF MESSAGE 43600016 LA W3,1(GRY,W3) UPDATE MESSAGE ADDRESS 43800016 SR W4,LN DECREMENT LENGTH 44000016 BAL W1,WRITE WRITE MESSAGE 44200016 B COMP GO CHECK REMAINING LENGTH 44400016 DUPENTRY EQU * 44600016 * 44800016 LR W1,W2 SAVE NEW ERROR NUMBER 45000016 LA 3,FRSTERR CONVERT ERROR NUMBER AND PLACE 45200016 BAL W5,CNVRT INTO MESSAGE 45400016 STH W1,ERRORNM SAVE ERROR NUMBER 45600016 LA 3,DUPNM CONVERT ERROR NUMBER AND PLACE 45800016 BAL W5,CNVRT INTO MESSAGE 46000016 MVC 1(DPLNG,TW),DUPMSG MOVE MESSAGE TO BUFFER 46200016 BAL W1,WRITE WRITE MESSAGE 46400016 PREXITIB EQU * 46600016 BAL W2,PRINTMES PRINT THE ERROR MESSAGE 46800016 MVI IHC900SW,ON INDICATE RETURN TO PRINT BUFF 20754 46850017 L W2,ERNM(0,R1) PICK UP ERROR NUMBER A42666 46860021 CLI 3(W2),214 IS IT A 214 A42666 46870021 BNE MESSRTN NO,BRANCH A42666 46880021 OI 12(R1),X'40' SPEC CASE RET TO FIOCS A42666 46890021 B MESSRTN TEST PRINT BUFFER FOR ERROR 20754 46900017 EXCEEDED MVI IHC900SW,OFF INDICATE NORMAL PROCESSING 20754 46950017 BAL W2,TRACEBK GIVE TRACEBACK 47000016 BAL W2,FRMAIN FREE BUFFER IF NECESSARY 47200016 TM 12(R1),X'40' IS THIS SPECIAL 214 CASE A42666 47260021 BO COMRET1 YES, RETURN TO FIOCS A42666 47320021 EXITIB EQU * 47400016 MVI ENTRYSW,OFF TUR- OFF E-TRY SWITCH 47600016 L 15,=V(IBCOM#) GO TO TERMINATE JOB 47800016 BAL 14,68(0,15) 48000016 DC AL2(16) 48200016 FRMAIN CLI FREESW,ON IS THE BUFFER AREA TO BE FREED 48400016 BCR 7,W2 (I.E. IS THIS A 218) NO, RETURN 48600016 MVI FREESW,OFF YES, TURN OFF SWITCH 48800016 L 1,MSG(0,R1) GET ADDRESS OF AREA TO BE FREED 49000016 LA 0,112 GET LENGTH 49200016 FREEMAIN R,LV=(0),A=(1) 49400016 BR W2 RETURN 49600016 WRITE EQU * 49800016 MVI 0(TW),C'0' MOVE IN CARRIAGE CONTROL CHAR. 50000016 WRITE1 EQU * 19727 50100017 LA GRX,1(0,LN) SET LENGTH TO BUFFER LENGTH 50200016 WRITENT EQU * 50400016 L 1,=V(FIOCSBEP) LINK TO SPECIAL ENTRY POINT IN 50600016 BALR 0,1 FIOCS(THIS ENTRY ASSUMES A 50800016 PARAMS EQU * SAVE AREA IS PASSED TO IT) 51000016 DC XL2'0200' 51200016 NOP 0 51400016 LR TW,GRX SET NEW BUFFER ADDR INTO REG TW 51600016 LR LN,GRY SET LENGTH OF BUFFER-1 IN 51800016 BCTR LN,0 REG. LN 52000016 BR W1 RETURN 52200016 CNVRT L 15,=V(IBCOM#) GET ADDRESS OF INT OUTPUT 52400016 EX 0,82(0,15) CONVERSION ROUTINE 52600016 LA 2,ERRORNM GET ADDRESS OF NUMBER TO CONVERT 52800016 BALR 0,1 LINK TO CONVERSION ROUTINE 53000016 DC XL2'0204' 53200016 BR W5 RETURN 53400016 BADERNO EQU * 53600016 LA 3,MS902DT GET ADDRESS OF WHERE TO PUT NUM. 53800016 BAL W5,CNVRT CONVERT NUMBER 54000016 MVC 1(MS902LN,TW),MS902 MOVE MESSAGE 54200016 BAL W1,WRITE WRITE MESSAGE 54400016 B COMRET GO TO EXIT 54600016 CLEANTBL EQU * 54800016 L R1,=V(IHCUOPT) GET OPTION TABLE ADDRESS 55000016 L W3,NUMENTR GET NUMBER OF ENTRIES 55200016 SLL W3,3 GET ADDRESS OF LAST ENTRY IN 55400016 LR TB,R1 TABLE AS ADDRESS OF BEGINNING+ 55600016 AR TB,W3 NUMBER OF ENTRIES*ENTRY SIZE. 55800016 SRL W3,3 56000016 SR W4,W4 56200016 LOOP1 SR W2,W2 56400016 IC W2,NUMERR GET NUMBER OF ERRORS THAT HAVE 56600016 TM BITS,TW56ER OCCURRED. IF 256 ERRORS INDICAT- 56800016 BZ *+12 ION IS ON ADD 256 TO THIS COUNT. 57000016 AH W2,CON256 57200016 NI BITS,FF-TW56ER TURN OFF 256 INDICATION 57400016 LTR W2,W2 IS COUNT ZERO(I.E. NO ERRORS OF 57600016 BZ NXTNM THIS TYPE HAVE OCCURRED)YES, BR. 57800016 CH W4,CON256 HAS HEADING BEEN PRINTED YET 58000016 BNL STMSGUP YES, BRANCH 58200016 AH W4,CON256 NO, INDICATE HEADING HAS BEEN 58400016 MVC 1(HDNG,TW),HEADING PRINTED. MOVE HEADING TO BUFFER 58600016 MVI 0(TW),C'1' PRINT HEADING 19727 58700017 BAL W1,WRITE1 19727 58800017 STMSGUP EQU * 59000016 LA W5,EQ206(0,W3) PUT ERROR TYPE IN MESSAGE 59200016 STH W5,ERRORNM VIA THE CONVERSION ROUTINE 59400016 LA 3,ERRNMOF(0,TW) 59600016 BAL W5,CNVRT 59800016 LA 3,NUMEROF(0,TW) PUT NUMBER OF ERRORS OF THIS 60000016 STH W2,ERRORNM TYPE THAT HAVE OCCURRED IN MESS. 60200016 BAL W5,CNVRT VIA THE CONVERSION ROUTINE 60400016 CH W2,CON511 IF ERROR COUNT IS 511 THEN THIS 60600016 BNE WRTLINE REALLY MEANS 511 OR OVER SO 60800016 MVC NUMEROF+5(7,TW),OROVER AUGMENT THE MESSAGE 61000016 WRTLINE BAL W1,WRITE WRITE THIS LINE OF SUMMARY 61200016 STC W4,NUMERR ZERO OUT ERROR COUNT 61400016 NXTNM SH TB,TABSIZEH DECREMENT TABLE ENTRY ADDRESS 61600016 BCT W3,LOOP1 LOOP BACK IF MORE ERROR ENTRIES 61800016 MVI ENDSW,OFF TO HANDLE. ELSE TURN OFF SWITCH 62000016 B COMRET1 RETURN 62200016 CON4 DC H'4' 62400016 CON217 DC H'217' 62600016 CON218 DC H'218' 62800016 CON240 DC H'240' 37107 62900020 ERRORNM DC H'0' 63000016 TABSIZEH DC H'8' 63200016 HLF206 DC H'206' 63400016 EQ206 EQU 206 63600016 CON256 DC H'256' 63800016 CON511 DC H'511' 64000016 MOVETOBF MVC 1(0,GRX),0(GRX) 64200018 ENDERR DC F'0' 64400016 COMMONSV DC 18F'0' 64600016 SPER DC XL1'00' 64800016 FREESW DC XL1'00' 65000016 ENDSW DC XL1'00' 65200016 ENTRYSW DC XL1'00' 65400016 IHC900SW DC XL1'00' 65500017 DS 0F 65600016 OUTPARM DC XL4'04000000' 65800016 PRINTSW DC XL1'00' 66000016 FF EQU X'FF' 66200016 ON EQU X'FF' 66400016 OFF EQU X'00' 66600016 FORU EQU X'80' 66800016 UFORM EQU X'C0' 67000016 * 67200016 * 67400016 * OFFSETS TO VARIOUS AREAS IN IBCOM 67600016 * 67800016 * 68000016 SAVE EQU X'7C' 68200016 MAINEP EQU X'C0' 68400016 IOERR EQU X'110' 68600016 ENDFILE EQU X'10C' 68800016 MSG EQU 0 69000016 RTCD EQU 4 69200016 ERNM EQU 8 69400016 DSRN EQU 12 69600016 IODECB EQU 16 69800016 CCHAR EQU X'80' BIT INDICATING CONTROL CHAR. 70000016 * IS TO BE ADDED FOR ERROR 212 70200016 MODIFY EQU X'40' BIT INDICATING TABLE ENTRY 70400016 * CAN BE MODIFIED 70600016 TW56ER EQU X'20' BIT INDICATING THAT MORE THAN 70800016 * 256 ERRORS OF THIS TYPE HAVE 71000016 * OCCURRED 71200016 PRNTBUF EQU X'10' BIT INDICATING THAT CURRENT 71400016 * BUFFER IS TO BE PRINTED ALONG 71600016 * WITH THE ERROR MESSAGE 71800016 PRNTMSG EQU X'04' BIT INDICATING ALWAYS PRINT MSG. 72000016 TRACE EQU X'02' BIT INDICATING GIVE TRACE 72200016 EJECT 72400016 * MESSAGES 72600016 OROVER DC C'OR OVER' 72800016 MS902 DC C'IHC902I ERROR NUMBER ' 73000016 MS902DT DC C' ' 73200016 DC C' OUT OF RANGE OF ERROR TABLE' 73400016 MS902E EQU * 73600016 MS902LN EQU MS902E-MS902 73800016 MS902D EQU MS902DT-MS902 74000016 DUPMSG DC C'IHC901I EXECUTION TERMINATING DUE TO SECONDARY ENTRY TX74200016 O ERROR MONITOR FOR ERROR ' 74400016 DUPNM DC C' ' 74600016 DC C' WHILE PROCESSING ERROR' 74800016 FRSTERR DC C' ' 75000016 DUPMSGND EQU * 75200016 DPLNG EQU DUPMSGND-DUPMSG 75400016 HDNG EQU 64 75600016 HEADING DC C'SUMMARY OF ERRORS FOR THIS JOB ERROR NUMBER NUMBERX75800016 OF ERRORS' 76000016 ERRNMOF EQU 34 76200016 NUMEROF EQU 49 76400016 TERMSG EQU 70 76600016 MSGEND DC C'IHC900I EXECUTION TERMINATING DUE TO ERROR COUNT FOR EX76800016 RROR NUMBER ' 77000016 CNVRTNM DC XL4'40404040' 77200016 MESS0 DC C'STANDARD FIXUP' 77400016 MESS1 DC C' USER FIXUP ' 77600016 BUFPTRS EQU X'114' 77800016 COMON DC C' TAKEN , EXECUTION CONTINUING' 78000016 MESSLN EQU MESS1-MESS0 78200016 MESSLN2 EQU *-COMON 78400016 EJECT 78600016 ERRTBL DSECT 78800016 MAXERR DS X MAX. NUMBER OF ERRORS 79000016 MAXMESS DS X MAX. NUMBER OF MESSAGES 79200016 NUMERR DS X NUMBER OF ERRORS SO FAR 79400016 BITS DS X BITS 79600016 USERADDR DS 4X ADDRESS OF USER'S FIXUP ROUTINE 79800016 * IF NONE IS PRESENT THIS WORD 80000016 * SHOULD CONTAIN A ONE TO INDICATE 80200016 * NO ADDRESS IS PRESENT 80400016 OPTIONTB DSECT 80600016 NUMENTR DS 4X NUMBER OF ENTRIES IN OPTION 80800016 * TABLE 81000016 DS 4X 81200016 ERRORENT DS 8X ENTRY IN TABLE PER ERROR 81400016 DCBD DSORG=PS 81600016 END 81800016 ./ ADD SSI=01011132,NAME=IHCETRCH,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 1 20000016 IHCTRACM 30000016 END 40000016 ./ ADD SSI=01012000,NAME=IHCFAINT,SOURCE=0 IHCFAINT START 0 00020000 ENTRY AINT REAL TRUNCATION 00040000 SPACE 3 00060000 * CALLING SEQUENCE 00080000 * LA S,SAVLOC 00100000 * LA A,ARGLST 00120000 * L L,=V(AINT) 00140000 * BALR R,L 00160000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00180000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00200000 * DC AL4(X) ADDRESS OF FIRST ARGUMENT 00220000 SPACE 3 00240000 * ERROR CONDITIONS 00260000 * NONE 00280000 SPACE 3 00300000 * REGISTER DEFINITIONS 00320000 S EQU 13 SAVE AREA POINTER 00340000 R EQU 14 RETURN REGISTER 00360000 L EQU 15 LINKAGE REGISTER 00380000 A EQU 1 ARGUMENT LIST POINTER 00400000 ARGADD EQU 2 ADDRESS OF ARGUMENT 00420000 RESULT EQU 0 RESULT REGISTER 00440000 SPACE 3 00460000 * BRANCHING CONDITIONS 00480000 ALWAYS EQU 15 UNCONDITIONAL 00500000 HIEQ EQU 10 HIGH OR EQUAL 00520000 LOEQ EQU 12 LOW OR EQUAL 00540000 EJECT 00560000 * 00580000 USING *,15 00600000 AINT B 10(0,15) 00620000 DC AL1(4) 00640000 DC CL4'AINT' 00660000 STM 14,2,12(13) 00680000 L ARGADD,0(0,A) 00700000 LE RESULT,0(0,ARGADD) GET ARGUMENT 00720000 CE RESULT,CNSTP1 00740000 BC HIEQ,TRUNC BRANCH IF GE +1 00760000 CE RESULT,CNSTM1 00780000 BC LOEQ,TRUNC BRANCH IF LE -1 00800000 SER RESULT,RESULT SET RESULT TO ZERO 00820000 BC ALWAYS,EXIT 00840000 TRUNC AE RESULT,CNSTRN TRUNCATE FRACTIONAL PART 00860000 EXIT LM 14,2,12(S) RESTORE MAIN REGISTERS 00880000 MVI 12(S),X'FF' 00900000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 00920000 * 00940000 SPACE 3 00960000 * 00980000 * DATA AND STORAGE AREAS 01000000 * 01020000 DS 0F 01040000 CNSTP1 DC X'41100000' 01060000 CNSTM1 DC X'C1100000' 01080000 CNSTRN DC X'47000000' 01100000 * 01120000 SPACE 3 01140000 END 01160000 ./ ADD SSI=01010726,NAME=IHCFCDXI,SOURCE=0 IHCFCDXI CSECT 00020000 * 3/9/66 00040000 EXTRN IBCOM# 00060000 EXTRN IHCERRM 00070016 EXTRN CDMPY# 00080000 EXTRN CDDVD# 00100000 ENTRY FCDXI# 00120000 * DBL PREC COMPLEX NUMBER BASE, FIXED POINT EXPONENT LIBRARY ROUTINE 00140000 USING *,15 00160000 FCDXI# B 12(0,15) 00180000 DC AL1(6) 00200000 DC CL6'FCDXI#' 00220000 STM RTN,BASADD,12(SAVE) 00226016 LR ADDR,SAVE 00232016 LA SAVE,SAVREG GET ADDR OF OWN SAVE 00238016 ST ADDR,4(SAVE) STORE FORMER SAVE AREA ADDR 00244016 ST SAVE,8(ADDR) STORE NEW SAVE ADDR IN FORMER 00250016 BALR BASADD,0 00256016 USING *,BASADD 00262016 BEGIN L ADDR,0(PLIST) LOAD PLIST OF COMPLEX NUM 00268016 LD REAL,0(0,ADDR) LOAD REAL PART OF NO INTO REAL REG 00280000 LD IMAG,8(0,ADDR) LOAD IMAG PART OF NO INTO IMAG REG 00300000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00320000 L EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00340000 LTDR REAL,REAL CHECK IF REAL NO PLUS, MINUS,OR ZERO 00400000 BC 6,TEST IF REAL NO NOT ZERO, BRANCH TO TEST 00420000 LTDR IMAG,IMAG CHECK IF IMAG NO PLUS, MINUS,OR ZERO 00440000 BC 8,ERROR IF IMAG NO IS ZERO, BRANCH TO ERROR 00460000 TEST SR EXPSW,EXPSW SET NEGATIVE EXPN SWITCH REG TO ZERO 00480000 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00500000 BC 2,PLUS IF EXPN IS POSITIVE, BRANCH TO PLUS 00520000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00540000 LCR EXPN,EXPN EXPN MINUS, CONVERT TO 2S COMPLIMENT 00560000 LA EXPSW,1(EXPSW) SET EXP SW REG TO ONE FOR MINUS EXPN 00580000 PLUS MVC FACTR(16),ONE 00640016 LOOP STD REAL,BASER STORE REAL PART COMPLEX NO AT BASER 00700000 STD IMAG,BASEI STORE IMAG PART COMPLEX NO AT BASEI 00720000 SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 00740000 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 00760000 BC 10,JUMP IF SIGN BIT NOT MINUS,BRANCH TO JUMP 00780000 LA PLIST,PARAM2 SET PARAM LIST REG FOR CDMPY ROUTINE 00800000 L LINK,ACDMPY LOAD ADCON OF CDMPY RTN IN LINK REG 00820000 BALR RTN,LINK BRANCH TO CDMPY RTN FOR COMPLEX MULT 00840000 STD REAL,FACTR STORE REAL PART COMPLEX NO AT FACTR 00860000 STD IMAG,FACTI STORE IMAG PART COMPLEX NO AT FACTI 00880000 JUMP LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00900000 BC 8,NEXT IF EXPONENT NOW ZERO, BRANCH TO NEXT 00920000 LA PLIST,PARAM3 SET PARAM LIST REG FOR CDMPY ROUTINE 00940000 L LINK,ACDMPY LOAD ADCON OF CDMPY RTN IN LINK REG 00960000 BALR RTN,LINK BRANCH TO CDMPY RTN FOR COMPLEX MULT 00980000 BC 15,LOOP BRANCH TO LOOP TO TEST NEXT EXPN BIT 01000000 NEXT LTR EXPSW,EXPSW TEST IF EXPSW REG PLUS,MINUS,OR ZERO 01020000 BC 8,EXIT IF EXP NOT MINUS-TO EXIT 01040016 LA PLIST,PARAM1 SET PARAM LIST REG FOR CDDVD ROUTINE 01060000 L LINK,ACDDVD LOAD ADCON OF CDDVD RTN IN LINK REG 01080000 BALR RTN,LINK BRANCH TO CDDVD RTN FOR COMPLEX DVSN 01100000 BC 15,EXIT BRANCH TO EXIT(RESULT IN FP REG 0,2) 01140000 LOAD1 LD REAL,ONE LOAD ONE AS REAL RESULT IN REAL REG 01160000 LD IMAG,ZERO LOAD ZERO AS IMAG RESULT IN IMAG REG 01180000 EXIT L SAVE,4(SAVE) RESTORE TO FORMER SAVE AREA 01190016 LM RTN,BASADD,12(SAVE) RELOAD 14-5 01200016 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 01220000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 01240000 ERROR LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 01260000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 01280000 STD REAL,BASER 01285016 STD IMAG,BASEI 01290016 ST EXPN,EXPON 01295016 LM RTN,LINK,AERRMON 14 HAS ADDR ERMON, 15 HAS ADDR IBCOM 01300016 LA 2,EXPON ADDR OF EXPONENT 01305016 LA 3,MSGDATA 01310016 EX 0,82(LINK) FCVIO 01315016 BALR 0,1 01320016 DC X'040B' LL=4 WW=11 01325016 LA PLIST,ERRLIST 01330016 LR LINK,RTN ADDR ERMON IN LINK FOR BALR 01335016 BALR RTN,LINK 01340016 CLI RETCODE+3,X'00' DID USER FIX DATA 01345016 STNDFIX BZ EXIT RESULT ALREADY ZERO IN REGS 01350016 FIXUP LA PLIST,ERRLIST+12 ADDR OF REAL,IMAG,EXP 01355016 B BEGIN 01360016 * FLOATING POINT REGISTERS 01380000 REAL EQU 0 REGISTER FOR REAL PART OF COMPLEX NO 01400000 IMAG EQU 2 REGISTER FOR IMAG PART OF COMPLEX NO 01420000 * GENERAL PURPOSE REGISTERS 01440000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01460000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01480000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01500000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01520000 EXPN EQU 2 01540016 ADDR EQU 3 01560016 EXPSW EQU 4 01580016 BASADD EQU 5 01600016 * ADCONS AND CONSTANTS AREA 01620000 SAVREG DS 18F 01640016 BASER DS D USED TO HOLD REAL PART BASE NO 01660000 BASEI DS D USED TO HOLD IMAG PART BASE NO 01680000 FACTR DC X'4110000000000000' USED IN FACTORING REAL BASE NO 01700000 FACTI DC X'0000000000000000' USED IN FACTORING IMAG BASE NO 01720000 ONE DC X'4110000000000000' CONSTANT ONE IN DOUBLE PREC F P 01740000 ZERO DC X'0000000000000000' CONS OF ZERO IN DOUBLE PREC F P 01760000 PARAM1 DC AL4(ONE) ADCON OF 1ST PARAM IN CDDVD RTN 01780000 PARAM2 DC AL4(FACTR) ADCON OF 2ND PARAM IN CDDVD RTN 01800000 PARAM3 DC AL4(BASER) ADCON OF 1ST PARAM IN CDMPY RTN 01820000 DC AL4(BASER) ADCON OF 2ND PARAM IN CDMPY RTN 01840000 ACDMPY DC AL4(CDMPY#) ADCON OF CDMPY MATH LIBRARY RTN 01860000 ACDDVD DC AL4(CDDVD#) ADCON OF CDDVD MATH LIBRARY RTN 01880000 AERRMON DC V(IHCERRM) 01890016 VIBCOM DC A(IBCOM#) ADCON OF STANDARD ERROR ROUTINE 01900000 ERRLIST DC A(MSGLNG) 01901016 DC A(RETCODE) 01902016 DC A(ERRNUM) 01903016 DC A(BASER) 01904016 DC X'80' 01905016 DC AL3(EXPON) 01906016 EXPON DS F 01907016 RETCODE DS F 01908016 ERRNUM DC F'247' 01909016 MSGLNG DC A(ENDMSG-MSG) 01910016 MSG DC C'IHC247I FCDXI COMPLEX*16 BASE=0.0+0.0I, INTEGER EXPONEX01911016 NT=' 01912016 MSGDATA DS 11C 01913016 DC C', LE 0' 01914016 ENDMSG EQU * 01915016 END 01920000 ./ ADD SSI=11010932,NAME=IHCFCOME,SOURCE=0 TITLE 'IHCFCOME' - OPERATING SYSTEM 360 FORTRAN E 00020000 IHCFCOME START 0 LIBRARY PACKAGE FOR FORTRAN E 00040000 *2203 273600,274400-274600 22800 00050019 * 24793 00060019 IBCOM# EQU * 00080000 ENTRY IBCOM# 00100000 EXTRN FIOCS# 00120000 ENTRY FDIOCS# 00140000 ENTRY INTSWTCH 00145016 ENTRY IHCERRM 00150016 ENTRY ERRMON 00155016 * 00160000 * STATUS - CHANGE LEVEL 04, 10APR70 RELEASE 19 00180019 * 00200000 * FUNCTION/OPERATION--IHCFCOME, A MEMBER OF THE FORTRAN SYSTEM LIBRARY, 00220000 * PERFORMS OBJECT-TIME IMPLEMENTATION OF THE FOLLOWING FORTRAN 00240000 * I/O SOURCE STATEMENTS. 00260000 * 1. READ AND WRITE (BOTH FORMATTED AND NON-FORMATTED) 00280000 * 2. BACKSPACE, REWIND, AND ENDFILE (DEVICE MANIPULATION) 00300000 * 3. STOP AND PAUSE (WRITE TO OPERATOR) 00320000 * IN ADDITION, IHCFCOME PROCESSES OBJECT-TIME ERRORS DETECTED 00340000 * BY THE VARIOUS FORTRAN LIBRARY SUBPROGRAMS, PROCESSES 00360000 * ARITHMETIC-TYPE PROGRAM INTERRUPTS, AND TERMINATES LOAD MODULE 00380000 * EXECUTION. 00400000 * 00420000 * ENTRY POINTS--ONE ENTRY POINT, 'IBCOM#', WHICH IS THE INITIAL 00440000 * LOCATION IN A TRANSFER VECTOR. LINKAGE TO ROUTINES WITHIN 00460000 * IHCFCOME IS ACCOMPLISHED BY L 15,=V(IBCOM#) 00480000 * BAL 14,D(15) 00500000 * WHERE 'D' VARIES ACCORDING TO THE ROUTINE DESIRED. 00520000 * 00540000 * ROUTINE 'D' FUNCTION 00560000 * ....... ... .............................................. 00580000 * FRDWF 0 OPENING SECTION, FORMATTED READ 00600000 * FWRWF 4 OPENING SECTION, FORMATTED WRITE 00620000 * FIOLF 8 I/O LIST SECTION, FORMATTED LIST VARIABLE 00640000 * FIOAF 12 I/O LIST SECTION, FORMATTED LIST ARRAY 00660000 * FENDF 16 CLOSING SECTION, FORMATTED READ OR WRITE 00680000 * FRDNF 20 OPENING SECTION, NON-FORMATTED READ 00700000 * FWRNF 24 OPENING SECTION, NON-FORMATTED WRITE 00720000 * FIOLN 28 I/O LIST SECTION, NON-FORMATTED LIST VARIABLE 00740000 * FIOAN 32 I/O LIST SECTION, NON-FORMATTED LIST ARRAY 00760000 * FENDN 36 CLOSING SECTION, NON-FORMATTED READ OR WRITE 00780000 * FBKSP 40 IMPLEMENTS THE BACKSPACE SOURCE STATEMENT 00800000 * FRWND 44 IMPLEMENTS THE REWIND SOURCE STATEMENT 00820000 * FEOFM 48 IMPLEMENTS THE ENDFILE SOURCE STATEMENT 00840000 * FSTOP 52 WRITE TO OPERATOR, TERMINATE JOB 00860000 * FPAUS 56 WRITE TO OPERATOR, RESUME EXECUTION 00880000 * IBFERR 60 EXECUTION ERROR MONITOR 00900000 * IBFINT 64 INTERRUPT PROCESSOR 00920000 * IBEXIT 68 JOB TERMINATOR 00940000 * 00960000 * THE COMPLETE CALLING SEQUENCE FOR EACH OF THE ABOVE ROUTINES 00980000 * IS GIVEN IN THE BODY OF THE LISTING. 01000000 * 01020000 * INPUT--INPUT CONSISTS OF PARAMETERS PASSED IN THE CALLING SEQUENCES 01040000 * GENERATED BY THE FORTRAN COMPILER, AND DATA READ FROM USER- 01060000 * DEFINED INPUT SOURCES. 01080000 * 01100000 * OUTPUT--OUTPUT CONSISTS OF DATA RECORDS AND ERROR MESSAGES. 01120000 * 01140000 * EXTERNAL ROUTINES--IHCFIOSE, THE I/O INTERFACE WITH DATA MANAGEMENT. 01160000 * 01180000 * EXITS-- 01200000 * NORMAL--RETURN IS TO THE CALLING ROUTINE VIA REGISTER 14, 01220000 * UNLESS THE SOURCE STATEMENT BEING IMPLEMENTED IS A STOP, 01240000 * IN WHICH CASE RETURN IS TO THE SUPERVISOR. 01260000 * ERROR--IN CASE OF AN OBJECT-TIME ERROR, A MESSAGE IS WRITTEN 01280000 * ON THE MESSAGE OUTPUT UNIT, EXECUTION IS TERMINATED, AND RETURN 01300000 * IS TO THE SUPERVISOR WITH A CODE OF 16 DECIMAL. 01320000 * 01340000 * TABLES/WORK AREAS-- 01360000 * 'TABLE' - A BRANCH TABLE CORRESPONDING TO FORMAT CODES 01380000 * GENERATED BY THE FORTRAN COMPILER. 01400000 * 'ETABHX' - POWERS OF 10 FROM 0 TO 9 IN DOUBLE-PRECISION 01420000 * FLOATING POINT (HEXADECIMAL REPRESENTATION). 01440000 * 'ETABHT' - TENS' POWERS OF 10 FROM 10 TO 70 IN DOUBLE-PRECISION 01460000 * FLOATING POINT (HEXADECIMAL REPRESENTATION). 01480000 * 'SAVE' - REGISTER STORAGE AREA USED BY THE READ/WRITE AND 01500000 * DEVICE MANIPULATION ROUTINES. 01520000 * 'SAVERR' - REGISTER STORAGE AREA USED BY THE WRITE-TO-OPERATOR 01540000 * ROUTINES, THE EXECUTION ERROR MONITOR, THE INTERRUPT 01560000 * PROCESSOR, AND THE JOB TERMINATOR. 01580000 * 'SAVER' - REGISTER STORAGE AREA USED BY THE FORMAT CONVERSION 01600000 * PACKAGE. 01620000 * 01640000 * ATTRIBUTES--THIS MODULE IS NOT REENTRANT, BUT IS SERIALLY REUSABLE. 01660000 * 01680000 * NOTES-- 01700000 * 1. ALL CALLING SEQUENCES TO IHCFCOME ARE NON-STANDARD. 01720000 * 2. IHCFCOME USES ITS OWN INTERNAL REGISTER SAVE AREAS, RATHER 01740000 * THAN STORING REGISTERS IN THE CALLING PROGRAM. 01760000 * 3. ROUTINES FSTOP AND FPAUS USE A HAND-CODED WTO/WTOR MACRO. 01780000 * 4. ROUTINE FPAUS ISSUES A SYSTEM WAIT FOLLOWING EXECUTION 01800000 * OF THE WTOR. 01820000 * 5. ROUTINE IBFINT ISSUES A SYSTEM SPIE TO INITIALIZE THE 01840000 * PROCESSING OF ARITHMETIC-TYPE PROGRAM INTERRUPTS. 01860000 * 6. ROUTINE IBEXIT ISSUES A SYSTEM SPIE WITH NO ARGUMENTS 01880000 * TO RETURN TO NORMAL INTERRUPT PROCESSING. 01900000 * 01920000 EJECT 01940000 * REGISTER DEFINITIONS 01960000 S EQU 13 SAVE AREA POINTER 01980000 R EQU 14 RETURN REGISTER 02000000 L EQU 15 LINKAGE REGISTER 02020000 GRX EQU 2 FIRST ARGUMENT 02040000 GRY EQU 3 SECOND ARGUMENT 02060000 SPILL EQU 4 UTILITY REGISTER 02080000 BASE EQU 5 BASE REGISTER 02100000 CALLER EQU 6 CALLING REGISTER 02120000 BYTER EQU 7 ONE BYTE ONLY 02140000 BUFLIM EQU 8 END OF RECORD 02160000 BUFPTR EQU 9 LOCATION IN RECORD 02180000 FMTPTR EQU 10 LOCATION IN FORMAT 02200000 ADDER EQU 11 ARRAY INCREMENT 02220000 LOOP EQU 12 LOOP CONTROL 02240000 RECCNT EQU 5 RECORD COUNTER 02260000 BUFLOC EQU 10 START OF RECORD 02280000 RECNUM EQU 4 BACKSPACE COUNTER 02300000 INDEX EQU 5 PARAMETER LOCATOR 02320000 COUNT EQU 4 COUNT FOR MOVE 02340000 WIDTH EQU 6 BUFFER POSITIONS 02360000 CALLBY EQU 4 INTERNAL CALLS 02380000 DECCTR EQU 7 NUMBER OF DECIMALS 02400000 SPLCTR EQU 8 OVERFLOW COUNTER 02420000 CALLIN EQU 9 INTERNAL CALLS 02440000 DATUM1 EQU 10 HIGH-ORDER BINARY NUMBER 02460000 DATUM2 EQU 11 LOW-ORDER BINARY NUMBER 02480000 BASEC EQU 12 BASE REGISTER 02500000 RESULT EQU 2 FLOATED DATUM 02520000 SCALE EQU 4 SCALING CONSTANT 02540000 NUMBER EQU 7 BINARY INTEGER 02560000 FLOAT EQU 6 WORK REGISTER 02580000 FACTOR EQU 2 SCALING INDICATOR 02600000 CHRSAV EQU 9 POINTER TO CONVERT AREA 02620000 TABLEX EQU 10 SCALING TABLE POINTER 02640000 EXPONX EQU 11 EXPONENT TABLE POINTER 02660000 BRANCH EQU 13 BRANCH CONDITION CODE 02680000 MAXIM EQU 13 MAXIMUM NUMBER OF DIGITS 02700000 ROUNDR EQU 10 ROUNDING POSITION 02720000 DIGRND EQU 11 ROUNDING REGISTER 02740000 MINIM EQU 10 MINIMUM SPACE REQUIRED 02760000 MOVER EQU 11 NUMBER OF DIGITS TO MOVE 02780000 R0 EQU 0 HWRE 02782014 DEC EQU 2 HWRE 02784014 ORER EQU 5 HWRE 02786014 ADR EQU 6 HWRE 02788014 SWT EQU 7 HWRE 02790014 R8 EQU 8 02792014 R9 EQU 9 02794014 R10 EQU 10 02796014 R11 EQU 11 02798014 R256 EQU 4 USED TO COMPUTE CORRECT 174 02798417 B EQU 6 SIZE OF MOVE OPERATION 174 02798817 BTM EQU 11 BYTES LEFT IN ARRAY 174 02799217 BTG EQU 12 BYTES LEFT IN BUFFER 174 02799617 SPACE 3 02800000 * BRANCHING CONDITIONS 02820000 ALWAYS EQU 15 UNCONDITIONAL 02840000 HIGH EQU 2 HIGH 02860000 LOW EQU 4 LOW 02880000 EQUAL EQU 8 EQUAL 02900000 NOTEQ EQU 7 NOT EQUAL 02920000 HIEQ EQU 10 HIGH OR EQUAL 02940000 LOEQ EQU 12 LOW OR EQUAL 02960000 PLUS EQU 2 PLUS 02980000 MINUS EQU 4 MINUS 03000000 ZERO EQU 8 ZERO 03020000 NZERO EQU 7 NOT ZERO 03040000 ZPLUS EQU 10 ZERO OR PLUS 03060000 ZMINUS EQU 12 ZERO OR MINUS 03080000 ALL EQU 1 ALL BITS ON 03100000 NONE EQU 8 NO BITS ON 03120000 ANYALL EQU 5 ANY OR ALL BITS ON 03140000 OVER EQU 1 OVERFLOW 03160000 UNDER EQU 14 NO OVERFLOW 03180000 SPACE 3 03200000 * MISCELLANEOUS CODES 03220000 FMTINP EQU X'F0' FORMATTED INPUT 03240000 FMTOUT EQU X'FF' FORMATTED OUTPUT 03260000 NONINP EQU X'00' NON-FORMATTED INPUT 03280000 NONOUT EQU X'0F' NON-FORMATTED OUTPUT 03300000 INIT EQU X'00' INITIALIZATION OPERATION 03320000 READ EQU X'01' READ OPERATION 03340000 RITE EQU X'02' WRITE OPERATION 03360000 CTRL EQU X'03' CONTROL OPERATION 03380000 TERM EQU X'04' TERMINATION OPERATION 03400000 NULL EQU X'00' NULL QUALIFIER 03420000 BKSP EQU X'00' BACKSPACE QUALIFIER 03440000 RWND EQU X'01' REWIND QUALIFIER 03460000 EOFM EQU X'02' WRITE EOF QUALIFIER 03480000 FORMAT EQU X'F0' FORMAT QUALIFIER 03500000 OUTPUT EQU X'0F' OUTPUT QUALIFIER 03520000 ON EQU X'FF' ON CONDITION 03540000 OFF EQU X'00' OFF CONDITION 03560000 HALF EQU X'0F' HALF-ON CONDITION 03580000 DIGSW EQU X'80' DIGIT ENCOUNTERED 03600000 NEGDIG EQU X'40' NEGATIVE NUMBER 03620000 DECSW EQU X'20' DECIMAL POINT ENCOUNTERED 03640000 EXPSW EQU X'10' EXPONENT ENCOUNTERED 03660000 NODEC EQU X'DF' RESET FOR NO DECIMALS 03680000 NEGEXP EQU X'08' NEGATIVE EXPONENT 03700000 NEGSCL EQU X'04' NEGATIVE SCALING 03720000 NOEXP EQU X'02' CONVERSION WITHOUT EXPONENT 03740000 EDEXP EQU X'01' CONVERSION WITH EXPONENT 03760000 POSHAF EQU X'7F' NO OVERFLOW 03780000 NEGHAF EQU X'80' OVERFLOW 03800000 POSSCL EQU X'04' POSITIVE SCALING 03820000 DIGDEC EQU X'A0' FOR IMBEDDED BLANKS 03840000 OVERFL EQU X'F0' 03846014 UNDERFL EQU X'0F' 03852014 EJECT 03860000 * 03880000 * IBCOM TRANSFER VECTOR 03900000 * 03920000 USING *,L 03940000 BC ALWAYS,FRDWF MAIN ENTRY, FORMATTED READ 03960000 BC ALWAYS,FWRWF MAIN ENTRY, FORMATTED WRITE 03980000 BC ALWAYS,FIOLF SECONDARY ENTRY, I/O LIST ITEM 04000000 BC ALWAYS,FIOAF SECONDARY ENTRY, I/O LIST ARRAY 04020000 BC ALWAYS,FENDF FINAL ENTRY, END OF I/O LIST 04040000 BC ALWAYS,FRDNF MAIN ENTRY, NON-FORMATTED READ 04060000 BC ALWAYS,FWRNF MAIN ENTRY, NON-FORMATTED WRITE 04080000 BC ALWAYS,FIOLN SECONDARY ENTRY, I/O LIST ITEM 04100000 BC ALWAYS,FIOAN SECONDARY ENTRY, I/O LIST ARRAY 04120000 BC ALWAYS,FENDN FINAL ENTRY, END OF I/O LIST 04140000 BC ALWAYS,FBKSP BACKSPACE TAPE 04160000 BC ALWAYS,FRWND REWIND TAPE 04180000 BC ALWAYS,FEOFM WRITE TAPE MARK 04200000 BC ALWAYS,FSTOP STOP SUBROUTINE 04220000 BC ALWAYS,FPAUS PAUSE SUBROUTINE 04240000 BC ALWAYS,IBFERR EXECUTION ERROR MONITOR 04260000 BC ALWAYS,IBFINT INTERRUPTION PROCESSOR 04280000 BC ALWAYS,IBEXIT JOB TERMINATION 04300000 * 04320000 OVFIND DC X'00' OVERFLOW/UNDERFLOW INDICATOR 04340000 DVCIND DC X'00' DIVIDE-CHECK INDICATOR 04360000 * 04380000 L 1,VFIOCS I/O INTERFACE 04400000 L 1,VFCVZO HEXADECIMAL OUTPUT CONVERSION 04420000 L 1,VFCVIO INTEGER OUTPUT CONVERSION 04440000 L 1,VFCVEO REAL OUTPUT CONVERSION 04460000 L 1,VFCVDO DOUBLE OUTPUT CONVERSION 04480000 * 04500000 L 1,VFCVZO LOGICAL OUTPUT CONVERSION 04520000 L 1,VFCVDO COMPLEX OUTPUT CONVERSION 04540000 L 1,VFCVAO ALPHAMERIC OUTPUT CONVERSION 04560000 * 04580000 NOPB2 BCR 0,0 TWO-BYTE NOP 04590016 FOUR DC AL2(4) 04600016 DASW DC X'00' 04610016 DC XL3'00' 04620016 * 04640000 MVI INTSW,ON IGNORE INTERRUPTS 04660000 MVI INTSW,OFF PROCESS INTERRUPTS 04680000 OVSWITCH DC X'00' 04681016 SAVE1 DS 0F 04682016 DC XL1'FF' THIS BYTE OF FF IS NECESSARY FOR 04683016 * COMPATABILITY WITH FORTRAN H 04684016 * IBCOM(FOR ERROR HANDLING) 04685016 DC AL3(0) 04686016 DC 3F'0' AREA FOR FIOCS#, DIOCS#, AND 04687016 * PDUMP TO STORE 14-1 04688016 FMTSWS DS 0F 04688816 EFMTSW DC AL1(0) END-FORMAT INDICATOR 04689616 ARRSW DC AL1(0) ARRAY INDICATOR 04690416 DC AL1(0) NECESSARY - DO NOT DELETE. 6002 04691217 FQUALS DC AL1(0) FILE QUALIFIER STORAGE 04692016 COUNTS DS 0F 04692816 GCOUNT DC AL1(0) CURRENT GROUP COUNT 04693616 GCSAVE DC AL1(0) LAST GROUP COUNT 04694416 FCOUNT DC AL1(0) FIELD COUNT 04695216 SCALEF DC AL1(0) CURRENT SCALE FACTOR 04696016 LAGRX LA GRX,0(0,0) INSTRUCTION MASK 04696816 DFIOCS DS F AREA FOR ADDRESS OF ** 04697616 ** ROUTIND BEING USED ** 04698416 * 04700000 MOVE1 MVC 0(1,FMTPTR),0(BUFPTR) RECORD TO FORMAT 04701016 MOVE2 MVC 0(1,BUFPTR),0(FMTPTR) FORMAT TO RECORD 04702016 MOVE3 MVC 0(1,GRX),0(BUFPTR) RECORD TO INPUT ITEM 04703016 MOVE4 MVC 0(1,BUFPTR),0(GRX) OUTPUT ITEM TO RECORD 04704016 VFIOCS DC A(FIOCS#) 04705016 DC A(KEEP) THIS ADDRESS OF KEEP MUST BE AT 04706016 * LOCATION X'B8' IN IBCOM E FOR 04707016 * COMPATABILITY WITH FORTRAN H 04708016 * IBCOM (ERROR HANDLING PURPOSES) 04709016 FDIOCS# DC A(SEQDASD) AREA FOR DIOCS' ADDRESS 04712016 ERRSAV EQU FDIOCS# THIS IS THE ADDRESS OF THE SAVE 04713016 DC 6F'0' AREA THAT WILL BE USED BY ALL 04714016 * THE MATH ROUTINES FOR CALLS TO 04715016 * THE'ERROR MONITOR' 04716016 * ONLY SIX WORDS ARE NECESSARY 04717016 * SINCE THE IBCOM 'E' ERROR MON. 04718016 * WILL NOT SAVE IN THIS AREA. 04719016 SAVE DS 13F MAIN REGISTER STORAGE 25534 04719118 ENDFILE DC 1F'0' DUMMY ENDFILE FOR FIOCS 25534 04719218 * ENDFILE MUST BE AT 10C 25534 04719318 * OFFSET FOR FIOCS 25534 04719418 BUFADD DS 1F START OF RECORD 25534 04719518 LSTGRP DS 1F LAST LEFT PARENTHESIS 25534 04719618 BUFPTRHI DC A(0) IF T-CODE USED, HIGHEST 6002 04719718 * PREVIOUS RECORD PTR SETTING.6002 04719818 EJECT 04720000 * CALLING SEQUENCES 04740000 * 04760000 * CNOP 0,4 04780000 * L L,=V(IBCOM) 04800000 * BAL R,0(L) FRDWF 04820000 * OR 04840000 * BAL R,4(L) FWRWF 04860000 * DC XL1'FLAG',AL3(UNIT) 04880000 * DC AL4(FORMAT) 04900000 * WHERE FLAG = 0 IF UNIT IS AN INTEGER CONSTANT, 04920000 * ANY OTHER BIT PATTERN IF UNIT IS A VARIABLE, 04940000 * AND FORMAT IS THE ADDRESS OF THE FIRST BYTE 04960000 * OF THE ASSOCIATED FORMAT STATEMENT. 04980000 * 05000000 * L L,=V(IBCOM) 05020000 * BAL R,8(L) FIOLF 05040000 * DC XL1'LENGTH',XL0.4'0',XL0.4'X',XL0.4'B',XL1.4'D' 05060000 * WHERE LENGTH = SIZE (IN BYTES) OF THE ITEM, 05080000 * AND X, B, D ARE THE INDEX, BASE, DISPLACEMENT 05100000 * WHICH SPECIFY THE ADDRESS OF THE ITEM. 05120000 * 05140000 * L L,=V(IBCOM) 05160000 * BAL R,12(L) FIOAF 05180000 * DC AL4(ADDRESS) 05200000 * DC XL1'LENGTH',AL3(ELEMENTS) 05220000 * WHERE ADDRESS = LOCATION OF THE ARRAY, 05240000 * LENGTH = SIZE (IN BYTES) OF EACH ITEM, 05260000 * ELEMENTS = NUMBER OF ITEMS IN THE ARRAY. 05280000 * 05300000 * L L,=V(IBCOM) 05320000 * BAL R,16(L) FENDF 05340000 * 05360000 SPACE 3 05380000 * ERROR CONDITIONS 05400000 * INVALID CHARACTER IN FORMAT STATEMENT. 05420000 * ATTEMPT TO READ OR WRITE PAST END OF RECORD. 05440000 * FOR OTHERS, SEE FIOCS ROUTINE. 05460000 EJECT 05480000 * 05500000 FRDWF MVI IOSWF,FMTINP SET FOR FORMATTED INPUT 05520000 BC ALWAYS,RWCOMF 05540000 * 05560000 FWRWF MVI IOSWF,FMTOUT SET FOR FORMATTED OUTPUT 05580000 SPACE 3 05600000 * 05620000 RWCOMF STM 0,12,SAVE SAVE MAIN REGISTERS 05640000 LA BASE,RETIO SET RETURN REGISTER 05645016 IO EQU * 05650016 NI DASW,OFF TURN OFF DIRECT ACCESS SWITCH 05655016 LR GRX,R PICKUP PARAMETER POINTER 05660000 L FMTPTR,4(0,R) SET PTR TO START OF FORMAT 23878 05670018 L 1,VFIOCS 05680000 TM 0(R),X'80' IS THIS A DASD OPERATION ** 05700000 BC 8,NOTDASD1 BR IF SEQUENTIAL I/O ** 05720000 OI DASW,ON TURN ON DASD I/O INDICATOR ** 05726016 LA R,4(0,R) UPDATE RETURN POINT FOR RECORD N 05732016 L 1,FDIOCS# GET DIOCS ADDRESS ** 05740000 NOTDASD1 ST 1,DFIOCS SET I/O ROUTINE ADDRESS ** 05760000 BALR 0,1 INITIALIZE FILE 05780000 DC AL1(INIT) 05800000 IOSWF DC AL1(0) 05820000 NOP 0 05826016 SR BYTER,BYTER INITIALIZE REGISTER 05832016 SR BUFLIM,BUFLIM 05838016 STM BYTER,BUFLIM,FMTSWS INITIALIZE SWITCHES IF FORMAT 05844016 * THIS IS NECESSARY 05850016 ST BYTER,BUFPTRHI CLEAR BUFPTRHI 6002 05855017 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 05860000 LR BUFPTR,GRX INITIALIZE RECORD POINTER 05880000 BR BASE RETURN 05885016 RETIO EQU * 05890016 ST GRX,BUFADD SAVE BEGINNING OF RECORD 05895016 DASRTN1 LA R,8(0,R) COMPUTE ACTUAL RETURN ADDRESS** 06040000 * 06060000 EJECT 06080000 * 06100000 SCAN SR BASE,BASE 06120000 IC BASE,0(0,FMTPTR) SCAN OUT OPERATOR 06140000 SLA BASE,1 06160000 CH BASE,LIMIT 06180000 BC HIEQ,FMTERR ERROR, NOT IN TABLE. 06200000 BC ALWAYS,TABLE(BASE) BRANCH TO CORRESPONDING ROUTINE 06220000 * 06240000 TABLE DS 0H 06260000 BC ALWAYS,FMTERR 00 06280000 BC ALWAYS,BEGINF 02 06300000 BC ALWAYS,GRPCNT 04 06320000 BC ALWAYS,FLDCNT 06 06340000 BC ALWAYS,PSCALE 08 06360000 BC ALWAYS,FCNVRT 0A 06380000 BC ALWAYS,ECNVRT 0C 06400000 BC ALWAYS,DCNVRT 0E 06420000 BC ALWAYS,ICNVRT 10 06440000 BC ALWAYS,COLUMN 12 06460000 BC ALWAYS,ACNVRT 14 06480000 BC ALWAYS,LCNVRT 16 06500000 BC ALWAYS,XCNVRT 18 06520000 BC ALWAYS,HCNVRT 1A 06540000 BC ALWAYS,GRPEND 1C 06560000 BC ALWAYS,SLASHR 1E 06580000 BC ALWAYS,GCNVRT 20 06600000 BC ALWAYS,ENDFMT 22 06620000 LIMIT DC AL2(*-TABLE) 06640000 * 06660000 FMTERR LA R,211 GIVE MESSAGE 211 06670016 COMERRHN ST R,ERRORNO SAVE EROR NUMBER 06680016 LA 1,STASH GET ADDRESS OF PARAMETER LIST 06690016 B 60(0,L) GO TO OUPUT MESSAGE 06700016 * 06720000 EJECT 06740000 * 06760000 BEGINF LA FMTPTR,1(0,FMTPTR) BUMP FORMAT POINTER 06780000 SCAN1 ST FMTPTR,LSTGRP SAVE POINTER FOR REPEATS 06800000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 06820000 * 06840000 GRPCNT IC BYTER,1(0,FMTPTR) 06860000 STC BYTER,GCOUNT SAVE GROUP COUNT 06880000 STC BYTER,GCSAVE 06900000 LA FMTPTR,2(0,FMTPTR) BUMP FORMAT POINTER 06920000 BC ALWAYS,SCAN1 06940000 * 06960000 FLDCNT MVC FCOUNT(1),1(FMTPTR) SAVE FIELD COUNT 06980000 SCAN2 LA FMTPTR,2(0,FMTPTR) BUMP FORMAT POINTER 07000000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 07020000 * 07040000 PSCALE MVC SCALEF(1),1(FMTPTR) SAVE SCALE FACTOR 07060000 BC ALWAYS,SCAN2 07080000 * 07100000 COLUMN IC BYTER,1(0,FMTPTR) GET COLUMN POSITION 07120000 BCTR BYTER,0 07140000 L SPILL,BUFADD ADD START OF RECORD 07160000 AR SPILL,BYTER AND COLUMN POSITION. 07180000 CR SPILL,BUFLIM COMPARE TO END OF RECORD 07200000 BC HIEQ,ERROR ERROR, COLUMN OUTSIDE RECORD. 07220000 C BUFPTR,BUFPTRHI IS CURRENT RECORD POINTER 6002 07230017 BC LOEQ,COL4 HIGHER THAN PREVIOUS HIGH? 6002 07240017 ST BUFPTR,BUFPTRHI IF SO, SAVE CURRENT PTR. 6002 07250017 COL4 LR BUFPTR,SPILL GET NEW RECORD POINTER. 6002 07260017 BC ALWAYS,SCAN2 07280000 * 07300000 XCNVRT IC BYTER,1(0,FMTPTR) PICKUP N 07320000 LA FMTPTR,2(0,FMTPTR) BUMP FORMAT POINTER 07340000 TM IOSWF,OUTPUT 07360000 BC ALL,XBLANK BRANCH IF OUTPUT 07380000 AR BUFPTR,BYTER BUMP RECORD POINTER BY N 07400000 CR BUFPTR,BUFLIM COMPARE TO END OF RECORD 07420000 BC HIGH,ERROR ERROR, SKIP PAST RECORD. 07440000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 07460000 XBLANK CR BUFPTR,BUFLIM COMPARE TO END OF RECORD 07480000 BC HIEQ,ERROR ERROR, BLANK PAST RECORD. 07500000 MVI 0(BUFPTR),C' ' MOVE IN BLANKS, ONE AT A TIME. 07520000 LA BUFPTR,1(0,BUFPTR) BUMP RECORD POINTER 07540000 BCT BYTER,XBLANK 07560000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 07580000 * 07600000 HCNVRT IC BYTER,1(0,FMTPTR) PICKUP N 07620000 LA FMTPTR,2(0,FMTPTR) BUMP FORMAT POINTER 07640000 LR SPILL,BUFLIM 07660000 SR SPILL,BUFPTR SUBTRACT POINTER FROM RECORD END 07680000 CR BYTER,SPILL ARE ENOUGH BYTES LEFT 07700000 BC HIGH,ERROR NO, ERROR. 07720000 BCTR BYTER,0 YES, PREPARE FOR EXECUTE. 07740000 TM IOSWF,OUTPUT 07760000 BC ALL,HCVOUT BRANCH IF OUTPUT 07780000 EX BYTER,MOVE1 MOVE CHARACTERS INTO FORMAT 07800000 BC ALWAYS,HCVRET 07820000 HCVOUT EX BYTER,MOVE2 MOVE CHARACTERS FROM FORMAT 07840000 HCVRET LA BUFPTR,1(BYTER,BUFPTR) BUMP RECORD POINTER 07860000 LA FMTPTR,1(BYTER,FMTPTR) BUMP FORMAT POINTER 07880000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 07900000 * 07920000 GRPEND LA FMTPTR,1(0,FMTPTR) BUMP FORMAT POINTER 07940000 TM GCOUNT,X'FE' IS THERE A GROUP COUNT 07960000 BC NONE,SCAN NO, CONTINUE FORMAT SCAN. 07980000 L FMTPTR,LSTGRP YES, RESET FORMAT POINTER. 08000000 IC BYTER,GCOUNT 08020000 BCTR BYTER,0 REDUCE GROUP COUNT 08040000 STC BYTER,GCOUNT 08060000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 08080000 * 08100000 SLASHR BAL CALLER,RECORD INPUT OR OUTPUT ONE RECORD 08120000 LA FMTPTR,1(0,FMTPTR) BUMP FORMAT POINTER 08140000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 08160000 * 08180000 ENDFMT MVI EFMTSW,ON SET END-FORMAT SWITCH ON, 08200000 BC ALWAYS,LIST AND EXIT TO I/O LIST. 08220000 LSTRET BAL CALLER,RECORD INPUT OR OUTPUT ONE RECORD 08240000 MVC GCOUNT(1),GCSAVE RESET LAST GROUP COUNT 08260000 L FMTPTR,LSTGRP RESET FORMAT POINTER 08280000 BC ALWAYS,SCAN CONTINUE FORMAT SCAN 08300000 * 08320000 RECORD STM GRX,GRY,STASH SAVE ARGUMENT REGISTERS 08340000 TM IOSWF,OUTPUT 08360000 BC ALL,RECOUT BRANCH IF OUTPUT 08380000 MVI IOTYPF,READ SET INDICATOR FOR READ 08400000 BC ALWAYS,RECCOM 08420000 RECOUT MVI IOTYPF,RITE SET INDICATOR FOR WRITE 08440000 LR GRX,BUFPTR 08460000 C GRX,BUFPTRHI IS CURRENT RECORD POINTER 6002 08480017 BC HIEQ,RECOUT1 LOWER THAN PREVIOUS HIGH? 6002 08500017 L GRX,BUFPTRHI IF SO, USE PREVIOUS HIGH. 6002 08520017 RECOUT1 XC BUFPTRHI(4),BUFPTRHI CLEAR BUFPTRHI. 6002 08540017 RECSIZ S GRX,BUFADD COMPUTE RECORD LENGTH 08560000 RECCOM L 1,DFIOCS ** 08580000 BALR 0,1 READ OR WRITE ONE RECORD 08600000 IOTYPF DC AL1(0) 08620000 DC AL1(NULL) 08640000 NOP 0 08650016 ST GRX,BUFADD SAVE START OF RECORD 08660000 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 08680000 LR BUFPTR,GRX INITIALIZE RECORD POINTER 08700000 LM GRX,GRY,STASH RESTORE ARGUMENT REGISTERS, 08720000 BCR ALWAYS,CALLER AND RETURN TO CALLER. 08740000 * 08760000 EJECT 08780000 * 08800000 FCNVRT LA BASE,0 SET FOR F-CONVERSION 08820000 BC ALWAYS,PARAM4 08840000 * 08860000 ECNVRT LA BASE,1 SET FOR E-CONVERSION 08880000 PARAM4 MVC PARAMS+1(2),1(FMTPTR) SET FORMAT WIDTH, DECIMALS. 08900000 MVC PARAMS+3(1),SCALEF SET CURRENT SCALE FACTOR 08920000 LA FMTPTR,3(0,FMTPTR) BUMP FORMAT POINTER 08940000 BC ALWAYS,COMMON 08960000 * 08980000 DCNVRT EQU ECNVRT 09000000 * 09020000 ICNVRT LA BASE,2 SET FOR I-CONVERSION 09040000 BC ALWAYS,PARAM2 09060000 * 09080000 ACNVRT LA BASE,3 SET FOR A-CONVERSION 09100000 PARAM2 MVC PARAMS+1(1),1(FMTPTR) SET FORMAT WIDTH 09120000 MVC PARAMS+2(2),NOPB2 AND A TWO-BYTE NOP. 09140000 LA FMTPTR,2(0,FMTPTR) BUMP FORMAT POINTER 09160000 * 09180000 LCNVRT EQU FMTERR 09200000 * 09220000 GCNVRT EQU FMTERR 09240000 * 09260000 COMMON SLA BASE,3 ADJUST TO DOUBLE-WORD BOUNDARY 09280000 TM IOSWF,OUTPUT 09300000 BC NONE,EFMTCK BRANCH IF INPUT 09320000 LA BASE,4(0,BASE) ADJUST TO 2ND HALF OF DOUBLEWORD 09340000 EFMTCK TM EFMTSW,ON 09360000 BC NONE,LIST BRANCH IF NOT END OF FORMAT 09380000 MVI EFMTSW,OFF SET END-FORMAT SWITCH OFF, 09400000 BAL CALLER,FMTCAL AND SKIP LIST EXIT. 09420000 * 09440000 LIST TM ARRSW,ON 09460000 BC ALL,BUMPER BRANCH IF ARRAY 09480000 STM 4,12,KEEP SAVE OWN REGISTERS 09500000 LM 0,12,SAVE RESTORE MAIN REGISTERS 09520000 BCR ALWAYS,R EXIT TO I/O LIST 09540000 * 09560000 EJECT 09580000 * 09600000 FIOLF STM 0,12,SAVE SAVE MAIN REGISTERS 09620000 MVC STASH(4),0(R) STASH LIST PARAMETERS 09640000 LA R,4(0,R) COMPUTE RETURN ADDRESS 09660000 MVC PARAMS(1),STASH SET LENGTH OF I/O LIST ITEM 09680000 NI STASH,X'00' 09700000 NI STASH+1,X'0F' 09720000 OC STASH(4),LAGRX CREATE LA TO GRX 09740000 EX 0,STASH PICKUP ITEM ADDRESS IN GRX 09760000 LM 4,12,KEEP RESTORE OWN REGISTERS 09780000 BAL CALLER,FMTCAL CONVERT CURRENT LIST ITEM 09800000 BC ALWAYS,LIST RETURN TO I/O LIST 09820000 * 09840000 FIOAF STM 0,12,SAVE SAVE MAIN REGISTERS 09860000 LM 4,12,KEEP RESTORE OWN REGISTERS 09880000 MVC STASH(8),0(R) STASH LIST PARAMETERS 09900000 LA R,8(0,R) COMPUTE RETURN ADDRESS 09920000 MVC PARAMS(1),STASH+4 SET LENGTH OF ARRAY ITEMS 09940000 NI STASH+4,X'00' 09960000 NI STASH+5,X'0F' 09980000 L LOOP,STASH+4 GET NUMBER OF ITEMS IN ARRAY 10000000 L GRX,STASH PICKUP ADDRESS OF ARRAY 10020000 SR ADDER,ADDER 10040000 IC ADDER,PARAMS USE ITEM LENGTH AS INCREMENT 10060000 MVI ARRSW,ON SET ARRAY SWITCH ON 10080000 RECALL BAL CALLER,FMTCAL CONVERT CURRENT LIST ITEM 10100000 BUMPER AR GRX,ADDER STEP THROUGH ARRAY, 10120000 BCT LOOP,RECALL UNTIL IT IS EXHAUSTED. 10140000 MVI ARRSW,OFF SET ARRAY SWITCH OFF 10160000 BC ALWAYS,LIST RETURN TO I/O LIST 10180000 * 10200000 EJECT 10220000 * 10240000 FMTCAL TM EFMTSW,ON 10260000 BC ALL,LSTRET BRANCH IF END OF FORMAT 10280000 IC BYTER,PARAMS+1 10300000 LTR BYTER,BYTER 10320000 BC ZMINUS,TSTCNT WIDTH = 0 10340000 LA SPILL,0(BYTER,BUFPTR) RECORD POINTER PLUS WIDTH 10360000 CR SPILL,BUFLIM COMPARE TO END OF RECORD 10380000 BC HIGH,ERROR ERROR, AT END OF RECORD. 10400000 LR GRY,BUFPTR PICKUP BUFFER LOCATION 10420000 L 1,ADCONS(BASE) 10440000 BALR 0,1 BRANCH TO CONVERSION ROUTINE 10460000 PARAMS DC AL4(0) 10480000 LA BUFPTR,0(BYTER,BUFPTR) UPDATE RECORD POINTER 10500000 TSTCNT TM FCOUNT,X'FE' IS THERE A FIELD COUNT 10520000 BC NONE,SCAN NO, CONTINUE FORMAT SCAN. 10540000 IC BYTER,FCOUNT 10560000 BCTR BYTER,0 YES, REDUCE FIELD COUNT. 10580000 STC BYTER,FCOUNT 10600000 BCR ALWAYS,CALLER RETURN TO CALLER 10620000 * 10640000 FENDF STM 0,12,SAVE SAVE MAIN REGISTERS 10660000 LM 4,12,KEEP RESTORE OWN REGISTERS 10680000 TM IOSWF,OUTPUT 10700000 BC NONE,EXITF BRANCH IF INPUT 10720000 BAL CALLER,RECORD OUTPUT ONE RECORD 10740000 EXITF LM 0,12,SAVE RESTORE MAIN REGISTERS 10760000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 10780000 * 10800000 ERROR TM IOSWF,OUTPUT 10820000 BC NONE,ERRORX BRANCH IF INPUT 10840000 BAL CALLER,RECORD OUTPUT ONE RECORD 10860000 ERRORX LA R,212 GIVE MESSAGE 212 10880016 B COMERRHN 10900016 * 10920000 EJECT 10940000 * CALLING SEQUENCES 10960000 * 10980000 * CNOP 0,4 11000000 * L L,=V(IBCOM) 11020000 * BAL R,20(L) FRDNF 11040000 * OR 11060000 * BAL R,24(L) FWRNF 11080000 * DC XL1'FLAG',AL3(UNIT) 11100000 * WHERE FLAG = 0 IF UNIT IS AN INTEGER CONSTANT, 11120000 * ANY OTHER BIT PATTERN IF UNIT IS A VARIABLE. 11140000 * 11160000 * L L,=V(IBCOM) 11180000 * BAL R,28(L) FIOLN 11200000 * DC XL1'LENGTH',XL0.4'0',XL0.4'X',XL0.4'B',XL1.4'D' 11220000 * WHERE LENGTH = SIZE (IN BYTES) OF THE ITEM, 11240000 * AND X, B, D ARE THE INDEX, BASE, DISPLACEMENT 11260000 * WHICH SPECIFY THE ADDRESS OF THE ITEM. 11280000 * 11300000 * L L,=V(IBCOM) 11320000 * BAL R,32(L) FIOAN 11340000 * DC AL4(ADDRESS) 11360000 * DC XL1'LENGTH',AL3(ELEMENTS) 11380000 * WHERE ADDRESS = LOCATION OF THE ARRAY, 11400000 * LENGTH = SIZE (IN BYTES) OF EACH ITEM, 11420000 * ELEMENTS = NUMBER OF ITEMS IN THE ARRAY. 11440000 * 11460000 * L L,=V(IBCOM) 11480000 * BAL R,36(L) FENDN 11500000 * 11520000 SPACE 3 11540000 * ERROR CONDITIONS 11560000 * INPUT LIST LONGER THAN LOGICAL RECORD. 11580000 * ATTEMPT TO OUTPUT MORE THAN 255 RECORDS IN A LOGICAL RECORD. 11600000 * FOR OTHERS, SEE FIOCS ROUTINE. 11620000 EJECT 11640000 * 11660000 FRDNF MVI IOSWF,NONINP SET FOR NON-FORMATTED INPUT 11680016 BC ALWAYS,RWCOMN 11700000 * 11720000 FWRNF MVI IOSWF,NONOUT SET FOR NON-FORMATTED OUTPUT 11740016 SPACE 3 11760000 * 11780000 RWCOMN STM 0,12,SAVE SAVE MAIN REGISTERS 11800000 BAL BASE,IO GO TO INITIALIZE 11900016 LR BUFLOC,GRX SET BUFFER ADDRESS 12000016 SR BTM,BTM INITIALIZE BYTE REGISTER 174 12020017 TM IOSWF,OUTPUT IS THIS A WRITE ? 174 12040017 BC NONE,SETREC NO LEAVE AS MOVE3 - READ 174 12060017 LA BYTER,6(0,0) YES SET FOR MOVE4 WRITE 174 12080017 SETREC SR RECCNT,RECCNT INITIALIZE RECORD COUNT 174 12100017 STM 4,12,KEEP SAVE OWN REGISTERS 12120000 LM 0,12,SAVE RESTORE MAIN REGISTERS 12140000 BC ALWAYS,4(0,R) EXIT TO I/O LIST 12200000 * 12220000 EJECT 12240000 * 12260000 FIOLN STM 0,12,SAVE SAVE MAIN REGISTERS 12280000 MVC STASH(4),0(R) STASH LIST PARAMETERS 12300000 MVC FQUALS(1),STASH SET LENGTH OF I/O LIST ITEM 12320000 NI STASH,X'00' 12340000 NI STASH+1,X'0F' 12360000 OC STASH(4),LAGRX CREATE LA TO GRX 12380000 EX 0,STASH PICKUP ITEM ADDRESS IN GRX 12400000 LM 4,12,KEEP RESTORE OWN REGISTERS 12420000 MVI GOWHR,OFF SET RTN TO FIOLN FR NEWREC 174 12424017 IC BTM,FQUALS ITEM LENGTH 174 12428017 LR BTG,BUFLIM END OF BUF - LOC IN BUF 174 12432017 SR BTG,BUFPTR = BYTES LEFT IN BUF 174 12436017 CR BTG,BTM BYTES IN BUF < ITEM SIZE ? 174 12440017 BL CHECK YES - CHECK FOR SPLIT READ 174 12444017 MOVCOM BCTR BTM,0 ADJUST FOR MVC COUNT 174 12448017 MOVOUT EX BTM,MOVE3(BYTER) MAKE THE MOVE 174 12452017 LA BUFPTR,1(BTM,BUFPTR) UPDATE BUFFER POINTER 174 12456017 STM 4,12,KEEP SAVE OWN REGISTERS 12460000 LM 0,12,SAVE RESTORE MAIN REGISTERS 12480000 BC ALWAYS,4(0,R) RETURN TO I/O LIST 12500000 * 12520000 FIOAN STM 0,12,SAVE SAVE MAIN REGISTERS 12540000 LM 4,12,KEEP RESTORE OWN REGISTERS 12560000 MVC STASH(8),0(R) STASH LIST PARAMETERS 12580000 L GRX,STASH ADDRESS OF ARRAY 174 12584017 L BTM,STASH+4 SIZE, TYPE & # OF ARRAY ITEMS 174 12588017 N BTM,MASK2 # OF ITEMS ONLY 174 12592017 MVC ITEM+1(1),4(R) SIZE OF ITEM 174 12596017 MH BTM,ITEM SIZE OF ARRAY 174 12600017 LH GRY,ITEM SIZE OF ITEM 174 12604017 LA R256,256(0) LARGEST MVC SIZE 256 174 12608017 LNR CALLER,GRY SET CONSTANT FOR FULL ITEM 174 12620017 ST CALLER,FULLIT SAVE CONSTANT 174 12624017 LOOPER LR BTG,BUFLIM END OF BUF - LOC IN BUF 174 12628017 SR BTG,BUFPTR = BYTES LEFT IN BUF 174 12632017 CR BTG,GRY BYTES IN BUF < ITEM SIZE ? 174 12636017 BNL DARRAY NO BYPASS SPLIT REC TEST 174 12640017 MVI GOWHR,ON SET RTN TO LOOPER FR NEWREC 174 12644017 CHECK LTR BYTER,BYTER IS THIS A WRITE ? 174 12648017 BNZ NEWREC YES - GET NEW BUFFER 174 12652017 TM DASW,ON DIRECT ACCESS ? 174 12656017 BC ALL,NEWREC YES - NO SPLIT READ 174 12660017 LTR BTG,BTG IS BUFFER FINISHED ? 174 12664017 BZ NEWREC YES - GET NEW BUFFER 174 12668017 RDSPLT BCTR BTG,0 ADJUST FOR MVC COUNT 174 12672017 EX BTG,MOVE3 READ 174 12676017 LA GRX,1(BTG,GRX) UPDATE ARRAY ADDRESS 174 12680017 SR BTM,BTG UPDATE BYTES TO MOVE 174 12684017 BCT BTM,NEWREC GET NEW BUFFER 174 12688017 DARRAY LR B,BTG MOVE SIZE = BYTES IN BUF 174 12692017 CR BTM,BTG RECORD > REMAINING BUFFER ? 174 12696017 BH ARRAY YES USE BYTES IN BUF SIZE 174 12700017 LR B,BTM NO USE RECORD SIZE 174 12704017 ARRAY CR B,R256 BYTES TO MOVE > 256 174 12708017 BNH LNTHOK NO BYTES TO MOVE = MVC 174 12712017 LR B,R256 YES 256 = MVC 174 12716017 LNTHOK LTR BYTER,BYTER IS THIS A READ ? 174 12720017 BNZ DORITE NO SET FOR WRITE 174 12724017 TM DASW,ON DIRECT ACCESS READ ? 174 12728017 BC LOEQ,SPLTYS NO DO SEQ READ 174 12732017 DORITE N B,FULLIT ADJUST FOR FULL ITEM 174 12736017 SPLTYS BCTR B,0 ADJUST FOR MVC COUNT 174 12740017 EX B,MOVE3(BYTER) MAKE THE MOVE 174 12744017 LA BUFPTR,1(B,BUFPTR) UPDATE BUFFER POINTER 174 12748017 LA GRX,1(B,GRX) UPDATE ARRAY POINTER 174 12752017 SR BTM,B UPDATE # OF BYTES TO MOVE 174 12756017 BCT BTM,LOOPER MORE TO MOVE ? YES LOOP 174 12760017 STM 4,12,KEEP SAVE OWN REGISTERS 12800000 LM 0,12,SAVE RESTORE MAIN REGISTERS 12820000 BC ALWAYS,8(0,R) RETURN TO I/O LIST 12840000 * 12860000 EJECT 12880000 * 13160000 NEWREC STM GRX,GRY,STASH SAVE ARGUMENT REGISTERS 13180000 LTR BYTER,BYTER IS THIS A WRITE ? 174 13200017 BNZ OUTREC GO TO WRITE RECORD 174 13220017 MVI IOTYPN,READ SET INDICATOR FOR READ 13260000 TM DASW,ON WAS THIS A DASD I/O REQUEST ** 13280000 BC 1,COMREC BR IF IT IS ** 13300000 SH BUFLOC,FOUR POINT TO THE SCW SIR1 13320000 TM 2(BUFLOC),X'01' TEST SCC IF SOMETHING SIR1 13340000 BO COMREC FOLLOWS, YES OK, NO ERROR SIR1 13360000 * SIR1 13380000 LA R,213 GIVE MESSAGE 213 13400016 B COMERRHN 13420016 * SIR1 13440000 OUTREC EQU * SIR1 13460000 MVI IOTYPN,RITE SET INDICATOR FOR WRITE 174 13470017 SR BUFPTR,BUFLOC COMPUTE NUMBER OF BYTES OUTPUT, 13480000 LR GRX,BUFPTR AND PLACE IT IN GRX. 13500000 TM DASW,ON IS THIS A DASD I/O REQUEST ** 13520000 BC ALL,COMREC BR IF IT IS ** 13540000 SH BUFLOC,FOUR POINT TO THE SCW SIR1 13560000 OI 2(BUFLOC),X'01' INDICATE SOMETHING FOLLOWS SIR1 13580000 LTR RECCNT,RECCNT DOES ANYTHING PRECEDE SIR1 13600000 BZ INCRM NO,BRANCH SIR1 13620000 OI 2(BUFLOC),X'02' INDICATE SOMETHING PRECEDES SIR1 13640000 INCRM LA RECCNT,1(0,RECCNT) SIR1 13660000 COMREC L 1,DFIOCS ** 13680000 BALR 0,1 READ OR WRITE ONE RECORD 13700000 IOTYPN DC AL1(0) 13720000 DC AL1(NULL) 13740000 NOP 0 FIOCS RETURNS AT +6 13750016 LR BUFLOC,GRX SAVE START OF RECORD 13760000 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 13780000 LR BUFPTR,GRX GET BEGINNING OF BUFFER ADDR.** 13800000 DANOGRN LM GRX,GRY,STASH RESTORE ARGUMENT REGISTERS 13820000 TM GOWHR,ON CALLED FR FIOLN OR FIOAN ? 174 13830017 BC NONE,MOVCOM RTN TO MOVCOM (FIOLN CASE) 174 13840017 BC ALWAYS,LOOPER RTN TO LOOPER (FIOAN CASE) 174 13850017 * 13860000 EJECT 13880000 * 13900000 FENDN STM 0,12,SAVE SAVE MAIN REGISTERS 13920000 LM 4,12,KEEP RESTORE OWN REGISTERS 13940000 TM IOSWF,OUTPUT 13960016 BC ALL,ENDOUT BRANCH IF OUTPUT 13980000 ENDTST EQU * SIR1 14000000 TM DASW,ON IS THIS A DASD I/O REQUEST ** 14020000 BC 1,EXITN BR IF IT IS ** 14040000 TESTEND SH BUFLOC,FOUR POINT TO SCW SIR1 14060000 TM 2(BUFLOC),X'01' DOES ANY FOLLOW(TEST SCC) SIR1 14080000 BZ EXITN NO, ALL DONE(BRANCH)YES,READSIR1 14100000 L 1,VFIOCS 14120000 BALR 0,1 NO, KEEP READING UNTIL IT HAS. 14140000 DC AL1(READ) 14160000 DC AL1(NULL) 14180000 NOP 0 FIOCS RETURNS AT +6 14190016 LR BUFLOC,GRX GET START OF RECORD, 14200000 B TESTEND AND REPEAT TEST. SIR1 14220000 ENDOUT SR BUFPTR,BUFLOC COMPUTE NUMBER OF BYTES OUTPUT, 14240000 LR GRX,BUFPTR AND PLACE IT IN GRX. 14260000 TM DASW,ON IS THIS A DASD I/O REQUEST ** 14280000 BC 1,DAOUT BR IF IT IS ** 14300000 SH BUFLOC,FOUR POINT TO THE SCW SIR1 14320000 LTR RECCNT,RECCNT ANY SEGMENTS BEFORE THIS ONESIR1 14340000 BZ DAOUT NO BRANCH SIR1 14360000 OI 2(BUFLOC),X'02' YES INDICATE THIS IN THE SCCSIR1 14380000 DAOUT L 1,DFIOCS GET I/O INTERFACE ADDRESS ** 14400000 BALR 0,1 WRITE LAST RECORD 14420000 DC AL1(RITE) 14440000 DC AL1(NULL) 14460000 NOP 0 FIOCS RETURNS AT +6 14470016 EXITN LM 0,12,SAVE RESTORE MAIN REGISTERS 14480000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 14520000 * 14540000 EJECT 14560000 * CALLING SEQUENCE 14580000 * CNOP 0,4 14600000 * L L,=V(IBCOM) 14620000 * BAL R,40(L) FBKSP 14640000 * DC XL1'FLAG',AL3(UNIT) 14660000 * WHERE FLAG = 0 IF UNIT IS AN INTEGER CONSTANT, 14680000 * ANY OTHER BIT PATTERN IF UNIT IS A VARIABLE. 14700000 SPACE 3 14720000 * ERROR CONDITIONS 14740000 * SEE FIOCS ROUTINE 14760000 SPACE 3 14780000 * 14800000 FBKSP STM 0,4,SAVE SAVE MAIN REGISTERS 14820000 BSP EQU * SIR1 14840000 LR GRX,R PICKUP PARAMETER POINTER 14860000 L 1,VFIOCS 14880000 BALR 0,1 BACKSPACE RECORD 14900000 DC AL1(CTRL) 14920000 DC AL1(BKSP) 14940000 NOP 0 FIOCS RETURNS AT +6 15370016 EXITB LM 0,4,SAVE RESTORE MAIN REGISTERS 15380000 BC ALWAYS,4(0,R) RETURN TO MAIN PROGRAM 15400000 * 15420000 EJECT 15440000 * CALLING SEQUENCE 15460000 * CNOP 0,4 15480000 * L L,=V(IBCOM) 15500000 * BAL R,44(L) FRWND 15520000 * OR 15540000 * BAL R,48(L) FEOFM 15560000 * DC XL1'FLAG',AL3(UNIT) 15580000 * WHERE FLAG = 0 IF UNIT IS AN INTEGER CONSTANT, 15600000 * ANY OTHER BIT PATTERN IF UNIT IS A VARIABLE. 15620000 SPACE 3 15640000 * ERROR CONDITIONS 15660000 * SEE FIOCS ROUTINE 15680000 SPACE 3 15700000 * 15720000 FRWND MVI CTLSW,RWND SET FOR REWIND 15740000 BC ALWAYS,CTLCOM 15760000 * 15780000 FEOFM MVI CTLSW,EOFM SET FOR WRITE TAPE MARK 15800000 SPACE 3 15820000 * 15840000 CTLCOM STM 0,3,SAVE SAVE MAIN REGISTERS 15860000 LR GRX,R PICKUP PARAMETER POINTER 15880000 L 1,VFIOCS 15900000 BALR 0,1 PERFORM INDICATED CONTROL 15920000 DC AL1(CTRL) 15940000 CTLSW DC AL1(0) 15960000 NOP 0 FIOCS RETURNS AT +6 15970016 LM 0,3,SAVE RESTORE MAIN REGISTERS 15980000 BC ALWAYS,4(0,R) RETURN TO MAIN PROGRAM 16000000 * 16020000 EJECT 16040000 * 16060000 * DATA AND STORAGE AREAS 16080000 * 16100000 ADCONS DS 0F 16120000 DC AL4(FCVFI) 16140000 DC AL4(FCVFO) 16160000 DC AL4(FCVEI) 16180000 VFCVEO DC AL4(FCVEO) 16200000 DC AL4(FCVII) 16220000 VFCVIO DC AL4(FCVIO) 16240000 DC AL4(FCVAI) 16260000 VFCVAO DC AL4(FCVAO) 16280000 VFCVDO EQU VFCVEO 16300000 SPACE 3 16380000 * 16400000 KEEP DS 9F OWN REGISTER STORAGE 16440000 FULLIT DS 1F CONST FOR EVEN ITEM WRITE 174 16442017 MASK2 DC X'000FFFFF' CLEARS 1ST 12 BITS OF REG 174 16444017 ITEM DC AL2(0) HOLDS LENGTH OF ARRAY ITEM 174 16446017 GOWHR DC AL1(0) RTN SW FROM NEWREC 174 16448017 DS 0D 16450016 STASH DS 2F LIST PARAMETERS 16460000 * THIS CONSTANT MUST DIRECTLY FOLLOW STASH DS 2F 16464016 DC A(ERRORNO) 16468016 ERRORNO DC F'0' 16472016 CON241 DC H'241' 16476016 EJECT 16940000 * CALLING SEQUENCE 16960000 * L L,=V(IBCOM) 16980000 * BAL R,52(L) FSTOP 17000000 * OR 17020000 * BAL R,56(L) FPAUS 17040000 * DC AL1(LENGTH) 17060000 * DC C'TEXT' 17080000 * WHERE LENGTH IS THE NUMBER OF SUBSEQUENT TEXT BYTES, 17100000 * AND TEXT IS A NUMBER OR MESSAGE IN ALPHAMERIC FORM. 17120000 SPACE 3 17140000 * ERROR CONDITIONS 17160000 * NONE 17180000 SPACE 3 17200000 * 17220000 * WRITE TO OPERATOR 17240000 * 17260000 DS 0H 17280000 FSTOP MVI EXITSW,ON SET FOR MONITOR EXIT 17300000 BC ALWAYS,WTOCOM 17320000 * 17340000 FPAUS MVI EXITSW,OFF SET VS. MONITOR EXIT 17360000 NI PAUSE,X'BF' TURN OFF COMPLETED FLAG(BIT 1) 8460 17380000 * IN ECB NAMED PAUSE 8460 17400000 SPACE 3 17420000 * 17440000 WTOCOM STM 14,5,SAVERR SAVE MAIN REGISTERS 17460000 BALR BASE,0 LOAD BASE REGISTER 17480000 USING *,BASE 17500000 TM EXITSW,ON 17520000 BC ALL,STOPPR BRANCH IF STOP 17540000 MVC WTOMES+5(9),MPAWS 17560000 LA 1,OREPLY 17580000 BC ALWAYS,GETCNT 17600000 STOPPR MVC WTOMES+5(9),MSTOP 17620000 LA 1,MESLEN-1 18035 17640018 GETCNT SR SPILL,SPILL 17660000 IC SPILL,0(0,R) GET NUMBER OF BYTES IN MESSAGE 17680000 LR GRY,SPILL 17700000 CH SPILL,MESMAX 17720000 BC LOEQ,WTOMOV BRANCH IF WITHIN LIMITS 17740000 LH GRY,MESMAX SET TO MAXIMUM LENGTH 17760000 WTOMOV BCTR GRY,0 17780000 EX GRY,MOVEO MOVE MESSAGE INTO CALL 17800000 LA GRX,19(0,GRY) 18035 17807018 STH GRX,MESLEN-1 18035 17814018 A GRX,MESADR 18035 17821018 TM EXITSW,ON 18035 17828018 BC ALL,STOPCD BRANCH FOR STOP CODE 18035 17835018 MVC 0(2,GRX),DESCD2 18035 17842018 MVI 2(GRX),X'80' PAUSE CODE INSERTED 18035 17849018 BC ALWAYS,PADDER 18035 17856018 STOPCD MVC 0(2,GRX),DESCD1 18035 17863018 MVI 2(GRX),X'40' STOP ROUTING CODE 18035 17870018 PADDER MVI 3(GRX),X'00' STOP CODE INSERTED 18035 17877018 B WTOSVC 18035 17884018 CNOP 0,4 18035 17891018 OREPLY DC AL1(1) LENGTH OF REPLY 18035 17898018 DC AL3(ANSWER) REQUESTOR'S REPLY BUFFER ADD 18035 17905018 DC AL4(PAUSE) REQUESTOR'S REPLY ECB POINTER 18035 17912018 DC AL1(0) ZERO 18035 17919018 MESLEN DC AL1(0) MESSAGE LENGTH FIELD 18035 17926018 DC X'80' MCSFLAGS-ROUTING CODES EXIT 18035 17933018 DC AL1(0) 18035 17940018 WTOMES DC C'IHC00' 18035 17947018 DC 19C' ' 18035 17954018 MESMAX DC H'6' 18035 17961018 DESCD1 DC X'02' STOP DESCRIPTOR CODE 18035 17968018 DC X'00' 18035 17975018 DESCD2 DC X'40' PAUSE DESCRIPTOR CODE 18035 17982018 DC X'00' 18035 17989018 MESADR DC A(MESLEN-1) 18035 17996018 WTOSVC DS 0H 18020000 SVC 35 GIVE WTO / WTOR 18040000 TM EXITSW,ON 18060000 BC NONE,PAUSER BRANCH IF PAUSE 18080000 LM 14,5,SAVERR RESTORE MAIN REGISTERS 18100000 BAL R,68(0,L) TERMINATE JOB 18120000 DC AL2(0) 18140000 * 18160000 PAUSER L R,SAVERR 18180000 LA R,1(SPILL,R) COMPUTE RETURN ADDRESS 18200000 ST R,SAVERR 18220000 WAIT 1,ECB=PAUSE 18240000 LM 14,5,SAVERR RESTORE MAIN REGISTERS 18260000 DROP BASE 18280000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 18300000 * 18320000 EJECT 18340000 * CALLING SEQUENCE 18360000 * LA 1,PRAMS 18370016 * L L,=V(IBCOM#) 18380016 * B 60(0,L) 18390016 * WHERE 18400016 * PRAMS DC A(MSG) OR DC A(0) 18410016 * DC A(0) 18420016 * A(ERRORNO) 18430016 * ERRORNO DC A(NUM) NUM=ERROR CONDITION NUMBER 18440016 IHCERRM EQU * 18450016 ERRMON EQU * 18460016 USING *,L 18470016 L L,VIBCOM SET UP REG. ADDRESSABILITY 18480016 USING IBCOM#,L 18490016 IBFERR L R,8(0,1) GET ERROR MESSAGE NUMB. ADDRESS 18500016 L 2,0(0,R) GET ERROR NUMBER 18510016 CVD 2,STASH CONVERT IT TO DECIMAL 18520016 LR SPILL,1 SAVE PARAM LIST ADDRESS 18530016 UNPK ERRMES+4(3),STASH+6(2) UNPACK ERROR NUMB. TO EBCDIC 18540016 OI ERRMES+6,X'F0' AND SET PROPER ZONING. 18660000 LA GRX,OUTPTR SELECT SYSTEM OUTPUT DEVICE 18680000 L 1,VFIOCS 18700000 BALR 0,1 INITIALIZE FILE 18720000 DC AL1(INIT) 18740000 DC AL1(FMTOUT) 18760000 NOP 0 FIOCS RETURNS AT +6 18770016 MVC 0(8,GRX),ERRMES MOVE MESSAGE INTO BUFFER 18780000 LA BASE,8 SET LENGTH TO 8 18782016 CLI 3(R),216 IF ERROR NUMBER 216 18784016 BE MSGGIV 18786016 CLI 3(R),218 OR 218 18788016 BE MSGGIV 18790016 CLI 3(R),230 OR 230 18792016 BE MSGGIV 18794016 CLC 2(2,R),CON241 OR NUMBER GREATER THAN 240 18796016 BL GOPRINT 18798016 MSGGIV L 1,0(0,SPILL) PRINT OUT MESSAGE ALSO. 18800016 L BASE,0(0,1) GET ADDR OF MESSAGE AND ITS 18802016 CR BASE,GRY LENGTH. IF LENGTH > THAN BUFFER 18804016 BL GOTOPR THEN USE BUFFER LENGTH 18806016 LR BASE,GRY 18808016 GOTOPR LR GRY,BASE 18810016 BCTR GRY,0 SET FOR EXECUTING MOVE 18812016 EX GRY,MOVEFERR MOVE MESSAGE TO BUFFER 18814016 CLI 3(R),218 IF MESSAGE 218 18816016 BNE GOPRINT NO, BRANCH 18818016 LA 0,4(0,BASE) YES FREE STORAGE FOR MESSAGE 18820016 LR GRY,L 18822016 FREEMAIN R,LV=(0),A=(1) 18824016 LR L,GRY 18826016 GOPRINT LR GRX,BASE SET LENGTH OF MESSAGE 18831016 L 1,VFIOCS 4659 18836014 BALR 0,1 WRITE THE MESSAGE 18840000 DC AL1(RITE) 18860000 DC AL1(NULL) 18880000 NOP 0 FIOCS RETURNS AT +6 18900016 BAL R,68(0,L) TERMINATE JOB 18920000 DC AL2(16) 18940000 * 18960000 MOVEFERR MVC 1(1,GRX),4(1) 18970016 EJECT 18980000 * CALLING SEQUENCE 19000000 * L L,=V(IBCOM) 19020000 * BAL R,64(L) IBFINT 19040000 SPACE 3 19060000 * ERROR CONDITIONS 19080000 * NONE 19100000 SPACE 3 19120000 * 19140000 * INITIALIZATION AT BEGINNING OF PROBLEM PROGRAM 19160000 * 19180000 IBFINT STM 13,5,REG13 SAVE REGISTERS 19200000 BALR BASE,0 LOAD BASE REGISTER 19220000 USING *,BASE 19240000 SPIE ARITH,(9,11,12,13,15) 19260000 ST 1,PICAHOLD 19270014 L 1,VFIOCS 24793 19271019 LR 4,GRX 24793 19272019 LA GRX,OUTPTR PARAMS TO OPEN OBJ ERR UNIT 24793 19273019 BALR 0,1 24793 19274019 DC XL2'00FF' 24793 19275019 NOP 0 24793 19276019 LR GRX,4 24793 19277019 LM 14,5,SAVERR RESTORE REGISTERS 19280000 DROP BASE 19300000 BCR ALWAYS,R RETURN TO CALLER 19320000 * 19340000 SPACE 3 19360000 * 19380000 * ARITHMETIC PROGRAM INTERRUPT 19400000 * 19420000 USING *,L 19440000 ARITH MVI OPSW+27,C'P' INITIALIZE MESSAGE MD91 19446014 STM 3,13,SAVERR+12 19452014 MVC SAVERR(12),20(1) 19458014 MVC SAVERR+56(8),12(1) 19464014 L R8,VIBCOM 19470014 LR R9,1 19476014 LH SPILL,6(0,1) GET INTERRUPTION CODE 19482014 SH SPILL,SIXE 19488014 SLA SPILL,2 POSITION TO WORD BOUNDARY 19494014 BZ LDADC BRANCH ON SPEC INT TO AVOID 4648X19500014 IGNORE SWITCH TEST 19506014 CH SPILL,MOST 19512014 BC HIEQ,RETURN BRANCH IF NOT IN TABLE 19518014 TM INTSW,ON 19524014 BO FIX BRANCH IF IGNORE SWITCH ON HWRE 19530014 LDADC EQU * 4648 19536014 BC ALWAYS,TRAPS(SPILL) BRANCH TO APPROPRIATE ROUTINE 19542014 * 19548014 TRAPS DS 0D 19554014 REGHOLD DS D 19560014 BC ALWAYS,FXOVF FIXED-POINT OVERFLOW 19566014 BC ALWAYS,FXDVC FIXED-POINT DIVIDE 19572014 BC ALWAYS,DCOVF DECIMAL OVERFLOW 19578014 BC ALWAYS,DCDVC DECIMAL DIVIDE 19584014 BC ALWAYS,FPOVF EXPONENT OVERFLOW 19590014 BC ALWAYS,FPUNF EXPONENT UNDERFLOW 19596014 BC ALWAYS,FPSIG SIGNIFICANCE 19602014 BC ALWAYS,FPDVC FLOATING-POINT DIVIDE 19608014 MOST DC AL2(*-TRAPS) 19614014 * 19620014 FPOVF MVI 72(8),ON 19626014 OI 122(R8),OVERFL 19632014 B FIX 19638014 * 19644014 FPUNF MVI 72(8),HALF SET O/U INDICATOR TO UNDERFLOW 19650014 OI 122(R8),UNDERFL 19656014 B FIX 19662014 * 19668014 DVCHK MVI 73(8),ON SET D-C INDICATOR ON 19674014 NI TEM+3,X'00' HWRE 19680014 B ALERT GO TO WRITE MESSAGE HWRE 19686014 SPACE 3 19692014 * 19698014 * HARDWARE CHANGE FIXUP ROUTINE 19704014 * 19710014 * 19716014 FIX CLI 7(1),X'0C' WAS INTERRUPT OVERFLOW HWRE 19722014 BNE UNTEST HWRE 19728014 LA SWT,1 INTERRUPTION WAS OVERFLOW HWRE 19734014 B FIND HWRE 19740014 UNTEST LA SWT,9 UNDERFLOW CODE HWRE 19746014 FIND L ADR,8(0,1) OBTAIN ADDRESS FROM OPPSW HWRE 19752014 OI TEM+3,X'FF' HWRE 19758014 SR ORER,ORER 19764014 SR R11,R11 INDICATOR FOR EXECUTE HWRE 19770014 LA DEC,2 19776014 SLR ADR,DEC POINT TO 2 BYTE INSTR ADDR HWRE 19782014 LTR ADR,ADR TEST FOR 4 BYTE INSTR 19788014 BNM SELECT 19794014 SLR ADR,DEC POINT TO 4 BYTE INSTR ADDR 19800014 SELECT CLI 0(ADR),X'44' WAS INSTRUCTION AN EXECUTE HWRE 19806014 BNE NOTEX HWRE 19812014 LA 1,SAVERR 19818014 LH SPILL,2(0,ADR) 19824014 SRDL SPILL,16 19830014 IC SPILL,1(0,ADR) 19836014 SLDL SPILL,16 19842014 LA R11,60 19848014 LA GRY,4095 19854014 NR GRY,SPILL 19860014 SRL SPILL,6 19866014 LA R0,2 19872014 EXLOOP SRL SPILL,4 19878014 LR DEC,R11 19884014 NR DEC,SPILL 19890014 BZ CLOSER 19896014 EX 0,ACTIONS 19902014 CLOSER BCT R0,EXLOOP 19908014 SRL SPILL,4 19914014 LR ADR,GRY 19920014 LR DEC,R11 19926014 NR DEC,SPILL 19932014 BZ NOMOD 19938014 IC ORER,3(DEC,1) 19944014 NOMOD IC R0,1(0,ADR) 19950014 OR ORER,R0 19956014 SPACE 3 19962014 NOTEX LA R0,3 INDEX FOR SHORT OPERATION HWRE 19968014 OI TEM+2,X'FF' 19974014 TM 0(ADR),X'10' TEST FOR SHORT OPERATION 19980014 BO SHORTOP 19986014 NI TEM+2,X'00' 19992014 LA R0,7 INDEX FOR LONG OPERATION HWRE 19998014 SHORTOP LA GRY,240 GENERAL PURPOSE MASK 20004014 AR SWT,R0 ADD INDICES TO DETERMINE INSTR TO EX HWRE 20010014 LTR R11,R11 20016014 BNE EXSTOR 20022014 IC ORER,1(0,ADR) OBTAIN R1,X2 OR R1,R2 FIELD OF INSTR 20028014 EXSTOR NR ORER,GRY ZERO X2 OR R2 FIELD OF INSTR 20034014 EX ORER,MODIFY HWRE 20040014 TM INTSW,ON 20046014 BO SETRG 20052014 ALERT LA GRX,OUTPTR SELECT SYSTEM OUTPUT DEVICE 20058014 L 1,AFIOCS 20064014 BALR 0,1 INITIALIZE FILE 20070014 DC AL1(INIT) 20076014 DC AL1(FMTOUT) 20082014 NOP 0 FIOCS RETURNS AT +6 20085016 MVC 0(40,GRX),OPSW SET CONSTANT PART OF MSG BNDR 20088014 LA GRY,40(0,GRX) UPDATE BUFFER POINTER BNDR 20094014 LR GRX,R9 20100014 LA GRX,4(0,GRX) POINT TO OPSW IN PIE 20106014 L 1,VFCVZO 20112014 BALR 0,1 CONVERT PSW TO HEX 20118014 DC AL1(8) 20124014 DC AL1(20) 20130014 LA GRX,60 GET NUMBER OF BYTES OUTPUT 20136014 CLI TEM+3,X'FF' 20142014 BNE MSGWRT 20148014 MVC 30(18,GRY),REGMSG 20154014 LA GRY,48(0,GRY) 20160014 LA GRX,REGHOLD 20166014 L 1,VFCVZO 20172014 BALR 0,1 20178014 DC AL1(8) 20184014 DC AL1(20) 20190014 LA GRX,108 20196014 CLI TEM+2,X'FF' 20202014 BNE MSGWRT 20208014 MVC 12(8,GRY),20(GRY) SHORT OP BLANK 2D HALF OF REG HWRE 20214014 MSGWRT L 1,AFIOCS 20220014 BALR 0,1 WRITE THE MESSAGE 20226014 DC AL1(RITE) 20232014 DC AL1(NULL) 20238014 NOP 0 FIOCS RETURNS AT +6 20241016 SKIPIT CLI TEM+3,X'FF' OVERFLOW OR UNDERFLOW 20244014 BNE RETURN IF NO SKIP FIXUP HWRE 20250014 SETRG CLI 7(R9),X'0D' WAS INTERRUPT UNDERFLOW 20256014 BE EXUN 20262014 EX ORER,MODIFY(SWT) ZERO OR MAXIMIZE REGISTER HWRE 20268014 EXUN LR SPILL,ORER 20274014 SRL SPILL,4 20280014 OR ORER,SPILL 20286014 CLI 7(R9),X'0D' 20292014 BNE TSIGN 20298014 EX ORER,MODIFY(SWT) 20304014 TM 0(ADR),X'0A' 20310014 BNO TSIGN 20316014 NI 8(R9),X'CF' 20322014 TSIGN TM REGHOLD,X'80' WAS SIGN NEGATIVE HWRE 20328014 BZ RETURN HWRE 20334014 EX ORER,SETSIGN MAKE REG HWRE 20340014 RETURN LM 3,13,SAVERR+12 20346014 BR 14 20352014 * CONSTANTS AND INSTRUCTIONS EXECUTED 20358014 MODIFY STD 0,REGHOLD HWRE 20364014 LE 0,MAX MAXIMIZE REGISTER HWRE 20370014 LD 0,MAX HWRE 20376014 SER 0,0 ZERO REGISTER HWRE 20382014 SIXE DC AL2(6) 20388014 SDR 0,0 HWRE 20394014 SETSIGN LNER 0,0 MAKE REGISTER NEGATIVE HWRE 20400014 ACTIONS AL GRY,0(DEC,1) 20406014 TEM DS F 20412014 DS 0D 20418014 MAX DC X'7FFFFFFFFFFFFFFF' LARGEST NUMBER 20424014 USING IBCOM#,L 20430014 SPACE 3 20500000 * 20520000 FXOVF EQU ALERT 20540000 FXDVC EQU DVCHK 20560000 DCOVF EQU ALERT 20580000 DCDVC EQU DVCHK 20600000 FPSIG EQU ALERT 20620000 FPDVC EQU DVCHK 20640000 * 20660000 EJECT 20680000 * CALLING SEQUENCE 20700000 * L L,=V(IBCOM) 20720000 * BAL R,68(L) IBEXIT 20740000 * DC AL2(CODE) 20760000 SPACE 3 20780000 * ERROR CONDITIONS 20800000 * NONE 20820000 SPACE 3 20840000 * 20860000 * JOB TERMINATION 20880000 * 20900000 IBEXIT BALR BASE,0 LOAD BASE REGISTER 20920000 USING *,BASE 20940000 LH SPILL,0(0,R) PICKUP RETURN CODE 20960000 L 1,AFIOCS 20980000 BALR 0,1 CLOSE ALL FILES 21000000 DC AL1(TERM) 21020000 DC AL1(NULL) 21040000 NOP 0 FIOCS RETURNS AT +6 21050016 LA 0,SEQDASD GET ERROR ADDRESS ** 21060000 L 1,FDIOCS# PICK UP DIOCS ADDRESS ** 21080000 CR 0,1 WAS DIOCS EVER CALLED ** 21100000 BC 8,DOSPIE BR IF DIOCS NEVER CALLED 21120000 BALR 0,1 GO TO DIOCS TO CLOSE ALL ** 21140000 DC AL1(TERM) DATA SETS AND TO DO GENERAL ** 21160000 DC AL1(NULL) CLEAN UP ** 21180000 NOP 0 FIOCS RETURNS AT +6 21181016 L 1,PICAHOLD 21183014 LTR 1,1 21186014 BZ DOSPIE 21189014 SPIE MF=(E,(1)) 21192014 B RELOAD 21195014 DOSPIE SPIE 21200000 RELOAD L S,REG13 21220014 L R,12(0,S) GET RETURN ADDRESS 21240000 LR L,SPILL PICKUP RETURN CODE 21260000 LM 0,12,20(S) RESTORE REGISTERS 21280000 BCR ALWAYS,R RETURN TO SUPERVISOR 21300000 DROP BASE 21320000 * 21340000 EJECT 21360000 * 21380000 * DATA AND STORAGE AREAS 21400000 * 21420000 REG13 DS 1F 21440000 SAVERR DS 16F 21450014 PICAHOLD DS F 21460014 VIBCOM DC AL4(IBCOM#) 21480000 AFIOCS DC AL4(FIOCS#) 21500000 VFCVZO DC AL4(FCVZO) 21520000 PAUSE DC AL4(0) WTOR ECB 21540000 OUTPTR DC X'04000000' 21560000 MOVEO MVC WTOMES+14(1),1(R) OPERATOR MESSAGE TO CALL 21580000 EIGHT DC AL2(8) 21600000 ANSWER DC AL1(0) 21620000 EXITSW DC AL1(0) SET ON BY STOP, OFF BY PAUSE 21640000 INTSW DC AL1(0) 21660000 INTSWTCH EQU INTSW 21670016 MSTOP DC C'2I STOP ' 21680000 MPAWS DC C'1A PAUSE ' 21700000 ERRMES DC C'0IHC I' 21720000 OPSW DC C'0IHC210I PROGRAM' 21730014 DC C' INTERRUPT( ) OL' BNDR 21740014 DC C'D PSW IS' BNDR 21750014 REGMSG DC C'REGISTER CONTAINED' 21760014 * 21800000 EJECT 21820000 F2F1F8 DC C'218' 4659 22166014 * 22180000 SEQDASD DS 0H GIVE ERROR MESSAGE ** 22200000 LA R,231 GIVE ERROR MESSAGE 231 22220016 B COMERRHN 22240016 * 22260000 EJECT 22280000 * 22300000 FCVZO DS 0H 22320000 USING *,1 22340000 STM 2,6,SAVER SAVE REGISTERS 22360000 LR INDEX,0 GET ADDRESS OF PARAMETERS 22380000 SR COUNT,COUNT 22400000 SR WIDTH,WIDTH 22420000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 22440000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 22460000 AR GRX,COUNT POINT TO RIGHT END OF ITEM 22480000 AR GRY,WIDTH POINT TO RIGHT END OF BUFFERAREA 22500000 NEXT BCTR GRX,0 MOVE LEFT ONE BYTE IN ITEM 22520000 UNPK TRANS+1(3),0(2,GRX) UNPACK ONE BYTE OF ITEM 22540000 MVZ TRANS+1(2),TRANS CLEAR ZONES 22560000 TR TRANS+1(2),DECIM TRANSLATE TWO HEX DIGITS 22580000 BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 22600000 MVC 0(1,GRY),TRANS+2 MOVE ONE DIGIT INTO BUFFER 22620000 BCT WIDTH,NEXTA 22640000 BC ALWAYS,EXITZ FORMAT WIDTH EXHAUSTED 22660000 NEXTA BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 22680000 MVC 0(1,GRY),TRANS+1 MOVE ONE DIGIT INTO BUFFER 22700000 BCT WIDTH,NEXTB 22720000 BC ALWAYS,EXITZ FORMAT WIDTH EXHAUSTED 22740000 NEXTB BCT COUNT,NEXT 22760000 BLANKR BCTR GRY,0 ITEM EXHAUSTED, 22780000 MVI 0(GRY),C' ' FILL IN BLANKS TO 22800000 BCT WIDTH,BLANKR START OF BUFFER AREA. 22820000 EXITZ LM 2,6,SAVER RESTORE REGISTERS 22840000 LR 1,0 22860000 BC ALWAYS,2(0,1) RETURN TO CALLER 22880000 * 22900000 EJECT 22920000 * 22940000 FCVAI DS 0H 22960000 USING *,1 22980000 STM 2,6,SAVER SAVE REGISTERS 23000000 LR INDEX,0 GET ADDRESS OF PARAMETERS 23020000 SR COUNT,COUNT 23040000 SR WIDTH,WIDTH 23060000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 23080000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 23100000 SR WIDTH,COUNT 23120000 BC MINUS,MOVER1 BRANCH IF LENGTH IS HIGH 23140000 AR GRY,WIDTH 23160000 MOVEAI BCTR COUNT,0 23180000 EX COUNT,MOVEY MOVE CHARACTERS TO ITEM 23200000 LTR WIDTH,WIDTH 23220000 BC ZPLUS,EXITA BRANCH IF LENGTH LOW OR EQUAL 23240000 LPR WIDTH,WIDTH 23260000 LA GRX,1(COUNT,GRX) 23280000 BLANK1 MVI 0(GRX),C' ' BLANK EXCESS LENGTH 23300000 LA GRX,1(0,GRX) 23320000 BCT WIDTH,BLANK1 23340000 EXITA LM 2,6,SAVER RESTORE REGISTERS 23360000 LR 1,0 23380000 BC ALWAYS,2(0,1) RETURN TO CALLER 23400000 MOVER1 IC COUNT,1(0,INDEX) 23420000 BC ALWAYS,MOVEAI 23440000 * 23460000 SPACE 3 23480000 * 23500000 FCVAO DS 0H 23520000 USING *,1 23540000 STM 2,6,SAVER SAVE REGISTERS 23560000 LR INDEX,0 GET ADDRESS OF PARAMETERS 23580000 SR COUNT,COUNT 23600000 SR WIDTH,WIDTH 23620000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 23640000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 23660000 SR WIDTH,COUNT 23680000 BC ZMINUS,MOVER2 BRANCH IF LENGTH HIGH OR EQUAL 23700000 BLANK2 MVI 0(GRY),C' ' BLANK EXCESS WIDTH 23720000 LA GRY,1(0,GRY) 23740000 BCT WIDTH,BLANK2 23760000 MOVEAO BCTR COUNT,0 23780000 EX COUNT,MOVEX MOVE CHARACTERS TO BUFFER 23800000 LM 2,6,SAVER RESTORE REGISTERS 23820000 LR 1,0 23840000 BC ALWAYS,2(0,1) RETURN TO CALLER 23860000 MOVER2 IC COUNT,1(0,INDEX) 23880000 BC ALWAYS,MOVEAO 23900000 * 23920000 EJECT 23940000 * 23960000 FCVII DS 0H 23980000 USING *,1 24000000 STM 2,12,SAVER SAVE REGISTERS 24020000 BAL CALLBY,SCNCVB SCAN AND CONVERT TO BINARY 24040000 LAB TM SWITCH,NEGDIG WAS DATUM NEGATIVE 20443 24060018 BC NONE,CHECKI NO 24080000 LNR DATUM2,DATUM2 YES, SET SIGN. 24100000 CHECKI TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 24120000 BC NONE,STHALF 24140000 ST DATUM2,0(0,GRX) FULL-WORD INTEGER 24160000 EXITII LM 2,12,SAVER RESTORE REGISTERS 24180000 LR 1,0 24200000 BC ALWAYS,2(0,1) RETURN TO CALLER 24220000 STHALF STH DATUM2,0(0,GRX) HALF-WORD INTEGER 24240000 BC ALWAYS,EXITII 24260000 * 24280000 SCNCVB BALR BASEC,0 LOAD BASE REGISTER 24300000 USING *,BASEC 24320000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 24340000 SR WIDTH,WIDTH 24360000 SR DECCTR,DECCTR 24380000 STM WIDTH,DECCTR,DIGIT CLEAR DIGIT AND EXPONENT 24400000 IC WIDTH,1(0,INDEX) PICKUP WIDTH 24420000 IC DECCTR,2(0,INDEX) AND NUMBER OF DECIMALS. 24440000 SR SPLCTR,SPLCTR INITIALIZE SPILL COUNTER 24460000 SR DATUM1,DATUM1 24480000 SR DATUM2,DATUM2 24500000 STM DATUM1,DATUM2,DATUM N = 0 24520000 MVI SWITCH,OFF INITIALIZE SCAN SWITCHES 24540000 CNTSCN CLI 0(GRY),C'0' IS CHARACTER A NUMBER 24560000 BC LOW,NOTNUM 24580000 CLI 0(GRY),C'9' 24600000 BC HIGH,NOTNUM 24620000 OI SWITCH,DIGSW YES, SET DIGIT ENCOUNTERED. 24640000 MVN DIGIT+3(1),0(GRY) 24660000 GETNUM CL DATUM1,HIBYTE WILL LEFT SHIFT CAUSE OVERFLOW 24680000 BC HIGH,SPILIT YES, BRANCH. 24700000 SLDL DATUM1,3 N * 10 24720000 BAL CALLIN,FXDPAD 24740000 BAL CALLIN,FXDPAD 24760000 AL DATUM2,DIGIT ADD NEW DIGIT TO N 24780000 BC 12,OKAY1 8137 24800000 AH DATUM1,CONONE OVERFLOW, CARRY ONE. 24820000 OKAY1 STM DATUM1,DATUM2,DATUM SAVE N 24840000 SETDEC TM SWITCH,DECSW DECIMAL POINT ENCOUNTERED 24860000 BC NONE,SCNRET NO 24880000 LA DECCTR,1(0,DECCTR) YES, BUMP DECIMAL COUNTER. 24900000 SCNRET LA GRY,1(0,GRY) UPDATE BUFFER POSITION 24920000 BCT WIDTH,CNTSCN TEST FORMAT WIDTH 24940000 TM SWITCH,EXPSW WAS EXPONENT ENCOUNTERED 24960000 BCR NONE,CALLBY NO 24980000 TM SWITCH,NEGEXP WAS EXPONENT NEGATIVE 25000000 BC NONE,SETEXP NO 25020000 LNR DATUM2,DATUM2 YES, SET SIGN. 25040000 SETEXP ST DATUM2,EXPON STASH EXPONENT 25060000 LM DATUM1,DATUM2,INTGER RESTORE N 25080000 BCR ALWAYS,CALLBY 25100000 * 25120000 FXDPAD AL DATUM2,DATUM+4 LOW-ORDER ADD 25140000 BC 12,OKAY2 BRANCH IF NO CARRY 8137 25160000 AH DATUM1,CONONE OVERFLOW, CARRY ONE. 25180000 BC OVER,SPILIT DATUM GT 2**64 - 1 25200000 OKAY2 A DATUM1,DATUM HIGH-ORDER ADD 25220000 BCR UNDER,CALLIN 25240000 SPILIT LM DATUM1,DATUM2,DATUM PICKUP MAXIMUM NUMBER, 25260000 LA SPLCTR,1(0,SPLCTR) AND BUMP SPILL COUNTER. 25280000 BC ALWAYS,SETDEC 25300000 * 25320000 NOTNUM CLI 0(GRY),C' ' 25340000 BC EQUAL,BLANK CHARACTER IS A BLANK 25360000 ST CALLBY,INREG FOR INTEGER INPUT, 20443 25365018 CLC INREG+1(3),ADLAB+1 GO TO SEE IF 20443 25370018 BC EQUAL,LABX DIGIT WAS ENCOUNTERED. 22374 25375018 CLI 0(GRY),C'.' 25380000 BC EQUAL,DECPNT CHARACTER IS DECIMAL POINT 25400000 CLI 0(GRY),C'E' 25420000 BC EQUAL,ECHAR CHARACTER IS 'E' 25440000 CLI 0(GRY),C'D' 25460000 BC EQUAL,ECHAR CHARACTER IS 'D' 25480000 NOTNUM1 CLI 0(GRY),C'+' 22374 25500018 BC EQUAL,PLUSS CHARACTER IS PLUS 25520000 CLI 0(GRY),X'50' 25540000 BC EQUAL,PLUSS CHARACTER IS A BCD PLUS 25560000 CLI 0(GRY),C'-' 25580000 BC EQUAL,MINUSS CHARACTER IS MINUS 25600000 BADCHR LA R,215 GIVE ERROR MESSAGE 215 25620016 B COMERRHN 25640016 * 25660000 BLANK TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED 25680000 BC NONE,SCNRET NO 25700000 MVI DIGIT+3,X'00' YES, TREAT BLANK LIKE ZERO. 25720000 BC ALWAYS,GETNUM 25740000 DECPNT TM SWITCH,DECSW+EXPSW ERROR IF DECIMAL POINT OR 6087 25760017 BC ANYALL,BADCHR EXPONENT WAS ENCOUNTERED. 6087 25780017 OI SWITCH,DIGDEC NO, SET SWITCH 25800000 SR DECCTR,DECCTR INITIALIZE DECIMAL COUNTER 25820000 BC ALWAYS,SCNRET 25840000 ECHAR TM SWITCH,EXPSW WAS EXPONENT ENCOUNTERED 25860000 BC ALL,BADCHR YES 25880000 ESAME OI SWITCH,EXPSW NO, SET SWITCH. 25900000 MVC INTGER(8),DATUM SAVE N 25920000 SR DATUM1,DATUM1 25940000 SR DATUM2,DATUM2 25960000 STM DATUM1,DATUM2,DATUM INITIALIZE FOR EXPONENT 25980000 NI SWITCH,NODEC 26000000 BC ALWAYS,SCNRET 26020000 LABX TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED? 22374 26025018 BC NONE,NOTNUM1 NO. GO TO SEE IF SIGN. 22374 26030018 BC ALWAYS,BADCHR YES. CHAR IS INVALID. 22374 26035018 PLUSS TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED 26040000 BC NONE,SCNRET NO 26060000 SSAME TM SWITCH,EXPSW WAS EXPONENT ENCOUNTERED 26080018 BC ALL,SCNRET YES 26100000 BC ALWAYS,ESAME NO, TREAT AS 'E'. 26120000 MINUSS TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED 26140000 BC ALL,ESIGN YES 26160000 OI SWITCH,NEGDIG NO, SET NUMBER NEGATIVE. 26180000 BC ALWAYS,SCNRET 26200000 ESIGN OI SWITCH,NEGEXP SET EXPONENT NEGATIVE 26220000 BC ALWAYS,SSAME 26240000 DROP BASEC 26260000 * 26280000 EJECT 26300000 * 26320000 FCVFI DS 0H 26340000 FCVEI DS 0H 26360000 FCVDI DS 0H 26380000 USING *,1 26400000 STM 2,13,SAVER SAVE REGISTERS 26420000 LR 13,15 26440000 L L,CIBCOM 26460000 EX 0,114(0,L) SET SWITCH TO IGNORE INTERRUPTS 26480000 L CALLIN,ADSCAN 26500000 BALR CALLBY,CALLIN SCAN AND CONVERT TO BINARY 26520000 LTR DATUM2,DATUM2 TEST LOW-ORDER INTEGER 26540000 BC NZERO,STASHI BRANCH IF NON-ZERO 26560000 LTR DATUM1,DATUM1 TEST HIGH-ORDER INTEGER 26580000 BC NZERO,STASHI BRANCH IF NON-ZERO 26600000 SDR RESULT,RESULT SET RESULT = 0 26620000 BC ALWAYS,CHECKS 26640000 STASHI STM DATUM1,DATUM2,INTGER STASH N IN WORK AREA 26660000 TM INTGER,X'FF' ROOM FOR CHARACTERISTIC 26680000 BC NONE,SET4E YES 26700000 SRDL DATUM1,4 NO, SHIFT OUT ONE HEX DIGIT. 26720000 STM DATUM1,DATUM2,INTGER 26740000 TM INTGER,X'0F' ENOUGH ROOM NOW 26760000 BC NONE,SET4F YES 26780000 SRDL DATUM1,4 NO, SHIFT OUT ONE MORE DIGIT. 26800000 STM DATUM1,DATUM2,INTGER 26820000 MVI INTGER,X'50' SET CHARACTERISTIC OF 16 26840000 BC ALWAYS,FLOATR 26860000 SET4F MVI INTGER,X'4F' SET CHARACTERISTIC OF 15 26880000 BC ALWAYS,FLOATR 26900000 SET4E MVI INTGER,X'4E' SET CHARACTERISTIC OF 14 26920000 FLOATR LD RESULT,CONFLT USING CONSTANT OF 0.0 * 16**14, 26940000 AD RESULT,INTGER FLOAT N. 26960000 SR SPLCTR,DECCTR OVERFLOW COUNT - DECIMAL COUNT 26980000 A SPLCTR,EXPON + INPUT EXPONENT. 27000000 TM SWITCH,EXPSW WAS THERE AN EXPONENT FIELD 27020000 BC ALL,CHECKX YES, IGNORE SCALE FACTOR. 27040000 MVC DIGIT+3(1),3(INDEX) 27060000 TM DIGIT+3,X'80' TEST SIGN OF SCALE FACTOR 27080000 BC NONE,SFPLUS BRANCH IF POSITIVE 27100000 NI DIGIT+3,X'7F' NEGATIVE, CLEAR SIGN BIT. 27120000 A SPLCTR,DIGIT INCREMENT EXPONENT 27140000 BC ALWAYS,CHECKX 27160000 SFPLUS S SPLCTR,DIGIT DECREMENT EXPONENT 27180000 CHECKX LTR SPLCTR,SPLCTR TEST SIGN OF EXPONENT 27200000 BC ZPLUS,POSEXP BRANCH IF POSITIVE 27220000 OI SWITCH,NEGSCL NEGATIVE, SET SWITCH. 27240000 POSEXP LPR DATUM2,SPLCTR FORCE EXPONENT POSITIVE 27260000 CH DATUM2,EXPMAX IS EXPONENT VALID 27280000 BC LOEQ,GETEXP YES 27300000 TM SWITCH,NEGSCL CHECK SIGN OF EXPONENT 27320000 BC ALL,SCLMAX BRANCH IF NEGATIVE 27340000 LD RESULT,MAXM SET RESULT=LARGEST POSSIBLE NO. 22800 27360019 BC ALWAYS,CHECKS 27380000 SCLMAX SH DATUM2,DEC19 REDUCE EXPONENT BY 19 27400000 CH DATUM2,EXPMAX 27420000 BC LOW,NOSCAL TEST FOR NUMBER IN RANGE 22800 27430019 SDR RESULT,RESULT SET RESULT TO ZERO FOR UNDERFLOW 22800 27440019 B CHECKS 22800 27450019 NOSCAL DD RESULT,TEN19 SCALE DOWN 22800 27460019 GETEXP SR DATUM1,DATUM1 27480000 D DATUM1,CONTEN SEPARATE TENS AND UNITS DIGITS 27500000 SLDA DATUM1,3 27520000 LD SCALE,ETABHX(DATUM1) PICKUP 10 ** UNITS 27540000 LTR DATUM2,DATUM2 27560000 BC ZERO,SCALER 27580000 MD SCALE,ETABHT(DATUM2) MULTIPLY BY 10 ** TENS 27600000 SCALER TM SWITCH,NEGSCL CHECK SIGN OF EXPONENT 27620000 BC NONE,SCALUP 27640000 DDR RESULT,SCALE NEGATIVE, SCALE DOWN. 27660000 BC ALWAYS,CHECKS 27680000 SCALUP MDR RESULT,SCALE POSITIVE, SCALE UP. 27700000 CHECKS TM SWITCH,NEGDIG WAS DATUM NEGATIVE 27720000 BC NONE,CHECKF NO 27740000 LNDR RESULT,RESULT YES, SET SIGN. 27760000 CHECKF TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 27780000 BC NONE,STDBLE 27800000 STE RESULT,0(0,GRX) SHORT-PRECISION REAL 27820000 EXITFI EX 0,118(0,L) RESUME PROCESSING OF INTERRUPTS 27840000 LR 15,13 27860000 LM 2,13,SAVER RESTORE REGISTERS 27880000 LR 1,0 27900000 BC ALWAYS,4(0,1) RETURN TO CALLER 27920000 STDBLE STD RESULT,0(0,GRX) LONG-PRECISION REAL 27940000 BC ALWAYS,EXITFI 27960000 * 27980000 EJECT 28000000 * 28020000 FCVIO DS 0H 28040000 USING *,1 28060000 STM 2,7,SAVER SAVE REGISTERS 28080000 LR INDEX,0 GET ADDRESS OF PARAMETERS 28100000 SR WIDTH,WIDTH 28120000 IC WIDTH,1(0,INDEX) PICKUP FORMAT WIDTH 28140000 AR GRY,WIDTH POINT TO RIGHT END OF BUFFERAREA 28160000 TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 28180000 BC NONE,LDHALF 28200000 L NUMBER,0(0,GRX) FULL-WORD INTEGER 28220000 BC ALWAYS,GETSGN 28240000 LDHALF LH NUMBER,0(0,GRX) HALF-WORD INTEGER 28260000 GETSGN MVI SWITCH,C' ' ASSUME POSITIVE NUMBER 28280000 LTR NUMBER,NUMBER 28300000 BC ZERO,ZEROINT INTEGER IS ZERO 4640 28310013 BC PLUS,CVTDEC INTEGER IS POSITIVE 4640 28320013 MVI SWITCH,C'-' RESET FOR NEGATIVE NUMBER 28340000 CVTDEC CVD NUMBER,CVAREA CONVERT TO DECIMAL, 28360000 UNPK CVAREA(15),CVAREA(8) UNPACKED FORM. 28380000 OI CVAREA+14,X'F0' SET PROPER ZONING 28400000 LA GRX,CVAREA+15 POINT TO RIGHT END OF NUMBER 28420000 LA INDEX,CVAREA 28440000 LA COUNT,15 28460000 ZEROCK CLI 0(INDEX),C'0' IGNORE LEADING ZEROS 28480000 BC NOTEQ,SIZCHK 28500000 LA INDEX,1(0,INDEX) 28520000 BCT COUNT,ZEROCK 28540000 ZEROINT BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 4640 28560013 MVI 0(GRY),C'0' STASH A ZERO IN BUFFER 28580000 BCT WIDTH,SETSGN 28600000 EXITIO LM 2,7,SAVER RESTORE REGISTERS 28620000 LR 1,0 28640000 BC ALWAYS,2(0,1) RETURN TO CALLER 28660000 SIZCHK CR WIDTH,COUNT IS FIELD WIDTH ADEQUATE 28680000 BC LOW,STARS1 NO 28700000 BC EQUAL,SIGNCHK TEST IF NEGATIVE 4640 28710013 SETCHR BCTR GRX,0 MOVE LEFT ONE BYTE IN NUMBER 28720000 BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 28740000 MVC 0(1,GRY),0(GRX) MOVE ONE DIGIT TO BUFFER 28760000 BCT WIDTH,TESTC DECREMENT WIDTH 28780000 BC ALWAYS,EXITIO BRANCH IF EXHAUSTED 28800000 TESTC BCT COUNT,SETCHR DECREMENT SIGNIFICANT DIGITS 28820000 SETSGN BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 28840000 MVC 0(1,GRY),SWITCH SET SIGN OF NUMBER 28860000 TESTW BCT WIDTH,STBLNK DECREMENT WIDTH 28880000 BC ALWAYS,EXITIO BRANCH IF EXHAUSTED 28900000 STBLNK BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 28920000 MVI 0(GRY),C' ' STASH LEADING BLANKS 28940000 BC ALWAYS,TESTW 28960000 * 28980000 SIGNCHK CLI SWITCH,C'-' IS INTEGER NEGATIVE 4640 28986013 BC NOTEQ,SETCHR NO- FIELD ADEQUATE 4640 28992013 STARS1 L GRY,SAVER+4 29000000 STARS2 MVI 0(GRY),C'*' IF WIDTH WILL NOT ACCOMMODATE 29020000 LA GRY,1(0,GRY) ALL SIGNIFICANT DIGITS, 29040000 BCT WIDTH,STARS2 FILL FIELD WITH ASTERISKS. 29060000 BC ALWAYS,EXITIO 29080000 * 29100000 EJECT 29120000 * 29140000 FCVFO DS 0H 29160000 USING *,1 29180000 STM 2,13,SAVER SAVE REGISTERS 29200000 MVI SWITCH,NOEXP SET FOR NO EXPONENT FIELD 29220000 BAL CALLBY,FIXCVD FIX AND CONVERT TO BCD 29240000 LM 2,13,SAVER RESTORE REGISTERS 29260000 LR 1,0 29280000 BC ALWAYS,4(0,1) RETURN TO CALLER 29300000 * 29320000 FIXCVD BALR BASEC,0 LOAD BASE REGISTER 29340000 USING *,BASEC 29360000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 29380000 SR DECCTR,DECCTR 29400000 SR WIDTH,WIDTH 29420000 SR SPLCTR,SPLCTR PLACE ZEROS IN REGISTER 29440000 TM 0(INDEX),X'04' TEST FOR DOUBLE WORD 29460000 BC NONE,LDDBLE BRANCH IF DOUBLE 29480000 SDR FLOAT,FLOAT 29500000 LE FLOAT,0(0,GRX) LOAD DATA IN FLOATING REG 29520000 LTER FLOAT,FLOAT TEST FOR ZERO DATA REAL*4 29540000 STASHD STE FLOAT,DATUM STORE SIGN AND CHARACTERISTIC 29560000 BC ZERO,ZERDAT IF DATA = 0, BRANCH 29580000 MVI INTSW,ON IGNORE INTERRUPTS 29600000 TM DATUM,X'80' TEST SIGN 29620000 BC NONE,*+16 POSITIVE- BYPASS SWITCH SET 29640000 OI SWITCH,NEGDIG NEGATIVE- SET SWITCH, 29660000 NI DATUM,X'7F' TURN OFF SIGN BIT 29680000 LE FLOAT,DATUM RE-LOAD REGISTER 29700000 IC WIDTH,DATUM PLACE EXPONENT IN REGISTER 29720000 N WIDTH,MASK SET EXPONENT IN REGISTER 29740000 TM DATUM,X'08' CHECK SECOND DIGIT OF EXPONENT 29760000 BC NONE,SECTAB LESS THAN EIGHT - NO ADJUST. 29780000 LA WIDTH,8(WIDTH) GREATER - ADJUST TABLE INDEX 29800000 SECTAB LA DATUM1,CVTAB(WIDTH) SET ADDRESS OF SCALING FACTOR 29820000 MD FLOAT,0(0,DATUM1) 29840000 SRA WIDTH,2 ADJUST FOR EXPONENT CALCULATION 29860000 LA DATUM1,EXPTAX(WIDTH) LOAD ADDRESS OF EXPONENT TABLE 29880000 AH SPLCTR,0(DATUM1) ADD EXPONENT FROM TABLE 29900000 STE FLOAT,DATUM STORE AND TEST FOR SPECIAL CASE 29920000 UNITSC CLI DATUM,X'48' IS DATA NOW LESS THAN 10 ** +9 29940000 BC HIEQ,MULNIN IT IS GREATER - BRANCH 29960000 CLI DATUM,X'39' IS DATA NOW LESS THAN 10 ** -9 29980000 BC LOEQ,MUMNIN IF LESS THEN BRANCH 30000000 CLI DATUM,X'3C' 30020000 BC EQUAL,MM65 30040000 CLI DATUM,X'45' 30060000 BC EQUAL,M56 30080000 IC WIDTH,DATUM NOT A SPECIAL CASE - INSERT 30100000 N WIDTH,MASK1 EXPONENT AND MASK 30120000 SLL WIDTH,3 SHIFT TO SET UP TABLE ADDRESS 30140000 MUL LA DATUM1,CVTAB1(WIDTH) POINT TO PROPER SCALING FACTOR 30160000 MD FLOAT,0(0,DATUM1) 30180000 SRA WIDTH,2 ADJUST FOR EXPONENT CALCULATION 30200000 LA DATUM1,EXPTAY(WIDTH) LOAD EXPONENT TABLE ADDRESS 30220000 AH SPLCTR,0(DATUM1) ADD EXPONENT VALUE FROM TABLE 30240000 CNDIG STE FLOAT,DATUM 30260000 CLI DATUM,X'40' CHECK THAT SCALING IS IN BOUNDS 30280000 BC NOTEQ,UNITSC OUT-OF-BOUNDS - BRANCH 30300000 CH SPLCTR,EXPMAX IS EXPONENT LARGER THAN MAX 30320000 BH DEVELOP DONT ROUND FOR EXP GREAT THAN 75 20211 30328017 AD FLOAT,ROUNDER ROUND TO 16 PLACES 20211 30336017 CD FLOAT,CVTAB1 CHECK FOR RIPPLE CARRY 20211 30344017 BL DEVELOP BRANCH IF NO RIPPLE 20211 30352017 MD FLOAT,TENTH YES A RIPPLE - ADJUST MANT BY 10 20211 30360017 AH SPLCTR,ONE AND ADD ONE TO EXPONENT 20211 30368017 * FINISHED WITH SCALLING BEGIN TO DEVELOP DIGITS 20211 30376017 DEVELOP MD FLOAT,S7 PICK OFF 7 DECIMAL DIGITS 20211 30384017 DBLCVT LA WIDTH,24 INITIALIZE POINTER TO CV AREA 30400000 AW FLOAT,S0 FIX FLOATING VARIABLE 30420000 STE FLOAT,DATUM STORE FLOATING INTEGER 30440000 MVI DATUM,X'00' MAKE INTO TRUE INTEGER 30460000 L DATUM1,DATUM LOAD INTEGER FOR CONVERSION 30480000 CVD DATUM1,INTCER(WIDTH) CONVERT INTO PROPER WORD 30500000 SH WIDTH,EIG ADJUST POINTER TO NEXT DBL WORD 30520000 BC ZERO,UNPK EXIT IF DONE 30540000 LA DATUM2,INTCER(WIDTH) DEVELOP ADDRESS OF CV AREA 30560000 NI 15(DATUM2),X'0F' ERASE LAST DIGIT 30580000 CVB DATUM1,INTCER+8(WIDTH) DETERMINE CORRECTION VALUE 30600000 ST DATUM1,INTCER(WIDTH) PLACE INTEGER IN SINGLE WORD 30620000 ST DECCTR,INTCER+4(WIDTH) STORE ZEROES TO MAKE DBL WORD 30640000 MVI 0(DATUM2),X'46' MAKE WORD A FLOATING VARIABLE 30660000 SD FLOAT,INTCER(WIDTH) ADJUST WORD BEING CONVERTED 30680000 MD FLOAT,S5 SCALE HEX DECIMAL TO INTEGER 30700000 BC ALWAYS,DBLCVT+4 REPEAT FOR A TOTAL OF THREE 30720000 UNPK UNPK CVAREA(7),INTCER+28(4) MOVE LEFT PART TO OUTPUT BUILD 30740000 UNPK CVAREA+6(6),INTCER+20(4) OVERLAY ONE,MOVE FOUR 30760000 UNPK CVAREA+11(6),INTCER+12(4) OVERLAY ONE,MOVE FOUR 30780000 MVI INTSW,OFF PROCESS INTERRUPTS 30800000 * 30820000 LA CHRSAV,CVAREA POINT TO START OF CONVERT AREA 30840000 LA MAXIM,16 SIXTEEN DIGITS MAXIMUM OUTPUT 30860000 ZERCHK CLI 0(CHRSAV),C'0' WAS THERE A LEADING ZERO 30880000 BC NOTEQ,TSTSCL NO 30900000 SH SPLCTR,CONONE YES, DECREMENT EXPONENT. 30920000 LA CHRSAV,1(0,CHRSAV) SKIP LEADING ZERO 30940000 BCTR MAXIM,0 30960000 BC ALWAYS,ZERCHK 30980000 LDDBLE LD FLOAT,0(0,GRX) LONG-PRECISION REAL 31000000 LTDR FLOAT,FLOAT 31020000 BC ALWAYS,STASHD 31040000 MULNIN LA WIDTH,64 SET POINTER TO 10 ** +9 31060000 BC ALWAYS,MUL 31080000 MUMNIN LA WIDTH,72 SET POINTER TO 10 ** -9 31100000 BC ALWAYS,MUL 31120000 M56 EQU * 31140000 TM DATUM+1,X'80' 31160000 BC NONE,M5 31180000 BC ALWAYS,M6 31200000 MM65 EQU * 31220000 TM DATUM+1,X'80' 31240000 BC NONE,MM6 31260000 BC ALWAYS,MM5 31280000 M5 MD FLOAT,S5M 31300000 AH SPLCTR,FIV 31320000 BC ALWAYS,CNDIG 31340000 M6 MD FLOAT,S6M 31360000 AH SPLCTR,SIX 31380000 BC ALWAYS,CNDIG 31400000 MM6 MD FLOAT,S6 31420000 SH SPLCTR,SIX 31440000 BC ALWAYS,CNDIG 31460000 MM5 MD FLOAT,S5 31480000 SH SPLCTR,FIV 31500000 BC ALWAYS,CNDIG 31520000 TSTSCL SR FACTOR,FACTOR INITIALIZE FOR SCALING 31540000 ST FACTOR,EXPON 31560000 TM 3(INDEX),X'FF' WAS THERE A SCALE FACTOR 31580000 BC NONE,NOFACT NO 31600000 MVC EXPON+3(1),3(INDEX) YES 31620000 TM EXPON+3,X'80' TEST SIGN OF SCALE FACTOR 31640000 BC NONE,UPSCAL BRANCH IF POSITIVE 31660000 NI EXPON+3,X'7F' NEGATIVE, CLEAR SIGN BIT. 31680000 S FACTOR,EXPON DECREMENT EXPONENT 31700000 BC ALWAYS,ADJEXP 31720000 UPSCAL A FACTOR,EXPON INCREMENT EXPONENT 31740000 ADJEXP ST FACTOR,EXPON 31760000 NOFACT TM SWITCH,EDEXP WAS THIS F-CONVERSION 31780000 BC ALL,FEDOUT NO 31800000 AR FACTOR,SPLCTR YES, SCALING INCLUDES EXPONENT. 31820000 * 31840000 FEDOUT IC WIDTH,1(0,INDEX) PICKUP WIDTH 31860000 IC DECCTR,2(0,INDEX) AND NUMBER OF DECIMALS. 31880000 LR ROUNDR,FACTOR COMPUTE POSITION OF ROUND 31900000 AR ROUNDR,DECCTR 31920000 LTR ROUNDR,ROUNDR 31940000 BC MINUS,ROUNDO BRANCH IF ROUNDING IMPOSSIBLE 31960000 CH ROUNDR,RNDMAX 31980000 BC HIEQ,ROUNDO BRANCH IF PAST END OF DIGITS 32000000 AR ROUNDR,CHRSAV 32020000 CLI 0(ROUNDR),C'5' 32040000 BC LOW,ROUNDO CHARACTER PAST END IS LT 5 32060000 CNTRND BCTR ROUNDR,0 32080000 CR ROUNDR,CHRSAV 32100000 BC LOW,SETONE BRANCH IF RIPPLE CARRY COMPLETE 32120000 CLI 0(ROUNDR),C'9' 32140000 BC EQUAL,RIPPLE CHARACTER TO ROUND IS A 9 32160000 SR DIGRND,DIGRND 32180000 IC DIGRND,0(0,ROUNDR) 32200000 LA DIGRND,1(0,DIGRND) BUMP CHARACTER BY ONE 32220000 STC DIGRND,0(0,ROUNDR) 32240000 BC ALWAYS,ROUNDO 32260000 RIPPLE MVI 0(ROUNDR),C'0' CHARACTER 9 ROUNDS TO 0 32280000 BC ALWAYS,CNTRND 32300000 SETONE MVI 0(ROUNDR),C'1' SET 1 FROM RIPPLE CARRY 32320000 LR CHRSAV,ROUNDR INCLUDE EXTRA CHARACTER 32340000 LA MAXIM,1(0,MAXIM) 32360000 AH SPLCTR,CONONE INCREMENT EXPONENT 32380000 TM SWITCH,EDEXP 32400000 BC ALL,ROUNDO 32420000 AH FACTOR,CONONE F-CONVERSION 32440000 * 32460000 ROUNDO LA MINIM,1(0,DECCTR) ALLOW FOR POINT AND D DECIMALS 32480000 LTR FACTOR,FACTOR 32500000 BC ZMINUS,EXPCHK BRANCH IF NO INTEGER PORTION 32520000 AR MINIM,FACTOR ALLOW FOR INTEGER DIGITS 32540000 EXPCHK TM SWITCH,NOEXP 32560000 BC ALL,MINCHK BRANCH IF F-CONVERSION 32580000 LA MINIM,4(0,MINIM) ALLOW FOR EXPONENT FIELD 32600000 MINCHK SR WIDTH,MINIM IS FIELD WIDTH ADEQUATE 32620000 BC MINUS,STARS3 NO 32640000 BC EQUAL,SIGNCHK1 CHECK IF MINUS SIGN NEEDED 4640 32650013 BUFADJ AR GRY,WIDTH YES, ADJUST BUFFER 4640 32660013 ST GRY,BEGPOS 32680000 LTR FACTOR,FACTOR TEST SCALING 32700000 BC ZERO,ZERFAC OUTPUT IS NORMALIZED 32720000 BC PLUS,POSFAC OUTPUT HAS INTEGER PORTION 32740000 LPR FACTOR,FACTOR DECIMAL PORTION HAS LEADING 0'S 32760000 MVI 0(GRY),C'.' SET DECIMAL POINT 32780000 LA GRY,1(0,GRY) 32800000 OI SWITCH,DECSW 32820000 LTR DECCTR,DECCTR 32840000 BC ZMINUS,LEADIN 32860000 NEGFAC MVI 0(GRY),C'0' SET LEADING ZEROS 32880000 LA GRY,1(0,GRY) 32900000 BCT DECCTR,ZERMOV 32920000 BC ALWAYS,LEADIN BRANCH IF DECIMALS EXHAUSTED 32940000 ZERMOV BCT FACTOR,NEGFAC 32960000 LR MOVER,DECCTR 32980000 BC ALWAYS,MAXCHK MOVE IN SIGNIFICANT DECIMALS 33000000 POSFAC OI SWITCH,POSSCL SET SWITCH FOR INTEGER 33020000 LR MOVER,FACTOR 33040000 BC ALWAYS,MAXCHK MOVE IN INTEGER PORTION 33060000 ZERFAC MVI 0(GRY),C'.' SET DECIMAL POINT 33080000 LA GRY,1(0,GRY) 33100000 OI SWITCH,DECSW 33120000 LTR DECCTR,DECCTR 33140000 BC ZMINUS,LEADIN BRANCH IF NO DECIMALS 33160000 LR MOVER,DECCTR 33180000 * 33200000 MAXCHK LTR MAXIM,MAXIM 33220000 BC ZMINUS,ZERSET BRANCH IF DIGITS EXHAUSTED 33240000 MOVDIG MVC 0(1,GRY),0(CHRSAV) FROM CONVERT AREA TO BUFFER 33260000 LA GRY,1(0,GRY) 33280000 LA CHRSAV,1(0,CHRSAV) 33300000 BCT MOVER,MOVCHK 33320000 BCTR MAXIM,0 33340000 BC ALWAYS,OUTCHK 33360000 MOVCHK BCT MAXIM,MOVDIG ANY MORE SIGNIFICANT DIGITS 33380000 ZERSET MVI 0(GRY),C'0' NO, FILL OUT FIELD WITH ZEROS. 33400000 LA GRY,1(0,GRY) 33420000 BCT MOVER,ZERSET 33440000 OUTCHK TM SWITCH,DECSW 33460000 BC NONE,ZERFAC BRANCH TO MOVE D DECIMALS 33480000 * 33500000 LEADIN LTR WIDTH,WIDTH 33520000 BCR ZERO,CALLBY BRANCH IF WIDTH EXHAUSTED 33540000 L GRY,BEGPOS 33560000 TM SWITCH,POSSCL 33580000 BC ALL,TSTSGN BRANCH IF INTEGER SET 33600000 BCTR GRY,0 33620000 TM SWITCH,NEGDIG 4640 33626013 BC NONE,LDZERO POSITIVE NUMBER 4640 33632013 CH WIDTH,CONONE TEST REMAINING BUFFER POSITIONS 4640 33638013 BC EQUAL,MINSGN ONLY ONE LEFT-ENTER MINUS SIGN 4640 33644013 LDZERO MVI 0(GRY),C'0' SET ZERO AS INTEGER 4640 33650013 BCT WIDTH,TSTSGN 33660000 BCR ALWAYS,CALLBY BRANCH IF WIDTH EXHAUSTED 33680000 TSTSGN TM SWITCH,NEGDIG 33700000 BC NONE,FILLUP BRANCH IF DATUM POSITIVE 33720000 BCTR GRY,0 33740000 MINSGN MVI 0(GRY),C'-' SET MINUS SIGN 4640 33760013 BCT WIDTH,FILLUP 33780000 BCR ALWAYS,CALLBY BRANCH IF WIDTH EXHAUSTED 33800000 FILLUP BCTR GRY,0 33820000 MVI 0(GRY),C' ' SET LEADING BLANKS 33840000 BCT WIDTH,FILLUP 33860000 BCR ALWAYS,CALLBY BRANCH IF WIDTH EXHAUSTED 33880000 * 33900000 SIGNCHK1 TM SWITCH,NEGDIG IS NUMBER NEGATIVE 4640 33906013 BC NONE,BUFADJ NO- FIELD ADEQUATE 4640 33912013 STARS3 AR WIDTH,MINIM RESTORE WIDTH 33920000 STARS4 MVI 0(GRY),C'*' IF WIDTH WILL NOT ACCOMMODATE 33940000 LA GRY,1(0,GRY) ALL SIGNIFICANT DIGITS, 33960000 BCT WIDTH,STARS4 FILL FIELD WITH ASTERISKS. 33980000 XITSKP LM 2,13,SAVER RESTORE REGISTERS 34000000 LR 1,0 34020000 BC ALWAYS,4(0,1) RETURN TO CALLER 34040000 * 34060000 ZERDAT IC WIDTH,1(0,INDEX) PICKUP WIDTH 34080000 IC DECCTR,2(0,INDEX) AND NUMBER OF DECIMALS. 34100000 CLEAR MVI 0(GRY),C' ' FILL FIELD WITH BLANKS 34120000 LA GRY,1(0,GRY) 34140000 BCT WIDTH,CLEAR 34160000 CHKEXP LA MAXIM,3 ASSUME AT LEAST 1 DEC PLACE.1748 34250015 LTR DECCTR,DECCTR IS DECIMAL WIDTH ZERO. 1748 34260015 BNZ *+8 IF NOT, BRANCH. 1748 34270015 LA MAXIM,2 REDUCE MOVE COUNT BY 1. 1748 34280015 LA MINIM,3(0,DECCTR) 7907 34320000 TM SWITCH,EDEXP 34340000 BC NONE,CHKSIZ BRANCH IF F-CONVERSION 34360000 LA MINIM,4(0,MINIM) ALLOW FOR EXPONENT FIELD 34380000 CHKSIZ LA CHRSAV,ZERPNT SET POINTER FOR MOVE. 1748 34410015 SR GRY,MINIM 34440000 COMPAR C GRY,SAVER+4 IS FIELD WIDTH ADEQUATE 34460000 BC HIEQ,SETZER BRANCH IF YES 34480000 LA GRY,1(0,GRY) 34500000 LA CHRSAV,1(0,CHRSAV) 34520000 BCT MAXIM,COMPAR TRY TO FIT WIDTH 34540000 IC WIDTH,1(0,INDEX) INADEQUATE FIELD WIDTH 1748 34560015 BC ALWAYS,STARS4 GO TO FILL WITH ASTERISKS 1748 34580015 SETZER EX MAXIM,CHRMOV MOVE IN SIGN AND 0.0 34600000 BC ALWAYS,XITSKP 34620000 DROP BASEC 34640000 * 34660000 EJECT 34680000 * 34700000 FCVEO DS 0H 34720000 FCVDO DS 0H 34740000 USING *,1 34760000 STM 2,13,SAVER SAVE REGISTERS 34780000 MVI SWITCH,EDEXP SET FOR E OR D EXPONENT FIELD 34800000 L CALLIN,ADFIXR 34820000 BALR CALLBY,CALLIN FIX AND CONVERT TO BCD 34840000 L GRY,BEGPOS 34860000 AR GRY,MINIM COMPUTE POSITION 34880000 SH GRY,CONFOR OF EXPONENT FIELD. 34900000 TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 34920000 BC NONE,MOVED 34940000 MVI 0(GRY),C'E' FOUR BYTES, SET E-CHARACTER. 34960000 BC ALWAYS,EXPSGN 34980000 MOVED MVI 0(GRY),C'D' EIGHT BYTES, SET D-CHARACTER. 35000000 EXPSGN S SPLCTR,EXPON ADJUST EXPONENT BY SCALE FACTOR, 35020000 LTR SPLCTR,SPLCTR AND TEST SIGN. 35040000 BC MINUS,SETNEG 35060000 MVI 1(GRY),C' ' POSITIVE, SET BLANK SIGN. 35080000 BC ALWAYS,EXPCVT 35100000 SETNEG MVI 1(GRY),C'-' NEGATIVE, SET MINUS SIGN. 35120000 LPR SPLCTR,SPLCTR 35140000 EXPCVT CVD SPLCTR,CVAREA CONVERT TO DECIMAL, 35160000 UNPK CVAREA(2),CVAREA+6(2) UNPACKED FORM. 35180000 OI CVAREA+1,X'F0' SET PROPER ZONING, 35200000 MVC 2(2,GRY),CVAREA AND MOVE IN TWO DIGITS. 35220000 LM 2,13,SAVER RESTORE REGISTERS 35240000 LR 1,0 35260000 BC ALWAYS,4(0,1) RETURN TO CALLER 35280000 * 35300000 EJECT 35320000 * 35340000 * TABLE OF POWERS OF TEN IN HEXADECIMAL FLOATING POINT 35360000 * 35380000 ETABHX DS 0D 35400000 DC X'4110000000000000' 10**0 35420000 DC X'41A0000000000000' 10**1 35440000 DC X'4264000000000000' 10**2 35460000 DC X'433E800000000000' 10**3 35480000 DC X'4427100000000000' 10**4 35500000 DC X'45186A0000000000' 10**5 35520000 DC X'45F4240000000000' 10**6 35540000 DC X'4698968000000000' 10**7 35560000 DC X'475F5E1000000000' 10**8 35580000 ETABHT DS 0D 35600000 DC X'483B9ACA00000000' 10**9 35620000 DC X'492540BE40000000' 10**10 35640000 DC X'5156BC75E2D63100' 10**20 35660000 DC X'59C9F2C9CD04674F' 10**30 35680000 DC X'621D6329F1C35CA5' 10**40 35700000 DC X'6A446C3B15F99267' 10**50 35720000 DC X'729F4F2726179A23' 10**60 35740000 DC X'7B172EBAD6DDC73C' 10**70 35760000 TEN19 DC X'508AC7230489E800' 35780000 SCLTAB EQU ETABHX 35800000 * 35820000 SPACE 3 35840000 EJECT 35860000 * 35880000 * DATA AND STORAGE AREAS 35900000 * 35920000 SAVER DS 12F REGISTER STORAGE 35940000 DATUM DS 1D INTEGER STORAGE 35960000 INTGER DS 1D TEMPORARY 35980000 DIGIT DS 1F DIGIT STORAGE 36000000 EXPON DS 1F EXPONENT STORAGE 36020000 CONFLT DC X'4E00000000000000' 36040000 EXPMAX DC AL2(75) 36060000 DEC19 DC AL2(19) 36080000 RNDMAX DC AL2(16) 36100000 TRANS DC AL4(0) TRANSLATION AREA 36120000 CVAREA DS 2D DECIMAL CONVERT AREA 36140000 CIBCOM DC AL4(IBCOM#) 36160000 ADSCAN DC AL4(SCNCVB) 36180000 ADFIXR DC AL4(FIXCVD) 36200000 BEGPOS DS 1F START OF SIGNIFICANT DIGITS 36220000 HIBYTE DC X'0FFFFFFF' 36240000 CONTEN DC AL4(10) 36260000 MOVEY MVC 0(1,GRX),0(GRY) BUFFER TO ITEM 36280000 MOVEX MVC 0(1,GRY),0(GRX) ITEM TO BUFFER 36300000 CHRMOV MVC 0(1,GRY),0(CHRSAV) MOVE FROM CONVERT AREA 36320000 CONONE DC AL2(1) 36340000 CONFOR DC AL2(4) 36360000 CONFIV DC AL2(5) 36380000 CONEGT DC AL2(8) 36400000 SWITCH DC AL1(0) SCAN SWITCHES 36420000 DECIM DC C'0123456789ABCDEF' TRANSLATION TABLE 36440000 ZERPNT DC C' 0.0' 36520000 * 36540000 INTCER DS 4D 36560000 CVTAB DS 0D 36580000 DC X'7B172EBAD6DDC73C' 10**70 36600000 DC X'729F4F2726179A23' 10**60 36620000 DC X'6A446C3B15F99267' 10**50 36640000 DC X'621D6329F1C35CA5' 10**40 36660000 DC X'621D6329F1C35CA5' 10**40 36680000 DC X'59C9F2C9CD04674F' 10**30 36700000 DC X'5156BC75E2D63100' 10**20 36720000 DC X'492540BE40000000' 10**10 36740000 DC X'4110000000000000' 36760000 DC X'3944B82FA09B5A52' 10 ** -9 36780000 DC X'302F394219248446' 10 ** -20 36800000 DC X'2814484BFEEBC2A1' 10 ** -30 36820000 DC X'1F8B61313BBABCF9' 10 ** -40 36840000 DC X'173BDCF495A97046' 10 ** -50 36860000 DC X'0F19B604AAACA62B' 10 ** -60 36880000 DC X'06B0AF48EC79AD21' 10 ** -70 36900000 CVTAB1 DS 0D 36920000 DC X'4110000000000000' 10 ** 0 36940000 TENTH DC X'401999999999999A' 10**-1 20211 36960017 DC X'3F28F5C28F5C28F6' 10 ** -2 36980000 DC X'3E4189374BC6A7F0' 10 ** -3 37000000 DC X'3D68DB8BAC710CB2' 10 ** -4 37020000 S6M DC X'3C10C6F7A0B5ED8D' 10 ** -6 37040000 DC X'3B1AD7F29ABCAF48' 10 ** -7 37060000 DC X'3A2AF31DC4611873' 10 ** -8 37080000 DC X'3944B82FA09B5A52' 10 ** -9 37100000 DC X'483B9ACA00000000' 10**9 37120000 DC X'475F5E1000000000' 10**8 37140000 S7 DC X'4698968000000000' 10**7 37160000 S5 DC X'45186A0000000000' 10**5 37180000 DC X'4427100000000000' 10**4 37200000 DC X'433E800000000000' 10**3 37220000 DC X'4264000000000000' 10**2 37240000 S5M DC X'3CA7C5AC471B4784' 10 ** -5 37260000 S6 DC X'45F4240000000000' 10**6 37280000 S0 DC X'4600000000000000' NORMALIZING FACTOR 4660 37300014 ROUNDER DC X'4000000000000004' ROUNDING FACTOR 20211 37308017 * ROUNDING FACTOR IS .5551 10**-16 THIS IS OBTAINED FROM 20211 37316017 * ROUNDING .5 10**-16 WHICH IS 3339A5652FB11378 20211 37324017 * FACTOR IS UNNORMALIZED TO SAVE TIME DURING EXECUTION 20211 37332017 MAXM DC X'7FFFFFFFFFFFFFFF' MAX. FLOAT POINT NO. 22800 37336019 MASK DC X'000000F0' 37340000 MASK1 DC X'0000000F' 37360000 EXPTAX DC X'FFBA' -70 37380000 DC X'FFC4' -60 37400000 DC X'FFCE' -50 37420000 DC X'FFD8' -40 37440000 DC X'FFD8' -40 37460000 DC X'FFE2' -30 37480000 DC X'FFEC' -20 37500000 DC X'FFF6' -10 37520000 DC X'0000' 0 37540000 DC X'0009' +9 37560000 TWT DC X'0014' 37580000 THT DC X'001E' 37600000 FRT DC X'0028' 37620000 FFT DC X'0032' 37640000 SXT DC X'003C' 37660000 SVT DC X'0046' 37680000 EXPTAY DC X'0000' ZERO 37700000 ONE DC X'0001' 37720000 TWO DC X'0002' 37740000 THR DC X'0003' 37760000 FOU DC X'0004' 37780000 FIV DC X'0005' 37800000 SEV DC X'0007' 37820000 EIG DC X'0008' 37840000 NIN DC X'0009' 37860000 DC X'FFF7' -9 37880000 DC X'FFF8' -8 37900000 DC X'FFF9' -7 37920000 DC X'FFFA' -6 37940000 DC X'FFFC' -4 37960000 DC X'FFFD' -3 37980000 DC X'FFFE' -2 38000000 SIX DC X'0006' 38020000 DC X'FFFB' -5 38040000 INREG DS 1F 20443 38046018 ADLAB DC A(LAB) 20443 38052018 SPACE 3 38060000 END 38080000 ./ ADD SSI=01011980,NAME=IHCFCOMH,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 0 20000016 IHCIBCOM 30000016 END 40000016 ./ ADD SSI=01011301,NAME=IHCFCVTH,SOURCE=0 TITLE 'IHCFCVTH' - OPERATING SYSTEM 360 FORTRAN H 00020000 IHCFCVTH START 0 I/O DATA CONVERSIONS 00040000 *0850 113000,113800-114000,245700 22800 00070000 *A047130-047160,,047230-047260,,053900,262667-262668 63563 00080022 *C053830 63563 00090022 ENTRY ADCON# 00100000 EXTRN IBCOM# 00120000 ENTRY INT6SWCH 4648 00130016 * THESE ENTRY POINTS ARE A TEMPORARY EXPEDIENT TO MAINTAIN 00140000 * COMPATIBILITY WITH FORTRAN E'S DUMP/PDUMP SUBROUTINE. 00160000 ENTRY FCVEOUTP 00180016 ENTRY FCVLOUTP 00200016 ENTRY FCVIOUTP 00220016 ENTRY FCVCOUTP 00240016 ENTRY FCVAOUTP 00260016 ENTRY FCVZOUTP 00280016 * 00300000 * STATUS -- CHANGE LEVEL 5 -- 1 AUGUST 1974 -- RELEASE 21.8 00320022 * 00340000 * FUNCTION/OPERATION--IHCFCVTH, A MEMBER OF THE FORTRAN SYSTEM LIBRARY, 00360000 * IS USED BY IHCFCOMH AND IHCNAMEL TO PERFORM VARIOUS TYPES OF 00380000 * INPUT AND OUTPUT DATA CONVERSIONS. IT IS ALSO USED BY IHCFDUMP 00400000 * TO FORMAT THE CORE DUMP OUTPUT RECORDS. 00420000 * 00440000 * ENTRY POINTS-- 00460000 * ADCON# IS THE INITIAL LOCATION IN A TABLE OF ADDRESS 00480000 * CONSTANTS FOR THE VARIOUS INPUT/OUTPUT CONVERSION ROUTINES. 00500000 * THESE ROUTINES MAY BE REFERENCED AS FOLLOWS-- 00520000 * LA 2,CORE LEFT-MOST BYTE OF ITEM IN CORE 00540000 * LA 3,BUFFER LEFT-MOST BYTE OF SPACE IN BUFFER 00560000 * L 1,=V(ADCON#) 00580000 * L 1,D(1) REGISTER 1 IS DESTROYED BY ROUTINE 00600000 * BALR 0,1 00620000 * DC XL2'LLWW' FOR Z, A, L, I CONVERSIONS 00640000 * OR 00660000 * DC XL4'LLWWDDSS' FOR F, E, D, G, AND COMPLEX 00680000 * WHERE 'LL' = LENGTH(IN BYTES) OF THE CORE ITEM 00700000 * 'WW' = WIDTH (IN BYTES) OF THE BUFFER SPACE 00720000 * 'DD' = NUMBER OF PLACES TO RIGHT OF DECIMAL POINT 00740000 * 'SS' = SCALE FACTOR (EXTERNAL VALUE = INTERNAL * 10**SS) 00760000 * AND 'D' VARIES ACCORDING TO THE ROUTINE DESIRED. 00780000 * 00800000 * ROUTINE 'D' FUNCTION 00820000 * ....... ... .............................................. 00840000 * FCVFI 0 READS REAL DATA WITHOUT AN EXTERNAL EXPONENT 00860000 * FCVFO 4 WRITES REAL DATA WITHOUT AN EXTERNAL EXPONENT 00880000 * FCVEI 8 READS REAL DATA WITH AN EXTERNAL EXPONENT 00900000 * FCVEO 12 WRITES REAL DATA WITH AN EXTERNAL EXPONENT 00920000 * FCVLI 24 READS LOGICAL DATA 00940000 * FCVLO 28 WRITES LOGICAL DATA 00960000 * FCVII 40 READS INTEGER DATA 00980000 * FCVIO 44 WRITES INTEGER DATA 01000000 * FCVGI 56 READS REAL DATA 01020000 * FCVGO 60 WRITES REAL DATA, USING F OR E OUTPUT 01040000 * FCVCI 72 READS COMPLEX DATA 01060000 * FCVCO 76 WRITES COMPLEX DATA 01080000 * FCVAI 80 READS ALPHAMERIC DATA 01100000 * FCVAO 84 WRITES ALPHAMERIC DATA 01120000 * FCVZI 88 READS HEXADECIMAL DATA 01140000 * FCVZO 92 WRITES HEXADECIMAL DATA 01160000 * 01180000 * INPUT--INPUT CONSISTS OF PARAMETERS PASSED BY THE CALLING ROUTINES, 01200000 * AND DATA CONTAINED IN CORE OR BUFFERS. 01220000 * 01240000 * OUTPUT--OUTPUT CONSISTS OF CONVERTED DATA IN CORE OR BUFFERS. 01260000 * 01280000 * EXTERNAL ROUTINES--IHCFCOMH, TO HANDLE ERROR PROCESSING. 01300000 * 01320000 * EXITS-- 01340000 * NORMAL--RETURN IS TO THE CALLING ROUTINE VIA REGISTER 1, 01360000 * USING THE ORIGINAL CONTENTS OF REGISTER 0. 01380000 * ERROR--A CALL IS MADE TO IHCFCOMH TO WRITE AN ERROR MESSAGE 01400000 * AND TERMINATE EXECUTION. 01420000 * 01440000 * TABLES/WORK AREAS-- 01460000 * 'ETABHX' - POWERS OF 10 FROM 0 TO 9 IN SINGLE-PRECISION 01480000 * FLOATING POINT (HEXADECIMAL REPRESENTATION). 01500000 * 'ETABHT' - TENS' POWERS OF 10 FROM 10 TO 70 IN DOUBLE-PRECISION 01520000 * FLOATING POINT (HEXADECIMAL REPRESENTATION). 01540000 * 'SAVER' - REGISTER STORAGE AREA USED BY THE FORMAT CONVERSION 01560000 * PACKAGE. 01580000 * 01600000 * ATTRIBUTES--THIS MODULE IS NOT REENTRANT, BUT IS SERIALLY REUSABLE. 01620000 * 01640000 * NOTES-- 01660000 * 1. ALL CALLING SEQUENCES TO IHCFCVTH ARE NON-STANDARD. 01680000 * 2. IHCFCVTH USES ITS OWN INTERNAL REGISTER SAVE AREAS, 01700000 * RATHER THAN STORING REGISTERS IN THE CALLING PROGRAM. 01720000 * 01740000 EJECT 01760000 * REGISTER DEFINITIONS 01780000 R EQU 14 RETURN REGISTER 01800000 L EQU 15 LINKAGE REGISTER 01820000 GRX EQU 2 FIRST ARGUMENT 01840000 GRY EQU 3 SECOND ARGUMENT 01860000 INDEX EQU 5 PARAMETER LOCATOR 01880000 COUNT EQU 4 COUNT FOR MOVE 01900000 WIDTH EQU 6 BUFFER POSITIONS 01920000 CALLBY EQU 4 INTERNAL CALLS 01940000 DECCTR EQU 7 NUMBER OF DECIMALS 01960000 SPLCTR EQU 8 OVERFLOW COUNTER 01980000 CALLIN EQU 9 INTERNAL CALLS 02000000 DATUM1 EQU 10 HIGH-ORDER BINARY NUMBER 02020000 DATUM2 EQU 11 LOW-ORDER BINARY NUMBER 02040000 BASEC EQU 12 BASE REGISTER 02060000 RESULT EQU 2 FLOATED DATUM 02080000 SCALE EQU 4 SCALING CONSTANT 02100000 NUMBER EQU 7 BINARY INTEGER 02120000 FLOAT EQU 6 WORK REGISTER 02140000 FACTOR EQU 2 SCALING INDICATOR 02160000 CHRSAV EQU 9 POINTER TO CONVERT AREA 02180000 MAXIM EQU 13 MAXIMUM NUMBER OF DIGITS 02200000 ROUNDR EQU 10 ROUNDING POSITION 02220000 DIGRND EQU 11 ROUNDING REGISTER 02240000 MINIM EQU 10 MINIMUM SPACE REQUIRED 02260000 MOVER EQU 11 NUMBER OF DIGITS TO MOVE 02280000 HEXPTR EQU 7 POINTER TO TRANSLATE AREA 02300000 HEXCTR EQU 8 NUMBER OF HEX DIGITS IN BYTE 02320000 BASEH EQU 8 BASE FOR HALF COMPUTE 02340000 BASEG EQU 4 BASE FOR G-CONVERSION 02360000 SPACE 3 02380000 * BRANCHING CONDITIONS 02400000 ALWAYS EQU 15 UNCONDITIONAL 02420000 HIGH EQU 2 HIGH 02440000 LOW EQU 4 LOW 02460000 EQUAL EQU 8 EQUAL 02480000 NOTEQ EQU 7 NOT EQUAL 02500000 HIEQ EQU 10 HIGH OR EQUAL 02520000 LOEQ EQU 12 LOW OR EQUAL 02540000 PLUS EQU 2 PLUS 02560000 MINUS EQU 4 MINUS 02580000 ZERO EQU 8 ZERO 02600000 NZERO EQU 7 NOT ZERO 02620000 ZPLUS EQU 10 ZERO OR PLUS 02640000 ZMINUS EQU 12 ZERO OR MINUS 02660000 ALL EQU 1 ALL BITS ON 02680000 NONE EQU 8 NO BITS ON 02700000 ANYALL EQU 5 ANY OR ALL BITS ON 6087 02710017 OVER EQU 1 OVERFLOW 02720000 UNDER EQU 14 NO OVERFLOW 02740000 SPACE 3 02760000 * MISCELLANEOUS CODES 02780000 ON EQU X'FF' ON CONDITION 02800000 OFF EQU X'00' OFF CONDITION 02820000 DIGSW EQU X'80' DIGIT ENCOUNTERED 02840000 NEGDIG EQU X'40' NEGATIVE NUMBER 02860000 DECSW EQU X'20' DECIMAL POINT ENCOUNTERED 02880000 EXPSW EQU X'10' EXPONENT ENCOUNTERED 02900000 NODEC EQU X'DF' RESET FOR NO DECIMALS 02920000 NEGEXP EQU X'08' NEGATIVE EXPONENT 02940000 NEGSCL EQU X'04' NEGATIVE SCALING 02960000 NOEXP EQU X'02' CONVERSION WITHOUT EXPONENT 02980000 EDEXP EQU X'01' CONVERSION WITH EXPONENT 03000000 POSSCL EQU X'04' POSITIVE SCALING 03020000 DIGDEC EQU X'A0' BEGIN DIGITS WITH DECIMAL 03040000 THRTNUSR EQU 184 OFFSETS INTO IBCOM FOR A) REG. 03045016 FRTNUSR EQU 124 13 IN IBCOM SAVE AREA B) REG 14 03050016 IBCSV EQU X'C4' IN SAME PLACE. AND IBCOM 2ND S.A 03055016 EJECT 03060000 * 03080000 * CONVERSION ADCONS ACCORDING TO MODE / TYPE 03100000 * 03120000 ADCON# DS 0F 03140000 DC AL4(FCVFI) 0 - INPUT 03160000 DC AL4(FCVFO) 0 - OUTPUT 03180000 DC AL4(FCVEI) 1 - INPUT 03200000 DC AL4(FCVEO) 1 - OUTPUT 03220000 DC AL4(FCVLI) 2 - INPUT 03240000 DC AL4(FCVLO) 2 - OUTPUT 03260000 DC AL4(FCVLI) 3 - INPUT 03280000 DC AL4(FCVLO) 3 - OUTPUT 03300000 DC AL4(FCVII) 4 - INPUT 03320000 DC AL4(FCVIO) 4 - OUTPUT 03340000 DC AL4(FCVII) 5 - INPUT 03360000 DC AL4(FCVIO) 5 - OUTPUT 03380000 DC AL4(FCVGI) 6 - INPUT 03400000 DC AL4(FCVGO) 6 - OUTPUT 03420000 DC AL4(FCVGI) 7 - INPUT 03440000 DC AL4(FCVGO) 7 - OUTPUT 03460000 DC AL4(FCVCI) 8 - INPUT 03480000 DC AL4(FCVCO) 8 - OUTPUT 03500000 DC AL4(FCVCI) 9 - INPUT 03520000 DC AL4(FCVCO) 9 - OUTPUT 03540000 DC AL4(FCVAI) 10 - INPUT 03560000 DC AL4(FCVAO) 10 - OUTPUT 03580000 DC AL4(FCVZI) 11 - INPUT 03600000 DC AL4(FCVZO) 11 - OUTPUT 03620000 * 03640000 EJECT 03660000 * 03660116 FCVAI DS 0H 03660216 USING *,1 03660316 STM 2,6,SAVER SAVE REGISTERS 03660416 LR INDEX,0 GET ADDRESS OF PARAMETERS 03660516 SR COUNT,COUNT 03660616 SR WIDTH,WIDTH 03660716 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 03660816 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 03660916 SR WIDTH,COUNT 03661016 BC MINUS,MOVER1 BRANCH IF LENGTH IS HIGH 03661116 AR GRY,WIDTH 03661216 MOVEAI BCTR COUNT,0 03661316 EX COUNT,MOVEY MOVE CHARACTERS TO ITEM 03661416 LTR WIDTH,WIDTH 03661516 BC ZPLUS,EXITA BRANCH IF LENGTH LOW OR EQUAL 03661616 LPR WIDTH,WIDTH 03661716 LA GRX,1(COUNT,GRX) 03661816 BLANK1 MVI 0(GRX),C' ' BLANK EXCESS LENGTH 03661916 LA GRX,1(0,GRX) 03662016 BCT WIDTH,BLANK1 03662116 EXITA LM 2,6,SAVER RESTORE REGISTERS 03662216 LR 1,0 03662316 BC ALWAYS,2(0,1) RETURN TO CALLER 03662416 MOVER1 IC COUNT,1(0,INDEX) 03662516 BC ALWAYS,MOVEAI 03662616 * 03662716 SPACE 3 03662816 * 03662916 FCVAO DS 0H 03663016 USING *,1 03663116 STM 2,6,SAVER SAVE REGISTERS 03663216 LR INDEX,0 GET ADDRESS OF PARAMETERS 03663316 SR COUNT,COUNT 03663416 SR WIDTH,WIDTH 03663516 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 03663616 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 03663716 SR WIDTH,COUNT 03663816 BC ZMINUS,MOVER2 BRANCH IF LENGTH HIGH OR EQUAL 03663916 BLANK2 MVI 0(GRY),C' ' BLANK EXCESS WIDTH 03664016 LA GRY,1(0,GRY) 03664116 BCT WIDTH,BLANK2 03664216 MOVEAO BCTR COUNT,0 03664316 EX COUNT,MOVEX MOVE CHARACTERS TO BUFFER 03664416 LM 2,6,SAVER RESTORE REGISTERS 03664516 LR 1,0 03664616 BC ALWAYS,2(0,1) RETURN TO CALLER 03664716 MOVER2 IC COUNT,1(0,INDEX) 03664816 BC ALWAYS,MOVEAO 03664916 * 03665016 EJECT 03665116 * 03665216 FCVLI DS 0H 03665316 USING *,1 03665416 STM 2,6,SAVER SAVE REGISTERS 03665516 LR INDEX,0 GET ADDRESS OF PARAMETERS 03665616 SR WIDTH,WIDTH 03665716 IC WIDTH,1(0,INDEX) PICKUP FORMAT WIDTH 03665816 SR COUNT,COUNT INITIALIZE FOR FALSE 03665916 LOGSCN CLI 0(GRY),C'T' 03666016 BC EQUAL,TRUEI CHARACTER IS T 03666116 CLI 0(GRY),C'F' 03666216 BC EQUAL,FALSE CHARACTER IS F 03666316 LA GRY,1(0,GRY) UPDATE BUFFER POSITION 03666416 BCT WIDTH,LOGSCN TEST FORMAT WIDTH 03666516 FALSE TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 03666616 BC NONE,PUTONE 03666716 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X03666816 HANDLING OF ANY BOUNDARY MISALIGNMENT. 03666916 ST COUNT,0(0,GRX) FOUR-BYTE LOGICAL 03667016 MVI INT6SW,X'00' RESET SWITCH 4648 03667116 EXITLI LM 2,6,SAVER RESTORE REGISTERS 03667216 LR 1,0 03667316 BC ALWAYS,2(0,1) RETURN TO CALLER 03667416 PUTONE STC COUNT,0(0,GRX) ONE-BYTE LOGICAL 03667516 BC ALWAYS,EXITLI 03667616 TRUEI LA COUNT,1 RESET FOR TRUE 03667716 BC ALWAYS,FALSE 03667816 * 03667916 SPACE 3 03668016 * 03668116 FCVLO DS 0H 03668216 USING *,1 03668316 STM 2,6,SAVER SAVE REGISTERS 03668416 LR INDEX,0 GET ADDRESS OF PARAMETERS 03668516 SR WIDTH,WIDTH 03668616 IC WIDTH,1(0,INDEX) PICKUP FORMAT WIDTH 03668716 BLANKL MVI 0(GRY),C' ' FILL FIELD WITH BLANKS 03668816 LA GRY,1(0,GRY) 03668916 BCT WIDTH,BLANKL 03669016 BCTR GRY,0 BACKUP ONE IN BUFFER 03669116 TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 03669216 BC NONE,GETONE 03669316 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X03669416 HANDLING OF ANY BOUNDARY MISALIGNMENT. 03669516 L COUNT,0(0,GRX) FOUR-BYTE LOGICAL 03669616 MVI INT6SW,X'00' RESET SWITCH 4648 03669716 LOGTST LTR COUNT,COUNT 03669816 BC NZERO,TRUEO BRANCH IF TRUE 03669916 MVI 0(GRY),C'F' SET CHARACTER F IN BUFFER 03670016 EXITLO LM 2,6,SAVER RESTORE REGISTERS 03670116 LR 1,0 03670216 BC ALWAYS,2(0,1) RETURN TO CALLER 03670316 GETONE SR COUNT,COUNT 03670416 IC COUNT,0(0,GRX) ONE-BYTE LOGICAL 03670516 BC ALWAYS,LOGTST 03670616 TRUEO MVI 0(GRY),C'T' SET CHARACTER T IN BUFFER 03670716 BC ALWAYS,EXITLO 03670816 * 03670916 EJECT 03671016 * 03680000 FCVZI DS 0H 03700000 USING *,1 03720000 STM 2,9,SAVER SAVE REGISTERS 03740016 LR INDEX,0 GET ADDRESS OF PARAMETERS 03760000 SR COUNT,COUNT 03780000 SR WIDTH,WIDTH 03800000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 03820000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 03840000 AR GRX,COUNT POINT TO RIGHT END OF ITEM 03860000 AR GRY,WIDTH POINT TO RIGHT END OF BUFFERAREA 03880000 MVI SWITCH,OFF INITIALIZE SIGN SWITCH 03900000 GETTWO LA HEXPTR,TRANS+3 POINT TO TRANSLATE AREA 03920000 LA HEXCTR,2 CONVERT TWO INPUT DIGITS 03940000 HEXSCN LTR WIDTH,WIDTH 03960000 BC ZMINUS,ZEROA BRANCH IF WIDTH EXHAUSTED 03980000 BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 04000000 CHKNUM EQU * 04010016 CLI 0(GRY),C'0' IS CHARACTER A NUMBER 04020000 BC LOW,NOTDEC 04040000 CLI 0(GRY),C'9' 04060000 BC HIGH,NOTDEC 04080000 MVC 0(1,HEXPTR),0(GRY) YES, USE UNTRANSLATED. 04100000 HEXNUM BCTR WIDTH,0 DECREMENT WIDTH 04120000 BCTR HEXPTR,0 MOVE LEFT IN TRANSLATE AREA 04140000 BCT HEXCTR,HEXSCN BRANCH IF ONE DIGIT REMAINS 04160000 PACK TRANS(2),TRANS+2(3) PACK THE TWO DIGITS IN ONE BYTE 04180000 BCTR GRX,0 MOVE LEFT ONE BYTE IN ITEM 04200000 MVC 0(1,GRX),TRANS MOVE PACKED BYTE INTO ITEM 04220000 BCT COUNT,GETTWO 04240000 HEXOUT TM SWITCH,ON WAS DATUM NEGATIVE 04260000 BC NONE,EXITZI NO 04280000 OI 0(GRX),X'80' YES, SET SIGN. 04300000 EXITZI LM 2,9,SAVER RESTORE REGISTERS 04320016 LR 1,0 04340000 BC ALWAYS,2(0,1) RETURN TO CALLER 04360000 * 04380000 NOTDEC CLI 0(GRY),C'A' 04400000 BC LOW,NOTHEX 04420000 CLI 0(GRY),C'F' 04440000 BC HIGH,NOTHEX 04460000 MVC 0(1,HEXPTR),0(GRY) CHARACTER IS A,B,C,D,E,F 04480000 TR 0(1,HEXPTR),ALPHA-193 TRANSLATE TO HEX 04500000 BC ALWAYS,HEXNUM 04520000 * 04540000 NOTHEX CLI 0(GRY),C' ' 04560000 BC EQUAL,HEXBLK CHARACTER IS A BLANK 04580000 CLI 0(GRY),C'+' 04600000 BC EQUAL,ZEROA CHARACTER IS PLUS 04620000 CLI 0(GRY),X'50' 04640000 BC EQUAL,ZEROA CHARACTER IS A BCD PLUS 04660000 CLI 0(GRY),C'-' 04680000 BC EQUAL,HEXNEG CHARACTER IS MINUS 04700000 MVI MSG+8,C'2' INDICATE MESSAGE 225 04710016 ST 8,ATESAV TEMP FOR THIS USING 1/8 63563 04713022 USING *,8 IN ORDER TO ADDRESS MSG+30 2/8 63563 04716022 MVC MSG+30(11),HXDCML MOVE 'HEXADECIMAL' TO MESSAGE 04720016 L 8,ATESAV RESTORE 3/8 63563 04723022 DROP 8 NOT NEEDED ANY LONGER 4/8 63563 04726022 MVI ERRORNO+3,225 INDICATE IT IS ERROR 225 04730016 LA CALLIN,CHKNUM SET RETURN POINT 04740016 STM 12,1,FPSAV3 SAVE REGS 04750016 B COMINTFC 04760016 * 04780000 HEXBLK MVI 0(HEXPTR),C'0' TREAT BLANK LIKE ZERO 04800000 BC ALWAYS,HEXNUM 04820000 HEXNEG MVI SWITCH,ON SET SWITCH FOR NEGATIVE 04840000 * 04860000 ZEROA BCT HEXCTR,ZEROB BRANCH IF BYTE WAS PACKED 04880000 NI TRANS+3,X'0F' CLEAR LEFTMOST DIGIT 04900000 BCTR GRX,0 04920000 MVC 0(1,GRX),TRANS+3 MOVE THE BYTE INTO ITEM 04940000 BCT COUNT,ZEROB 04960000 BC ALWAYS,HEXOUT BRANCH IF ITEM EXHAUSTED 04980000 ZEROB BCTR GRX,0 05000000 MVI 0(GRX),X'00' PAD ITEM WITH ZEROS 05020000 BCT COUNT,ZEROB 05040000 BC ALWAYS,HEXOUT BRANCH IF ITEM EXHAUSTED 05060000 * 05080000 SPACE 3 05100000 * 05120000 FCVZO DS 0H 05140000 USING *,1 05160000 STM 2,6,SAVEC SAVE REGISTERS 05166016 * IMPORTANT NOTE: THE Z OUTPUT ROUTINE CANNOT SAVE ITS REGISTERS 05172016 * IN THE SAME AREA AS Z INPUT OR I INPUT SINCE BOTH 05178016 * OF THESE ROUTINE CAN CALL THE ERROR MONITOR AND 05184016 * THE ERROR MONITOR USES THE Z OUTPUT ROUTINE 05190016 LR INDEX,0 GET ADDRESS OF PARAMETERS 05200000 SR COUNT,COUNT 05220000 SR WIDTH,WIDTH 05240000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 05260000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 05280000 AR GRX,COUNT POINT TO RIGHT END OF ITEM 05300000 AR GRY,WIDTH POINT TO RIGHT END OF BUFFERAREA 05320000 NEXT BCTR GRX,0 MOVE LEFT ONE BYTE IN ITEM 05340000 BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 05360000 MVC AREA(1),0(GRX) MOVE TO AREA TO AVOID FETCH PRT 5/8 63563 05380022 UNPK TRANS+1(3),AREA(2) UNPACK ONE BYTE OF ITEM 6/8 63563 05390022 TR TRANS+1(2),DECIM-240 TRANSLATE TWO HEX DIGITS 05400000 MVC 0(1,GRY),TRANS+2 MOVE ONE DIGIT INTO BUFFER 05420000 BCT WIDTH,NEXTA 05440000 BC ALWAYS,EXITZO FORMAT WIDTH EXHAUSTED 05460000 NEXTA BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 05480000 MVC 0(1,GRY),TRANS+1 MOVE ONE DIGIT INTO BUFFER 05500000 BCT WIDTH,NEXTB 05520000 BC ALWAYS,EXITZO FORMAT WIDTH EXHAUSTED 05540000 NEXTB BCT COUNT,NEXT 05560000 BLANKR BCTR GRY,0 ITEM EXHAUSTED, 05580000 MVI 0(GRY),C' ' FILL IN BLANKS TO 05600000 BCT WIDTH,BLANKR START OF BUFFER AREA. 05620000 EXITZO LM 2,6,SAVEC RESTORE REGISTERS 05640016 LR 1,0 05660000 BC ALWAYS,2(0,1) RETURN TO CALLER 05680000 * 05700000 EJECT 05720000 * 07820000 FCVII DS 0H 07840000 USING *,1 07860000 STM 2,12,SAVER SAVE REGISTERS 07880000 BAL CALLBY,SCNCVB SCAN AND CONVERT TO BINARY 07900000 LAB TM SWITCH,NEGDIG WAS DATUM NEGATIVE 20443 07920018 BC NONE,CHECKI NO 07940000 LNR DATUM2,DATUM2 YES, SET SIGN. 07960000 CHECKI TM 0(INDEX),X'05' CHECK LENGTH OF ITEM 4648 07970013 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X07980013 HANDLING OF ANY BOUNDARY MISALIGNMENT. 07990013 BC NONE,STHALF 08000000 TM 0(INDEX),X'04' 4648 08006013 BC NONE,STCHAR 4648 08012013 ST DATUM2,0(0,GRX) FULL-WORD INTEGER 08020000 EXITII LM 2,12,SAVER RESTORE REGISTERS 08040000 MVI INT6SW,X'00' RESET SWITCH 4648 08050013 LR 1,0 08060000 BC ALWAYS,2(0,1) RETURN TO CALLER 08080000 STHALF STH DATUM2,0(0,GRX) HALF-WORD INTEGER 08100000 BC ALWAYS,EXITII 08120000 STCHAR STC DATUM2,0(0,GRX) ONE-BYTE INTEGER (FOR 4648X08125013 CONVERSION OF 1-BYTE LOGICAL WITH I-FMT) 08130013 BC ALWAYS,EXITII 4648 08135013 * 08140000 SCNCVB BALR BASEC,0 LOAD BASE REGISTER 08160000 USING *,BASEC 08180000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 08200000 SR WIDTH,WIDTH 08220000 SR DECCTR,DECCTR 08240000 STM WIDTH,DECCTR,DIGIT CLEAR DIGIT AND EXPONENT 08260000 IC WIDTH,1(0,INDEX) PICKUP WIDTH 08280000 IC DECCTR,2(0,INDEX) AND NUMBER OF DECIMALS. 08300000 SR SPLCTR,SPLCTR INITIALIZE SPILL COUNTER 08320000 SR DATUM1,DATUM1 08340000 SR DATUM2,DATUM2 08360000 STM DATUM1,DATUM2,DATUM N = 0 08380000 MVI SWITCH,OFF INITIALIZE SCAN SWITCHES 08400000 CNTSCN CLI 0(GRY),C'0' IS CHARACTER A NUMBER 08420000 BC LOW,NOTNUM 08440000 CLI 0(GRY),C'9' 08460000 BC HIGH,NOTNUM 08480000 OI SWITCH,DIGSW YES, SET DIGIT ENCOUNTERED. 08500000 MVN DIGIT+3(1),0(GRY) 08520000 GETNUM CL DATUM1,HIBYTE WILL LEFT SHIFT CAUSE OVERFLOW 08540000 BC HIGH,SPILIT YES, BRANCH. 08560000 SLDL DATUM1,3 N * 10 08580000 BAL CALLIN,FXDPAD 08600000 BAL CALLIN,FXDPAD 08620000 AL DATUM2,DIGIT ADD NEW DIGIT TO N 08640000 BC 12,OKAY1 8137 08660000 AH DATUM1,CONONE OVERFLOW, CARRY ONE. 08680000 OKAY1 STM DATUM1,DATUM2,DATUM SAVE N 08700000 SETDEC TM SWITCH,DECSW DECIMAL POINT ENCOUNTERED 08720000 BC NONE,SCNRET NO 08740000 LA DECCTR,1(0,DECCTR) YES, BUMP DECIMAL COUNTER. 08760000 SCNRET LA GRY,1(0,GRY) UPDATE BUFFER POSITION 08780000 BCT WIDTH,CNTSCN TEST FORMAT WIDTH 08800000 TM SWITCH,EXPSW WAS EXPONENT ENCOUNTERED 08820000 BCR NONE,CALLBY NO 08840000 TM SWITCH,NEGEXP WAS EXPONENT NEGATIVE 08860000 BC NONE,SETEXP NO 08880000 LNR DATUM2,DATUM2 YES, SET SIGN. 08900000 SETEXP ST DATUM2,EXPON STASH EXPONENT 08920000 LM DATUM1,DATUM2,INTGER RESTORE N 08940000 BCR ALWAYS,CALLBY 08960000 * 08980000 FXDPAD AL DATUM2,DATUM+4 LOW-ORDER ADD 09000000 BC 12,OKAY2 BRANCH IF NO CARRY 8137 09020000 AH DATUM1,CONONE OVERFLOW, CARRY ONE. 09040000 BC OVER,SPILIT DATUM GT 2**64 - 1 09060000 OKAY2 A DATUM1,DATUM HIGH-ORDER ADD 09080000 BCR UNDER,CALLIN 09100000 SPILIT LM DATUM1,DATUM2,DATUM PICKUP MAXIMUM NUMBER, 09120000 LA SPLCTR,1(0,SPLCTR) AND BUMP SPILL COUNTER. 09140000 BC ALWAYS,SETDEC 09160000 * 09180000 NOTNUM CLI 0(GRY),C' ' 09200000 BC EQUAL,BLANK CHARACTER IS A BLANK 09220000 ST CALLBY,INREG FOR INTEGER INPUT, 20443 09225018 CLC INREG+1(3),ADLAB+1 GO TO SEE IF 20443 09230018 BC EQUAL,LABX DIGIT WAS ENCOUNTERED. 22374 09235018 CLI 0(GRY),C'.' 09240000 BC EQUAL,DECPNT CHARACTER IS DECIMAL POINT 09260000 CLI 0(GRY),C'E' 09280000 BC EQUAL,ECHAR CHARACTER IS 'E' 09300000 CLI 0(GRY),C'D' 09320000 BC EQUAL,ECHAR CHARACTER IS 'D' 09340000 NOTNUM1 CLI 0(GRY),C'+' 22374 09360018 BC EQUAL,PLUSS CHARACTER IS PLUS 09380000 CLI 0(GRY),X'50' 09400000 BC EQUAL,PLUSS CHARACTER IS A BCD PLUS 09420000 CLI 0(GRY),C'-' 09440000 BC EQUAL,MINUSS CHARACTER IS MINUS 09460000 BADCHR EQU * 09462016 MVI MSG+8,C'1' INDICATE MESSAGE 215 09464016 MVC MSG+30(11),DCML MOVE 'DECIMAL' TO MESSAGE 09466016 MVI ERRORNO+3,215 SET ERROR NUMBER TO 215 09468016 LA CALLIN,CNTSCN SET RETURN POINT 09470016 STM 12,1,FPSAV3 SAVE REGS 09472016 COMINTFC EQU * 09474016 BALR 12,0 SET UP ADDRESSABILITY 09476016 USING *,12 09478016 L 15,CIBCOM 09480016 L 13,THRTNUSR(0,15) GET ADDR. OF USER'S SAVE AREA 09482016 MVC 12(16,13),FRTNUSR(15) MOVE HIS REGS 14-1 TO HIS AREA 09484016 ST 13,IBCSV+4(0,15) LINK HIS SAVE AREA TO IBCOM'S 09486016 LA 13,IBCSV(0,15) 09488016 LA 1,PRMS SET UP PARAMETER LIST ADDRESS 09490016 ST GRY,12(0,1) PUT ADDRESS OF BAD CHARACTER IN 09492016 MVI 12(1),X'80' PARAMETER LIST(SET LAST IND.) 09494016 MVC MSG+52(1),0(GRY) MOVE BAD CHAR. TO MESSAGE 09496016 L 15,VIHCERRM CALL THE ERROR MONITOR 09498016 BALR 14,15 09500016 L 13,RETCD DID USER FIX UP THE DATA? 09502016 LTR 13,13 09504016 LM 12,1,FPSAV3 RESTORE REGS. 09506016 USING SCNCVB+2,12 09508016 BCR 7,CALLIN YES, RETURN 09510016 MVI 0(GRY),C'0' NO, SET CHAR TO ZERO 09512016 BR CALLIN RETURN 09514016 * 09540000 BLANK TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED 09560000 BC NONE,SCNRET NO 09580000 MVI DIGIT+3,X'00' YES, TREAT BLANK LIKE ZERO. 09600000 BC ALWAYS,GETNUM 09620000 DECPNT TM SWITCH,DECSW+EXPSW ERROR IF DECIMAL POINT OR 6087 09640017 BC ANYALL,BADCHR EXPONENT WAS ENCOUNTERED. 6087 09660017 OI SWITCH,DIGDEC NO, SET SWITCH. 09680000 SR DECCTR,DECCTR INITIALIZE DECIMAL COUNTER 09700000 BC ALWAYS,SCNRET 09720000 ECHAR TM SWITCH,EXPSW WAS EXPONENT ENCOUNTERED 09740000 BC ALL,BADCHR YES 09760000 ESAME OI SWITCH,EXPSW NO, SET SWITCH. 09780000 MVC INTGER(8),DATUM SAVE N 09800000 SR DATUM1,DATUM1 09820000 SR DATUM2,DATUM2 09840000 STM DATUM1,DATUM2,DATUM INITIALIZE FOR EXPONENT 09860000 NI SWITCH,NODEC 09880000 BC ALWAYS,SCNRET 09900000 LABX TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED? 22374 09905018 BC NONE,NOTNUM1 NO. GO TO SEE IF SIGN. 22374 09910018 BC ALWAYS,BADCHR YES. CHAR IS INVALID. 22374 09915018 PLUSS TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED 09920000 BC NONE,SCNRET NO 09940000 SSAME TM SWITCH,EXPSW WAS EXPONENT ENCOUNTERED 09960000 BC ALL,SCNRET YES 09980000 BC ALWAYS,ESAME NO, TREAT AS 'E'. 10000000 MINUSS TM SWITCH,DIGSW WAS DIGIT ENCOUNTERED 10020000 BC ALL,ESIGN YES 10040000 OI SWITCH,NEGDIG NO, SET NUMBER NEGATIVE. 10060000 BC ALWAYS,SCNRET 10080000 ESIGN OI SWITCH,NEGEXP SET EXPONENT NEGATIVE 10100000 BC ALWAYS,SSAME 10120000 DROP BASEC 10140000 * 10160000 EJECT 10180000 * 10200000 FCVFI DS 0H 10220000 FCVEI DS 0H 10240000 FCVDI DS 0H 10260000 FCVGI DS 0H 10280000 USING *,1 10300000 STM 2,13,SAVER SAVE REGISTERS 10320000 STD 2,FPSAV1 10340000 STD 4,FPSAV2 10360000 LR 13,15 10380000 L L,CIBCOM 10400000 EX 0,114(0,L) SET SWITCH TO IGNORE INTERRUPTS 10420000 L CALLIN,ADSCAN 10440000 BALR CALLBY,CALLIN SCAN AND CONVERT TO BINARY 10460000 LTR DATUM2,DATUM2 TEST LOW-ORDER INTEGER 10480000 BC NZERO,STASHI BRANCH IF NON-ZERO 10500000 LTR DATUM1,DATUM1 TEST HIGH-ORDER INTEGER 10520000 BC NZERO,STASHI BRANCH IF NON-ZERO 10540000 SDR RESULT,RESULT SET RESULT = 0 10560000 BC ALWAYS,CHECKS 10580000 STASHI STM DATUM1,DATUM2,INTGER STASH N IN WORK AREA 10600000 TM INTGER,X'FF' ROOM FOR CHARACTERISTIC 10620000 BC NONE,SET4E YES 10640000 SRDL DATUM1,4 NO, SHIFT OUT ONE HEX DIGIT. 10660000 STM DATUM1,DATUM2,INTGER 10680000 TM INTGER,X'0F' ENOUGH ROOM NOW 10700000 BC NONE,SET4F YES 10720000 SRDL DATUM1,4 NO, SHIFT OUT ONE MORE DIGIT. 10740000 STM DATUM1,DATUM2,INTGER 10760000 MVI INTGER,X'50' SET CHARACTERISTIC OF 16 10780000 BC ALWAYS,FLOATR 10800000 SET4F MVI INTGER,X'4F' SET CHARACTERISTIC OF 15 10820000 BC ALWAYS,FLOATR 10840000 SET4E MVI INTGER,X'4E' SET CHARACTERISTIC OF 14 10860000 FLOATR LD RESULT,CONFLT USING CONSTANT OF 0.0 * 16**14, 10880000 AD RESULT,INTGER FLOAT N. 10900000 SR SPLCTR,DECCTR OVERFLOW COUNT - DECIMAL COUNT 10920000 A SPLCTR,EXPON + INPUT EXPONENT. 10940000 TM SWITCH,EXPSW WAS THERE AN EXPONENT FIELD 10960000 BC ALL,CHECKX YES, IGNORE SCALE FACTOR. 10980000 MVC DIGIT+3(1),3(INDEX) 11000000 TM DIGIT+3,X'80' TEST SIGN OF SCALE FACTOR 11020000 BC NONE,SFPLUS BRANCH IF POSITIVE 11040000 NI DIGIT+3,X'7F' NEGATIVE, CLEAR SIGN BIT. 11060000 A SPLCTR,DIGIT INCREMENT EXPONENT 11080000 BC ALWAYS,CHECKX 11100000 SFPLUS S SPLCTR,DIGIT DECREMENT EXPONENT 11120000 CHECKX LTR SPLCTR,SPLCTR TEST SIGN OF EXPONENT 11140000 BC ZPLUS,POSEXP BRANCH IF POSITIVE 11160000 OI SWITCH,NEGSCL NEGATIVE, SET SWITCH. 11180000 POSEXP LPR DATUM2,SPLCTR FORCE EXPONENT POSITIVE 11200000 CH DATUM2,EXPMAX IS EXPONENT VALID 11220000 BC LOEQ,GETEXP YES 11240000 TM SWITCH,NEGSCL CHECK SIGN OF EXPONENT 11260000 BC ALL,SCLMAX BRANCH IF NEGATIVE 11280000 LD RESULT,MAXM SET RESULT=LARGEST POSSIBLE NO. 22800 11300000 BC ALWAYS,CHECKS 11320000 SCLMAX SH DATUM2,DEC19 REDUCE EXPONENT BY 19 11340000 CH DATUM2,EXPMAX 11360000 BC LOW,NOSCAL TEST FOR NUMBER IN RANGE 22800 11370000 SDR RESULT,RESULT SET RESULT TO ZERO FOR UNDERFLOW 22800 11380000 B CHECKS 22800 11390000 NOSCAL DD RESULT,TEN19 SCALE DOWN 22800 11400000 GETEXP SR DATUM1,DATUM1 11420000 D DATUM1,CONTEN SEPARATE TENS AND UNITS DIGITS 11440000 SLDA DATUM1,2 11460000 SLA DATUM2,1 11480000 SDR SCALE,SCALE 11500000 LE SCALE,ETABHX(DATUM1) PICKUP 10 ** UNITS 11520000 LTR DATUM2,DATUM2 11540000 BC ZERO,SCALER 11560000 MD SCALE,ETABHT(DATUM2) MULTIPLY BY 10 ** TENS 11580000 SCALER TM SWITCH,NEGSCL CHECK SIGN OF EXPONENT 11600000 BC NONE,SCALUP 11620000 DDR RESULT,SCALE NEGATIVE, SCALE DOWN. 11640000 BC ALWAYS,CHECKS 11660000 SCALUP MDR RESULT,SCALE POSITIVE, SCALE UP. 11680000 CHECKS TM SWITCH,NEGDIG WAS DATUM NEGATIVE 11700000 BC NONE,CHECKF NO 11720000 LNDR RESULT,RESULT YES, SET SIGN. 11740000 CHECKF TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 11760000 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X11766013 HANDLING OF ANY BOUNDARY MISALIGNMENT. 11772013 BC NONE,STDBLE 11780000 STE RESULT,0(0,GRX) SHORT-PRECISION REAL 11800000 EXITFI EX 0,118(0,L) RESUME PROCESSING OF INTERRUPTS 11820000 MVI INT6SW,X'00' RESET SWITCH 4648 11830013 LR 15,13 11840000 LD 2,FPSAV1 11860000 LD 4,FPSAV2 11880000 LM 2,13,SAVER RESTORE REGISTERS 11900000 LR 1,0 11920000 BC ALWAYS,4(0,1) RETURN TO CALLER 11940000 STDBLE STD RESULT,0(0,GRX) LONG-PRECISION REAL 11960000 BC ALWAYS,EXITFI 11980000 * 12000000 EJECT 12020000 * 12040000 FCVIO DS 0H 12060000 USING *,1 12080000 STM 2,7,SAVER SAVE REGISTERS 12100000 LR INDEX,0 GET ADDRESS OF PARAMETERS 12120000 SR WIDTH,WIDTH 12140000 IC WIDTH,1(0,INDEX) PICKUP FORMAT WIDTH 12160000 AR GRY,WIDTH POINT TO RIGHT END OF BUFFERAREA 12180000 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X12190013 HANDLING OF ANY BOUNDARY MISALIGNMENT. 12200013 TM 0(INDEX),X'05' CHECK LENGTH OF ITEM 4648 12210013 BC NONE,LDHALF 12220000 TM 0(INDEX),X'04' 4648 12226013 BC NONE,LDCHAR 4648 12232013 L NUMBER,0(0,GRX) FULL-WORD INTEGER 12240000 BC ALWAYS,GETSGN 12260000 LDHALF LH NUMBER,0(0,GRX) HALF-WORD INTEGER 12280000 GETSGN MVI SWITCH,C' ' ASSUME POSITIVE NUMBER 12300000 MVI INT6SW,X'00' RESET SWITCH 4648 12310013 LTR NUMBER,NUMBER 12320000 BC ZERO,ZEROINT INTEGER IS ZERO 4640 12330013 BC PLUS,CVTDEC INTEGER IS POSITIVE 4640 12340013 MVI SWITCH,C'-' RESET FOR NEGATIVE NUMBER 12360000 CVTDEC CVD NUMBER,CVAREA CONVERT TO DECIMAL, 12380000 UNPK CVAREA(15),CVAREA(8) UNPACKED FORM. 12400000 OI CVAREA+14,X'F0' SET PROPER ZONING 12420000 LA GRX,CVAREA+15 POINT TO RIGHT END OF NUMBER 12440000 LA INDEX,CVAREA 12460000 LA COUNT,15 12480000 ZEROCK CLI 0(INDEX),C'0' IGNORE LEADING ZEROS 12500000 BC NOTEQ,SIZCHK 12520000 LA INDEX,1(0,INDEX) 12540000 BCT COUNT,ZEROCK 12560000 ZEROINT BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 4640 12580013 MVI 0(GRY),C'0' STASH A ZERO IN BUFFER 12600000 BCT WIDTH,SETSGN 12620000 EXITIO LM 2,7,SAVER RESTORE REGISTERS 12640000 LR 1,0 12660000 BC ALWAYS,2(0,1) RETURN TO CALLER 12680000 LDCHAR SR NUMBER,NUMBER ONE-BYTE INTEGER (FOR 4648 12685013 IC NUMBER,0(0,GRX) CONVERSION OF 1-BYTE LOGICAL 4648 12690013 BC ALWAYS,GETSGN USING I-FORMAT) 4648 12695013 SIZCHK CR WIDTH,COUNT IS FIELD WIDTH ADEQUATE 12700000 BC LOW,STARS1 NO 12720000 BC EQUAL,SIGNCHK TEST IF NEGATIVE 4640 12730013 SETCHR BCTR GRX,0 MOVE LEFT ONE BYTE IN NUMBER 12740000 BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 12760000 MVC 0(1,GRY),0(GRX) MOVE ONE DIGIT TO BUFFER 12780000 BCT WIDTH,TESTC DECREMENT WIDTH 12800000 BC ALWAYS,EXITIO BRANCH IF EXHAUSTED 12820000 TESTC BCT COUNT,SETCHR DECREMENT SIGNIFICANT DIGITS 12840000 SETSGN BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 12860000 MVC 0(1,GRY),SWITCH SET SIGN OF NUMBER 12880000 TESTW BCT WIDTH,STBLNK DECREMENT WIDTH 12900000 BC ALWAYS,EXITIO BRANCH IF EXHAUSTED 12920000 STBLNK BCTR GRY,0 MOVE LEFT ONE BYTE IN BUFFER 12940000 MVI 0(GRY),C' ' STASH LEADING BLANKS 12960000 BC ALWAYS,TESTW 12980000 * 13000000 SIGNCHK CLI SWITCH,C'-' IS INTEGER NEGATIVE 4640 13006013 BC NOTEQ,SETCHR NO- FIELD ADEQUATE 4640 13012013 STARS1 L GRY,SAVER+4 13020000 STARS2 MVI 0(GRY),C'*' IF WIDTH WILL NOT ACCOMMODATE 13040000 LA GRY,1(0,GRY) ALL SIGNIFICANT DIGITS, 13060000 BCT WIDTH,STARS2 FILL FIELD WITH ASTERISKS. 13080000 BC ALWAYS,EXITIO 13100000 * 13120000 EJECT 13140000 * 13160000 FCVFO DS 0H 13180000 USING *,1 13200000 STM 2,13,SAVER SAVE REGISTERS 13220000 STD 6,FPSAV3 13240000 MVI SWITCH,NOEXP SET FOR NO EXPONENT FIELD 13260000 BAL CALLBY,FIXCVD FIX AND CONVERT TO BCD 13280000 LD 6,FPSAV3 13300000 LM 2,13,SAVER RESTORE REGISTERS 13320000 LR 1,0 13340000 BC ALWAYS,4(0,1) RETURN TO CALLER 13360000 * 13380000 FIXCVD BALR BASEC,0 LOAD BASE REGISTER 13400000 USING *,BASEC 13420000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 13440000 SR WIDTH,WIDTH INITIALIZE REGISTERS 13460000 SR DECCTR,DECCTR 13480000 SR SPLCTR,SPLCTR 13500000 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X13506013 HANDLING OF ANY BOUNDARY MISALIGNMENT. 13512013 TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 13520000 BC NONE,LDDBLE 13540000 SDR FLOAT,FLOAT 13560000 LE FLOAT,0(0,GRX) SHORT-PRECISION REAL 13580000 BC ALWAYS,STASHD 13600000 LDDBLE LD FLOAT,0(0,GRX) LONG-PRECISION REAL 13620000 STASHD STD FLOAT,DATUM 13640000 MVI INT6SW,X'00' RESET SWITCH 4648 13650013 TM DATUM,X'80' IS DATUM NEGATIVE 13660000 BC NONE,ZERTST NO 13680000 OI SWITCH,NEGDIG YES, SET SWITCH 13700000 NI DATUM,X'7F' AND CLEAR SIGN BIT. 13720000 LD FLOAT,DATUM RELOAD DATUM 13740000 ZERTST LTDR FLOAT,FLOAT 13760000 BC ZERO,ZERDAT BRANCH IF DATUM ZERO 13780000 LR 9,15 13800000 L L,CIBCOM 13820000 EX 0,114(0,L) SET SWITCH TO IGNORE INTERRUPTS 13840000 * 13860000 IC WIDTH,DATUM PLACE EXPONENT IN REGISTER 13880000 N WIDTH,MASK SET EXPONENT IN REGISTER 13900000 TM DATUM,X'08' CHECK SECOND DIGIT OF EXPONENT 13920000 BC NONE,SECTAB LESS THAN EIGHT - NO ADJUST. 13940000 LA WIDTH,8(WIDTH) GREATER - ADJUST TABLE INDEX 13960000 SECTAB LA DATUM1,CVTAB(WIDTH) SET ADDRESS OF SCALING FACTOR 13980000 MD FLOAT,0(0,DATUM1) 14000000 SRA WIDTH,2 ADJUST FOR EXPONENT CALCULATION 14020000 LA DATUM1,EXPTAX(WIDTH) LOAD ADDRESS OF EXPONENT TABLE 14040000 AH SPLCTR,0(DATUM1) ADD EXPONENT FROM TABLE 14060000 STE FLOAT,DATUM STORE AND TEST FOR SPECIAL CASE 14080000 UNITSC CLI DATUM,X'48' IS DATA NOW LESS THAN 10 ** +9 14100000 BC HIEQ,MULNIN IT IS GREATER - BRANCH 14120000 CLI DATUM,X'39' IS DATA NOW LESS THAN 10 ** -9 14140000 BC LOEQ,MUMNIN IF LESS THEN BRANCH 14160000 CLI DATUM,X'3C' 14180000 BC EQUAL,MM65 14200000 CLI DATUM,X'45' 14220000 BC EQUAL,M56 14240000 IC WIDTH,DATUM NOT A SPECIAL CASE - INSERT 14260000 N WIDTH,MASK1 EXPONENT AND MASK 14280000 SLL WIDTH,3 SHIFT TO SET UP TABLE ADDRESS 14300000 MUL LA DATUM1,CVTAB1(WIDTH) POINT TO PROPER SCALING FACTOR 14320000 MD FLOAT,0(0,DATUM1) 14340000 SRA WIDTH,2 ADJUST FOR EXPONENT CALCULATION 14360000 LA DATUM1,EXPTAY(WIDTH) LOAD EXPONENT TABLE ADDRESS 14380000 AH SPLCTR,0(DATUM1) ADD EXPONENT VALUE FROM TABLE 14400000 CNDIG STE FLOAT,DATUM 14420000 CLI DATUM,X'40' CHECK THAT SCALING IS IN BOUNDS 14440000 BC NOTEQ,UNITSC OUT-OF-BOUNDS - BRANCH 14460000 CH SPLCTR,EXPMAX IS EXPONENT LARGER THAN MAX 14480000 BH DEVELOP DONT ROUND FOR EXP GREATER THAN 75 20211 14488017 AD FLOAT,ROUNDER ROUND TO 16 PLACES 20211 14496017 CD FLOAT,CVTAB1 CHECK FOR RIPPLE CARRY 20211 14504017 BL DEVELOP BRANCH IF NO RIPPLE 20211 14512017 MD FLOAT,TENTH YES A RIPPLE ADJUST MANT BY 10 20211 14520017 AH SPLCTR,ONE AND EXPOMENT BY ONE 20211 14528017 * FINISHED WITH SCALLING BEGIN TO DEVELOP EBCDIC DIGITS 20211 14536017 DEVELOP MD FLOAT,S7 PICK OFF 7 DECIMAL DIGITS 20211 14544017 DBLCVT LA WIDTH,24 INITIALIZE POINTER TO CV AREA 14560000 AW FLOAT,S0 FIX FLOATING VARIABLE 14580000 STE FLOAT,DATUM STORE FLOATING INTEGER 14600000 MVI DATUM,X'00' MAKE INTO TRUE INTEGER 14620000 L DATUM1,DATUM LOAD INTEGER FOR CONVERSION 14640000 CVD DATUM1,INTCER(WIDTH) CONVERT INTO PROPER WORD 14660000 SH WIDTH,EIG ADJUST POINTER TO NEXT DBL WORD 14680000 BC ZERO,UNPK EXIT IF DONE 14700000 LA DATUM2,INTCER(WIDTH) DEVELOP ADDRESS OF CV AREA 14720000 NI 15(DATUM2),X'0F' ERASE LAST DIGIT 14740000 CVB DATUM1,INTCER+8(WIDTH) DETERMINE CORRECTION VALUE 14760000 ST DATUM1,INTCER(WIDTH) PLACE INTEGER IN SINGLE WORD 14780000 ST DECCTR,INTCER+4(WIDTH) STORE ZEROES TO MAKE DBL WORD 14800000 MVI 0(DATUM2),X'46' MAKE WORD A FLOATING VARIABLE 14820000 SD FLOAT,INTCER(WIDTH) ADJUST WORD BEING CONVERTED 14840000 MD FLOAT,S5 SCALE HEX DECIMAL TO INTEGER 14860000 BC ALWAYS,DBLCVT+4 REPEAT FOR A TOTAL OF THREE 14880000 * 14900000 MULNIN LA WIDTH,64 SET POINTER TO 10 ** +9 14920000 BC ALWAYS,MUL 14940000 MUMNIN LA WIDTH,72 SET POINTER TO 10 ** -9 14960000 BC ALWAYS,MUL 14980000 M56 TM DATUM+1,X'80' 15000000 BC NONE,M5 15020000 BC ALWAYS,M6 15040000 MM65 TM DATUM+1,X'80' 15060000 BC NONE,MM6 15080000 BC ALWAYS,MM5 15100000 M5 MD FLOAT,S5M 15120000 AH SPLCTR,FIV 15140000 BC ALWAYS,CNDIG 15160000 M6 MD FLOAT,S6M 15180000 AH SPLCTR,SIX 15200000 BC ALWAYS,CNDIG 15220000 MM6 MD FLOAT,S6 15240000 SH SPLCTR,SIX 15260000 BC ALWAYS,CNDIG 15280000 MM5 MD FLOAT,S5 15300000 SH SPLCTR,FIV 15320000 BC ALWAYS,CNDIG 15340000 * 15360000 UNPK UNPK CVAREA(7),INTCER+28(4) MOVE LEFT PART TO OUTPUT BUILD 15380000 UNPK CVAREA+6(6),INTCER+20(4) OVERLAY ONE,MOVE FOUR 15400000 UNPK CVAREA+11(6),INTCER+12(4) OVERLAY ONE,MOVE FOUR 15420000 * 15440000 EX 0,118(0,L) RESUME PROCESSING OF INTERRUPTS 15460000 LR 15,9 15480000 LA CHRSAV,CVAREA POINT TO START OF CONVERT AREA 15500000 LA MAXIM,16 SIXTEEN DIGITS MAXIMUM OUTPUT 15520000 ZERCHK CLI 0(CHRSAV),C'0' WAS THERE A LEADING ZERO 15540000 BC NOTEQ,TSTSCL NO 15560000 SH SPLCTR,CONONE YES, DECREMENT EXPONENT. 15580000 LA CHRSAV,1(0,CHRSAV) SKIP LEADING ZERO 15600000 BCTR MAXIM,0 15620000 BC ALWAYS,ZERCHK 15640000 TSTSCL SR FACTOR,FACTOR INITIALIZE FOR SCALING 15660000 ST FACTOR,EXPON 15680000 TM 3(INDEX),X'FF' WAS THERE A SCALE FACTOR 15700000 BC NONE,NOFACT NO 15720000 MVC EXPON+3(1),3(INDEX) YES 15740000 TM EXPON+3,X'80' TEST SIGN OF SCALE FACTOR 15760000 BC NONE,UPSCAL BRANCH IF POSITIVE 15780000 NI EXPON+3,X'7F' NEGATIVE, CLEAR SIGN BIT. 15800000 S FACTOR,EXPON DECREMENT EXPONENT 15820000 BC ALWAYS,ADJEXP 15840000 UPSCAL A FACTOR,EXPON INCREMENT EXPONENT 15860000 ADJEXP ST FACTOR,EXPON 15880000 NOFACT TM SWITCH,EDEXP WAS THIS F-CONVERSION 15900000 BC ALL,FEDOUT NO 15920000 AR FACTOR,SPLCTR YES, SCALING INCLUDES EXPONENT. 15940000 * 15960000 FEDOUT IC WIDTH,1(0,INDEX) PICKUP WIDTH 15980000 IC DECCTR,2(0,INDEX) AND NUMBER OF DECIMALS. 16000000 TM GFSWCH,ON 16020000 BC NONE,POSRND BRANCH IF NOT FLOATING DECIMAL 16040000 SR DECCTR,FACTOR 16060000 POSRND LR ROUNDR,FACTOR COMPUTE POSITION OF ROUND 16080000 AR ROUNDR,DECCTR 16100000 LTR ROUNDR,ROUNDR 16120000 BC MINUS,ROUNDO BRANCH IF ROUNDING IMPOSSIBLE 16140000 CH ROUNDR,RNDMAX 16160000 BC HIEQ,ROUNDO BRANCH IF PAST END OF DIGITS 16180000 AR ROUNDR,CHRSAV 16200000 CLI 0(ROUNDR),C'5' 16220000 BC LOW,ROUNDO CHARACTER PAST END IS LT 5 16240000 CNTRND BCTR ROUNDR,0 16260000 CR ROUNDR,CHRSAV 16280000 BC LOW,SETONE BRANCH IF RIPPLE CARRY COMPLETE 16300000 CLI 0(ROUNDR),C'9' 16320000 BC EQUAL,RIPPLE CHARACTER TO ROUND IS A 9 16340000 SR DIGRND,DIGRND 16360000 IC DIGRND,0(0,ROUNDR) 16380000 LA DIGRND,1(0,DIGRND) BUMP CHARACTER BY ONE 16400000 STC DIGRND,0(0,ROUNDR) 16420000 BC ALWAYS,ROUNDO 16440000 RIPPLE MVI 0(ROUNDR),C'0' CHARACTER 9 ROUNDS TO 0 16460000 BC ALWAYS,CNTRND 16480000 SETONE MVI 0(ROUNDR),C'1' SET 1 FROM RIPPLE CARRY 16500000 LR CHRSAV,ROUNDR INCLUDE EXTRA CHARACTER 16520000 LA MAXIM,1(0,MAXIM) 16540000 AH SPLCTR,CONONE INCREMENT EXPONENT 16560000 TM SWITCH,EDEXP 16580000 BC ALL,ROUNDO 16600000 AH FACTOR,CONONE F-CONVERSION 16620000 TM GFSWCH,ON 16640000 BC NONE,ROUNDO BRANCH IF NOT FLOATING DECIMAL 16660000 SH DECCTR,CONONE 16680000 * 16700000 ROUNDO LA MINIM,1(0,DECCTR) ALLOW FOR POINT AND D DECIMALS 16720000 LTR FACTOR,FACTOR 16740000 BC ZMINUS,EXPCHK BRANCH IF NO INTEGER PORTION 16760000 AR MINIM,FACTOR ALLOW FOR INTEGER DIGITS 16780000 EXPCHK TM SWITCH,NOEXP 16800000 BC ALL,MINCHK BRANCH IF F-CONVERSION 16820000 LA MINIM,4(0,MINIM) ALLOW FOR EXPONENT FIELD 16840000 MINCHK SR WIDTH,MINIM IS FIELD WIDTH ADEQUATE 16860000 BC MINUS,STARS3 NO 16880000 BC EQUAL,SIGNCHK1 CHECK IF MINUS SIGN NEEDED 4640 16890013 BUFADJ AR GRY,WIDTH YES, ADJUST BUFFER 4640 16900013 ST GRY,BEGPOS 16920000 LTR FACTOR,FACTOR TEST SCALING 16940000 BC ZERO,ZERFAC OUTPUT IS NORMALIZED 16960000 BC PLUS,POSFAC OUTPUT HAS INTEGER PORTION 16980000 LPR FACTOR,FACTOR DECIMAL PORTION HAS LEADING 0'S 17000000 MVI 0(GRY),C'.' SET DECIMAL POINT 17020000 LA GRY,1(0,GRY) 17040000 OI SWITCH,DECSW 17060000 LTR DECCTR,DECCTR 17080000 BC ZMINUS,LEADIN 17100000 NEGFAC MVI 0(GRY),C'0' SET LEADING ZEROS 17120000 LA GRY,1(0,GRY) 17140000 BCT DECCTR,ZERMOV 17160000 BC ALWAYS,LEADIN BRANCH IF DECIMALS EXHAUSTED 17180000 ZERMOV BCT FACTOR,NEGFAC 17200000 LR MOVER,DECCTR 17220000 BC ALWAYS,MAXCHK MOVE IN SIGNIFICANT DECIMALS 17240000 POSFAC OI SWITCH,POSSCL SET SWITCH FOR INTEGER 17260000 LR MOVER,FACTOR 17280000 BC ALWAYS,MAXCHK MOVE IN INTEGER PORTION 17300000 ZERFAC MVI 0(GRY),C'.' SET DECIMAL POINT 17320000 LA GRY,1(0,GRY) 17340000 OI SWITCH,DECSW 17360000 LTR DECCTR,DECCTR 17380000 BC ZMINUS,LEADIN BRANCH IF NO DECIMALS 17400000 LR MOVER,DECCTR 17420000 * 17440000 MAXCHK LTR MAXIM,MAXIM 17460000 BC ZMINUS,ZERSET BRANCH IF DIGITS EXHAUSTED 17480000 MOVDIG MVC 0(1,GRY),0(CHRSAV) FROM CONVERT AREA TO BUFFER 17500000 LA GRY,1(0,GRY) 17520000 LA CHRSAV,1(0,CHRSAV) 17540000 BCT MOVER,MOVCHK 17560000 BCTR MAXIM,0 17580000 BC ALWAYS,OUTCHK 17600000 MOVCHK BCT MAXIM,MOVDIG ANY MORE SIGNIFICANT DIGITS 17620000 ZERSET MVI 0(GRY),C'0' NO, FILL OUT FIELD WITH ZEROS. 17640000 LA GRY,1(0,GRY) 17660000 BCT MOVER,ZERSET 17680000 OUTCHK TM SWITCH,DECSW 17700000 BC NONE,ZERFAC BRANCH TO MOVE D DECIMALS 17720000 * 17740000 LEADIN LTR WIDTH,WIDTH 17760000 BCR ZERO,CALLBY BRANCH IF WIDTH EXHAUSTED 17780000 L GRY,BEGPOS 17800000 TM SWITCH,POSSCL 17820000 BC ALL,TSTSGN BRANCH IF INTEGER SET 17840000 BCTR GRY,0 17860000 TM SWITCH,NEGDIG 4640 17866013 BC NONE,LDZERO POSITIVE NUMBER 4640 17872013 CH WIDTH,CONONE TEST REMAINING BUFFER POSITIONS 4640 17878013 BC EQUAL,MINSGN ONLY ONE LEFT-ENTER MINUS SIGN 4640 17884013 LDZERO MVI 0(GRY),C'0' SET ZERO AS INTEGER 4640 17890013 BCT WIDTH,TSTSGN 17900000 BCR ALWAYS,CALLBY BRANCH IF WIDTH EXHAUSTED 17920000 TSTSGN TM SWITCH,NEGDIG 17940000 BC NONE,FILLUP BRANCH IF DATUM POSITIVE 17960000 BCTR GRY,0 17980000 MINSGN MVI 0(GRY),C'-' SET MINUS SIGN 4640 18000013 BCT WIDTH,FILLUP 18020000 BCR ALWAYS,CALLBY BRANCH IF WIDTH EXHAUSTED 18040000 FILLUP BCTR GRY,0 18060000 MVI 0(GRY),C' ' SET LEADING BLANKS 18080000 BCT WIDTH,FILLUP 18100000 BCR ALWAYS,CALLBY BRANCH IF WIDTH EXHAUSTED 18120000 * 18140000 SIGNCHK1 TM SWITCH,NEGDIG IS NUMBER NEGATIVE 4640 18146013 BC NONE,BUFADJ NO- FIELD ADEQUATE 4640 18152013 STARS3 AR WIDTH,MINIM RESTORE WIDTH 18160000 TM GFSWCH,ON IF THIS IS NOT G-FORMAT 2720 18165015 BC NONE,STARS4 TREATED AS F-FORMAT, BRANCH 2720 18170015 AH WIDTH,CONFOR RESTORE G-FORMAT WIDTH 2720 18175015 STARS4 MVI 0(GRY),C'*' IF WIDTH WILL NOT ACCOMMODATE 18180000 LA GRY,1(0,GRY) ALL SIGNIFICANT DIGITS, 18200000 BCT WIDTH,STARS4 FILL FIELD WITH ASTERISKS. 18220000 XITSKP LD 6,FPSAV3 18240000 LM 2,13,SAVER RESTORE REGISTERS 18260000 LR 1,0 18280000 BC ALWAYS,4(0,1) RETURN TO CALLER 18300000 * 18320000 ZERDAT IC WIDTH,1(0,INDEX) PICKUP WIDTH 18340000 IC DECCTR,2(0,INDEX) AND NUMBER OF DECIMALS. 18360000 CLEAR MVI 0(GRY),C' ' FILL FIELD WITH BLANKS 18380000 LA GRY,1(0,GRY) 18400000 BCT WIDTH,CLEAR 18420000 CHKEXP LA MAXIM,3 ASSUME AT LEAST 1 DEC PLACE.1748 18510015 LTR DECCTR,DECCTR IS DECIMAL WIDTH ZERO. 1748 18520015 BNZ *+8 IF NOT, BRANCH. 1748 18530015 LA MAXIM,2 REDUCE MOVE COUNT BY 1. 1748 18540015 LA MINIM,3(0,DECCTR) 7907 18580000 TM SWITCH,EDEXP 18600000 BC NONE,CHKSIZ BRANCH IF F-CONVERSION 18620000 LA MINIM,4(0,MINIM) ALLOW FOR EXPONENT FIELD 18640000 CHKSIZ LA CHRSAV,ZERPNT SET POINTER FOR MOVE. 1748 18670015 SR GRY,MINIM 18700000 COMPAR C GRY,SAVER+4 IS FIELD WIDTH ADEQUATE 18720000 BC HIEQ,SETZER BRANCH IF YES 18740000 LA GRY,1(0,GRY) 18760000 LA CHRSAV,1(0,CHRSAV) 18780000 BCT MAXIM,COMPAR TRY TO FIT WIDTH 18800000 IC WIDTH,1(0,INDEX) INADEQUATE FIELD WIDTH. 1748 18810015 L GRY,SAVER+4 NEEDED FOR WDTH LT DEC WDTH.1748 18820015 BC ALWAYS,STARS4 GO TO FILL WITH ASTERISKS. 1748 18830015 SETZER EX MAXIM,CHRMOV MOVE IN SIGN AND 0.0 18860000 BC ALWAYS,XITSKP 18880000 DROP BASEC 18900000 * 18920000 EJECT 18940000 * 18960000 FCVEO DS 0H 18980000 FCVDO DS 0H 19000000 USING *,1 19020000 STM 2,13,SAVER SAVE REGISTERS 19040000 STD 6,FPSAV3 19060000 MVI SWITCH,EDEXP SET FOR E OR D EXPONENT FIELD 19080000 L CALLIN,ADFIXR 19100000 BALR CALLBY,CALLIN FIX AND CONVERT TO BCD 19120000 L GRY,BEGPOS 19140000 AR GRY,MINIM COMPUTE POSITION 19160000 SH GRY,CONFOR OF EXPONENT FIELD. 19180000 TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 19200000 BC NONE,MOVED 19220000 MVI 0(GRY),C'E' FOUR BYTES, SET E-CHARACTER. 19240000 BC ALWAYS,EXPSGN 19260000 MOVED MVI 0(GRY),C'D' EIGHT BYTES, SET D-CHARACTER. 19280000 EXPSGN S SPLCTR,EXPON ADJUST EXPONENT BY SCALE FACTOR, 19300000 LTR SPLCTR,SPLCTR AND TEST SIGN. 19320000 BC MINUS,SETNEG 19340000 MVI 1(GRY),C' ' POSITIVE, SET BLANK SIGN. 19360000 BC ALWAYS,EXPCVT 19380000 SETNEG MVI 1(GRY),C'-' NEGATIVE, SET MINUS SIGN. 19400000 LPR SPLCTR,SPLCTR 19420000 EXPCVT CVD SPLCTR,CVAREA CONVERT TO DECIMAL, 19440000 UNPK CVAREA(2),CVAREA+6(2) UNPACKED FORM. 19460000 OI CVAREA+1,X'F0' SET PROPER ZONING, 19480000 MVC 2(2,GRY),CVAREA AND MOVE IN TWO DIGITS. 19500000 LD 6,FPSAV3 19520000 LM 2,13,SAVER RESTORE REGISTERS 19540000 LR 1,0 19560000 BC ALWAYS,4(0,1) RETURN TO CALLER 19580000 * 19600000 EJECT 19620000 * 19640000 FCVGO DS 0H 19660000 USING *,1 19680000 STM 0,7,SAVEG SAVE REGISTERS 19700000 STD 4,FPSAV4 19720000 STD 6,FPSAV5 19740000 BALR BASEG,0 LOAD BASE REGISTER 19760000 USING *,BASEG 19780000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 19800000 MVI INT6SW,X'FF' SET SWITCH ON TO ALLOW 4648X19806013 HANDLING OF ANY BOUNDARY MISALIGNMENT. 19812013 TM 0(INDEX),X'04' CHECK LENGTH OF ITEM 19820000 BC NONE,GETDBL 19840000 SDR FLOAT,FLOAT 19860000 LE FLOAT,0(0,GRX) SHORT-PRECISION REAL 19880000 BC ALWAYS,CHKDBL 19900000 GETDBL LD FLOAT,0(0,GRX) LONG-PRECISION REAL 19920000 CHKDBL LPDR FLOAT,FLOAT 19940000 CD FLOAT,TENTH 19960000 MVI INT6SW,X'00' RESET SWITCH 4648 19970013 BC LOW,USECVE BRANCH IF ITEM LT 0.1 19980000 SR DECCTR,DECCTR 20000000 IC DECCTR,2(0,INDEX) PICKUP NUMBER OF DECIMALS 20020000 SR WIDTH,WIDTH 20040000 D WIDTH,CONTEN SEPARATE TENS AND UNITS DIGITS 20060000 SLDA WIDTH,2 20080000 SLA DECCTR,1 20100000 SDR SCALE,SCALE 20120000 LE SCALE,ETABHX(WIDTH) PICKUP 10 ** UNITS 20140000 LTR DECCTR,DECCTR 20160000 BC ZERO,EXPDEC 20180000 MD SCALE,ETABHT(DECCTR) MULTIPLY BY 10 ** TENS 20200000 EXPDEC CDR FLOAT,SCALE 20220000 BC HIGH,USECVE BRANCH IF ITEM GT 10**D 20240000 MVC GPARS1(3),0(INDEX) IGNORE SCALE FACTOR 20260000 MVI GFSWCH,ON SET FOR FLOATING DECIMAL 20280000 TM CGSWCH,ON 20300000 BC ALL,USECVF BRANCH IF COMPLEX CALL 20320000 SR WIDTH,WIDTH 20340000 IC WIDTH,GPARS1+1 20360000 SH WIDTH,CONFOR REDUCE WIDTH BY FOUR 20380000 BC PLUS,PASSWDTH FALL THROUGH IF WIDTH LT 5. 2720 20385015 AH WIDTH,CONFOR RESTORE WIDTH. 2720 20390015 STARS5 MVI 0(GRY),C'*' WIDTH WILL NOT ACCOMMODATE 2720 20395015 LA GRY,1(0,GRY) ANY SIGNIFICANT DIGITS. 2720 20400015 BCT WIDTH,STARS5 FILL FIELD WITH ASTERISKS. 2720 20405015 BC ALWAYS,FEXIT BYPASS GOING TO F-CONVERT. 2720 20410015 PASSWDTH STC WIDTH,GPARS1+1 PLACE WIDTH-4 FOR F-CNVRT. 2720 20415015 AR WIDTH,GRY 20420000 MVC 0(4,WIDTH),CONBLK INSERT 4 BLANKS AT RIGHT 20440000 USECVF L 1,ADFOUT 20460000 BALR 0,1 USE F-CONVERSION 20480000 GPARS1 DC AL4(0) 20500000 FEXIT MVI GFSWCH,OFF SET OFF SWITCH FOR G-FORMAT 2720C20510015 TREATED AS F-FORMAT. 2720 20520015 BC ALWAYS,EXITGO 20540000 USECVE MVC GPARS2(4),0(INDEX) INCLUDE SCALE FACTOR 20560000 L 1,ADEOUT 20580000 BALR 0,1 USE E-CONVERSION 20600000 GPARS2 DC AL4(0) 20620000 EXITGO LD 4,FPSAV4 20640000 LD 6,FPSAV5 20660000 LM 0,7,SAVEG RESTORE REGISTERS 20680000 LR 1,0 20700000 BC ALWAYS,4(0,1) RETURN TO CALLER 20720000 DROP BASEG 20740000 * 20760000 EJECT 20780000 * 20800000 FCVCI DS 0H 20820000 USING *,1 20840000 STM 2,9,SAVEC SAVE REGISTERS 20860000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 20880000 SR COUNT,COUNT 20900000 SR WIDTH,WIDTH 20920000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 20940000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 20960000 SRA COUNT,1 20980000 STC COUNT,PARINP SET HALF OF ITEM LENGTH, 21000000 MVC PARINP+2(2),2(INDEX) PLUS DECIMALS AND SCALEFACTOR 21020000 LPAREN CLI 0(GRY),C'(' 21040000 BC EQUAL,CMPLXN BRANCH ON LEFT PARENTHESIS 21060000 CLI 0(GRY),X'6C' 21080000 BC EQUAL,CMPLXN BRANCH IF BCD LEFT PAREN 21100000 LA GRY,1(0,GRY) 21120000 BCT WIDTH,LPAREN 21140000 BC ALWAYS,ZERO1 BRANCH IF WIDTH EXHAUSTED 21160000 CMPLXN LA GRY,1(0,GRY) 21180000 ST GRY,CMPLXA SAVE START OF NUMBER, 21200000 SR NUMBER,NUMBER AND INITIALIZE COUNT. 21220000 BC ALWAYS,SUBCOM 21240000 COMMA CLI 0(GRY),C',' 21260000 BC EQUAL,HALF1 BRANCH ON COMMA 21280000 LA NUMBER,1(0,NUMBER) INCREMENT COUNT 21300000 LA GRY,1(0,GRY) 21320000 SUBCOM BCT WIDTH,COMMA 21340000 BC ALWAYS,ZERO1 BRANCH IF WIDTH EXHAUSTED 21360000 HALF1 BAL CALLIN,CVTINP CONVERT FIRST HALF 21380000 LA GRY,1(0,GRY) 21400000 ST GRY,CMPLXA SAVE START OF NUMBER, 21420000 SR NUMBER,NUMBER AND INITIALIZE COUNT. 21440000 AR GRX,COUNT POINT TO LAST HALF OF ITEM 21460000 BC ALWAYS,SUBPAR 21480000 RPAREN CLI 0(GRY),C')' 21500000 BC EQUAL,HALF2 BRANCH ON RIGHT PARENTHESIS 21520000 CLI 0(GRY),X'4C' 21540000 BC EQUAL,HALF2 BRANCH IF BCD RIGHT PAREN 21560000 LA NUMBER,1(0,NUMBER) INCREMENT COUNT 21580000 LA GRY,1(0,GRY) 21600000 SUBPAR BCT WIDTH,RPAREN 21620000 BC ALWAYS,ZERO1 BRANCH IF WIDTH EXHAUSTED 21640000 HALF2 BAL CALLIN,CVTINP CONVERT SECOND HALF 21660000 BC ALWAYS,EXITCI 21680000 * 21700000 CVTINP STC NUMBER,PARINP+1 SET DIGIT COUNT AS WIDTH 21720000 STM 0,3,TEMPX TEMPORARY SAVE 21740000 BALR BASEH,0 LOAD BASE REGISTER 21760000 USING *,BASEH 21780000 L GRY,CMPLXA POINT TO START OF DIGITS 21800000 L 1,ADGINP 21820000 BALR 0,1 CALL G-INPUT CONVERSION 21840000 PARINP DC AL4(0) 21860000 LM 0,3,TEMPX RESTORE 21880000 DROP BASEH 21900000 BCR ALWAYS,CALLIN RETURN 21920000 * 21940000 ZERO1 L GRX,SAVEC 21960000 IC COUNT,0(0,INDEX) 21980000 ZERO2 MVI 0(GRX),X'00' ZERO INPUT ITEM 22000000 LA GRX,1(0,GRX) 22020000 BCT COUNT,ZERO2 22040000 EXITCI LM 2,9,SAVEC RESTORE REGISTERS 22060000 LR 1,0 22080000 BC ALWAYS,4(0,1) RETURN TO CALLER 22100000 * 22120000 SPACE 3 22140000 * 22160000 FCVCO DS 0H 22180000 USING *,1 22200000 STM 2,9,SAVEC SAVE REGISTERS 22220000 MVI CGSWCH,ON SET G-OUTPUT SWITCH ON 22240000 LR INDEX,0 PREPARE TO ADDRESS PARAMETERS 22260000 SR COUNT,COUNT 22280000 SR WIDTH,WIDTH 22300000 IC COUNT,0(0,INDEX) PICKUP ITEM LENGTH 22320000 IC WIDTH,1(0,INDEX) AND FORMAT WIDTH. 22340000 SRA COUNT,1 22360000 STC COUNT,PAROUT SET HALF OF ITEM LENGTH, 22380000 MVC PAROUT+2(2),2(INDEX) PLUS DECIMALS AND SCALEFACTOR 22400000 AR GRX,COUNT POINT TO LAST HALF OF ITEM 22420000 AR GRY,WIDTH POINT TO RIGHT END OF BUFFERAREA 22440000 BCTR GRY,0 22460000 MVI 0(GRY),C')' SET RIGHT PARENTHESIS 22480000 BAL CALLIN,CVTOUT CONVERT SECOND HALF 22500000 SR GRX,COUNT POINT TO FIRST HALF OF ITEM 22520000 BCTR GRY,0 22540000 MVI 0(GRY),C',' SET COMMA 22560000 BAL CALLIN,CVTOUT CONVERT FIRST HALF 22580000 BCTR GRY,0 22600000 MVI 0(GRY),C'(' SET LEFT PARENTHESIS 22620000 EXITCO MVI CGSWCH,OFF SET G-OUTPUT SWITCH OFF 22640000 LM 2,9,SAVEC RESTORE REGISTERS 22660000 LR 1,0 22680000 BC ALWAYS,4(0,1) RETURN TO CALLER 22700000 * 22720000 CVTOUT SH WIDTH,CONONE 22740000 BC ZMINUS,EXITCO EXIT IF WIDTH EXHAUSTED 22760000 STC WIDTH,PAROUT+1 SET REMAINING SPACE AS WIDTH 22780000 SR GRY,WIDTH POINT TO START OF SPACE 22800000 STM 0,1,TEMPX TEMPORARY SAVE 22820000 BALR BASEH,0 LOAD BASE REGISTER 22840000 USING *,BASEH 22860000 L 1,ADGOUT 22880000 BALR 0,1 CALL G-OUTPUT CONVERSION 22900000 PAROUT DC AL4(0) 22920000 LM 0,1,TEMPX RESTORE 22940000 DROP BASEH 22960000 SR WIDTH,WIDTH INITIALIZE COUNT 22980000 BLKCHK CLI 0(GRY),C' ' 23000000 BC NOTEQ,CWIDTH BRANCH IF NON-BLANK 23020000 LA WIDTH,1(0,WIDTH) INCREMENT COUNT 23040000 LA GRY,1(0,GRY) 23060000 BC ALWAYS,BLKCHK 23080000 CWIDTH LTR WIDTH,WIDTH 23100000 BC ZMINUS,EXITCO EXIT IF WIDTH EXHAUSTED 23120000 BCR ALWAYS,CALLIN 23140000 * 23160000 EJECT 23180000 * 23200000 * TABLE OF POWERS OF TEN IN HEXADECIMAL FLOATING POINT 23220000 * 23240000 ETABHX DS 0F 23260000 DC X'41100000' 10**0 23280000 DC X'41A00000' 10**1 23300000 DC X'42640000' 10**2 23320000 DC X'433E8000' 10**3 23340000 DC X'44271000' 10**4 23360000 DC X'45186A00' 10**5 23380000 DC X'45F42400' 10**6 23400000 DC X'46989680' 10**7 23420000 DC X'475F5E10' 10**8 23440000 DC X'483B9ACA' 10**9 23460000 ETABHT DS 0D 23480000 TEN19 DC X'508AC7230489E800' FILL 23500000 DC X'492540BE40000000' 10**10 23520000 DC X'5156BC75E2D63100' 10**20 23540000 DC X'59C9F2C9CD04674F' 10**30 23560000 DC X'621D6329F1C35CA5' 10**40 23580000 DC X'6A446C3B15F99267' 10**50 23600000 DC X'729F4F2726179A23' 10**60 23620000 DC X'7B172EBAD6DDC73C' 10**70 23640000 CONFLT DC X'4E00000000000000' 23660000 * 23680000 SPACE 3 23700000 EJECT 23720000 * 23740000 * DATA AND STORAGE, NEW DECIMAL OUTPUT 23760000 * 23780000 INTCER DS 4D 23800000 CVTAB DS 0D 23820000 DC X'7B172EBAD6DDC73C' 10**70 23840000 DC X'729F4F2726179A23' 10**60 23860000 DC X'6A446C3B15F99267' 10**50 23880000 DC X'621D6329F1C35CA5' 10**40 23900000 DC X'621D6329F1C35CA5' 10**40 23920000 DC X'59C9F2C9CD04674F' 10**30 23940000 DC X'5156BC75E2D63100' 10**20 23960000 DC X'492540BE40000000' 10**10 23980000 DC X'4110000000000000' 24000000 DC X'3944B82FA09B5A52' 10 ** -9 24020000 DC X'302F394219248446' 10 ** -20 24040000 DC X'2814484BFEEBC2A1' 10 ** -30 24060000 DC X'1F8B61313BBABCF9' 10 ** -40 24080000 DC X'173BDCF495A97046' 10 ** -50 24100000 DC X'0F19B604AAACA62B' 10 ** -60 24120000 DC X'06B0AF48EC79AD21' 10 ** -70 24140000 CVTAB1 DS 0D 24160000 DC X'4110000000000000' 10 ** 0 24180000 TENTH DC X'401999999999999A' 10**-1 20211 24200017 DC X'3F28F5C28F5C28F6' 10 ** -2 24220000 DC X'3E4189374BC6A7F0' 10 ** -3 24240000 DC X'3D68DB8BAC710CB2' 10 ** -4 24260000 S6M DC X'3C10C6F7A0B5ED8D' 10 ** -6 24280000 DC X'3B1AD7F29ABCAF48' 10 ** -7 24300000 DC X'3A2AF31DC4611873' 10 ** -8 24320000 DC X'3944B82FA09B5A52' 10 ** -9 24340000 DC X'483B9ACA00000000' 10**9 24360000 DC X'475F5E1000000000' 10**8 24380000 S7 DC X'4698968000000000' 10**7 24400000 S5 DC X'45186A0000000000' 10**5 24420000 DC X'4427100000000000' 10**4 24440000 DC X'433E800000000000' 10**3 24460000 DC X'4264000000000000' 10**2 24480000 S5M DC X'3CA7C5AC471B4784' 10 ** -5 24500000 S6 DC X'45F4240000000000' 10**6 24520000 S0 DC X'4600000000000000' NORMALIZING FACTOR 4660 24540015 ROUNDER DC X'4000000000000004' ROUNDING FACTOR 20211 24546017 * ROUNDING FACTOR IS .5551 10**-16 THIS IS OBTAINED FROM 20211 24552017 * ROUNDING .5 10**-16 WHICH IS 3339A5652FB11378 20211 24558017 * FACTOR IS UNNORMALIZED TO SAVE TIME DURING EXECUTION 20211 24564017 MAXM DC X'7FFFFFFFFFFFFFFF' MAX. FLOAT POINT NO. 22800 24572000 MASK DC X'000000F0' 24580000 MASK1 DC X'0000000F' 24600000 EXPTAX DC X'FFBA' -70 24620000 DC X'FFC4' -60 24640000 DC X'FFCE' -50 24660000 DC X'FFD8' -40 24680000 DC X'FFD8' -40 24700000 DC X'FFE2' -30 24720000 DC X'FFEC' -20 24740000 DC X'FFF6' -10 24760000 DC X'0000' 0 24780000 DC X'0009' +9 24800000 TWT DC X'0014' 24820000 THT DC X'001E' 24840000 FRT DC X'0028' 24860000 FFT DC X'0032' 24880000 SXT DC X'003C' 24900000 SVT DC X'0046' 24920000 EXPTAY DC X'0000' ZERO 24940000 ONE DC X'0001' 24960000 TWO DC X'0002' 24980000 THR DC X'0003' 25000000 FOU DC X'0004' 25020000 FIV DC X'0005' 25040000 SEV DC X'0007' 25060000 EIG DC X'0008' 25080000 NIN DC X'0009' 25100000 DC X'FFF7' -9 25120000 DC X'FFF8' -8 25140000 DC X'FFF9' -7 25160000 DC X'FFFA' -6 25180000 DC X'FFFC' -4 25200000 DC X'FFFD' -3 25220000 DC X'FFFE' -2 25240000 SIX DC X'0006' 25260000 DC X'FFFB' -5 25280000 * 25300000 EJECT 25320000 * 25340000 * DATA AND STORAGE AREAS 25360000 * 25380000 MOVEY MVC 0(1,GRX),0(GRY) BUFFER TO ITEM 25381016 MOVEX MVC 0(1,GRY),0(GRX) ITEM TO BUFFER 25382016 VIHCERRM DC V(IHCERRM) ADDRESS OF ERROR MONITOR 25383016 CIBCOM DC A(IBCOM#) 1748 25386015 SAVER DS 12F REGISTER STORAGE 1748 25392015 TRANS DC AL4(0) TRANSLATION 1748 25398015 SWITCH DC AL1(0) SCAN SWITCHES 1748 25404015 ALPHA DC X'FAFBFCFDFEFF' INPUT TRANSLATION TABLE 1748 25410015 INT6SW DC X'00' BOUNDARY MISALIGNMENT SW 4648 25411016 INT6SWCH EQU INT6SW 25412016 FCVEOUTP EQU FCVEO 25413016 FCVLOUTP EQU FCVLO 25414016 FCVIOUTP EQU FCVIO 25415016 FCVCOUTP EQU FCVCO 25416016 FCVAOUTP EQU FCVAO 25417016 FCVZOUTP EQU FCVZO 25418016 ADSCAN DC A(SCNCVB) 1748 25420015 ADFIXR DC A(FIXCVD) 1748 25430015 ADGINP DC A(FCVGI) 1748 25440015 ADGOUT DC A(FCVGO) 1748 25450015 ADFOUT DC A(FCVFO) 1748 25460015 ADEOUT DC A(FCVEO) 1748 25470015 * 25540000 SAVEG DS 8F REGISTER STORAGE 25580000 SAVEC DS 8F REGISTER STORAGE 25600000 TEMPX DS 4F TEMPORARY STORAGE 25620000 FPSAV1 DS 1D 25640000 FPSAV2 DS 1D 25660000 FPSAV3 DS 1D 25680000 FPSAV4 DS 1D 25700000 FPSAV5 DS 1D 25720000 * 25740000 DATUM DS 1D INTEGER STORAGE 25760000 INTGER DS 1D TEMPORARY 25780000 DIGIT DS 1F DIGIT STORAGE 25800000 EXPON DS 1F EXPONENT STORAGE 25820000 EXPMAX DC AL2(75) 25840000 DEC19 DC AL2(19) 25860000 RNDMAX DC AL2(16) 25880000 CVAREA DS 2D DECIMAL CONVERT AREA 25920000 BEGPOS DS 1F START OF SIGNIFICANT DIGITS 25940000 CMPLXA DS 1F START OF COMPLEX NUMBER 25960000 HIBYTE DC X'0FFFFFFF' 25980000 CONTEN DC AL4(10) 26000000 CONBLK DC CL4' ' 26020000 CHRMOV MVC 0(1,GRY),0(CHRSAV) MOVE FROM CONVERT AREA 26080000 CONONE EQU ONE 26100000 CONFOR EQU FOU 26120000 GFSWCH DC AL1(0) G-FORMAT TREATED AS F- SW 2720 26140015 CGSWCH DC AL1(0) COMPLEX DATA G-OUTPUT SW 2720 26160015 DECIM DC C'0123456789ABCDEF' OUTPUT TRANSLATION TABLE 26220000 ZERPNT DC C' 0.0' 26240000 * 26260000 PRMS DC A(MSG) ADDRESS OF MESSAGE 26261016 DC A(RETCD) ADDRESS OF RETURN CODE FIELD 26262016 DC A(ERRORNO) ADDRESS OF ERROR NUMBER 26263016 DC A(0) ADDRESS OF BAD CHARACTER 26264016 ERRORNO DC F'0' 26265016 RETCD DC F'0' 26266016 INREG DS 1F 20443 26266318 ADLAB DC A(LAB) 20443 26266618 AREA DC AL2(0) AREA FOR UNPACK IN FCVZO 7/8 63563 26266722 ATESAV DC F'0' TEMP SAVE 8/8 63563 26266822 EJECT 26267016 * 26268016 * 26269016 * MESSAGES 26270016 DCML DC C' DECIMAL ' 26271016 HXDCML DC C'HEXADECIMAL' 26272016 MSG DC F'49' 26273016 DC C'IHC2 5I CONVERT - ILLEGAL CHARACTER ' 26274016 SPACE 3 26280000 END 26300000 ./ ADD SSI=01010726,NAME=IHCFCXPI,SOURCE=0 IHCFCXPI CSECT 00020000 * 2/23/66 00040000 EXTRN IBCOM# 00060000 EXTRN IHCERRM 00070016 EXTRN CMPY# 00080000 EXTRN CDVD# 00100000 ENTRY FCXPI# 00120000 * SGL PREC COMPLEX NUMBER BASE, FIXED POINT EXPONENT LIBRARY ROUTINE 00140000 USING *,15 00160000 FCXPI# B 12(0,15) 00180000 DC AL1(6) 00200000 DC CL6'FCXPI#' 00220000 STM RTN,BASADD,12(SAVE) 00224016 BALR BASADD,0 00228016 USING *,BASADD 00232016 LR ADDR,SAVE 00236016 LA SAVE,SAVREG 00240016 ST ADDR,4(SAVE) 00244016 ST SAVE,8(ADDR) 00248016 BEGIN EQU * 00252016 L ADDR,0(0,PLIST) LOAD PLIST OF COMPLEX NO IN ADDR REG 00260000 LE REAL,0(0,ADDR) LOAD REAL PART OF NO INTO REAL REG 00280000 LE IMAG,4(0,ADDR) LOAD IMAG PART OF NO INTO IMAG REG 00300000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00320000 L EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00340000 LTER REAL,REAL CHECK IF REAL NO PLUS, MINUS,OR ZERO 00400000 BC 6,TEST IF REAL NO NOT ZERO, BRANCH TO TEST 00420000 LTER IMAG,IMAG CHECK IF IMAG NO PLUS, MINUS,OR ZERO 00440000 BC 8,ERROR IF IMAG NO IS ZERO, BRANCH TO ERROR 00460000 TEST SR EXPSW,EXPSW SET NEGATIVE EXPN SWITCH REG TO ZERO 00480000 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00500000 BC 2,PLUS IF EXPN IS POSITIVE, BRANCH TO PLUS 00520000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00540000 LCR EXPN,EXPN EXPN MINUS, CONVERT TO 2S COMPLIMENT 00560000 LA EXPSW,1(EXPSW) SET EXP SW REG TO ONE FOR MINUS EXPN 00580000 PLUS MVC FACTR(8),ONE 00640016 LOOP STE REAL,BASER STORE REAL PART COMPLEX NO AT BASER 00700000 STE IMAG,BASEI STORE IMAG PART COMPLEX NO AT BASEI 00720000 SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 00740000 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 00760000 BC 10,JUMP IF SIGN BIT NOT MINUS,BRANCH TO JUMP 00780000 LA PLIST,PARAM2 SET PARAM LIST REG FOR CMPY ROUTINE 00800000 L LINK,ACMPY LOAD ADCON OF CMPY RTN IN LINK REG 00820000 BALR RTN,LINK BRANCH TO CMPY RTN FOR COMPLEX MULT 00840000 STE REAL,FACTR STORE REAL PART COMPLEX NO AT FACTR 00860000 STE IMAG,FACTI STORE IMAG PART COMPLEX NO AT FACTI 00880000 JUMP LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00900000 BC 8,NEXT IF EXPONENT NOW ZERO, BRANCH TO NEXT 00920000 LA PLIST,PARAM3 SET PARAM LIST REG FOR CMPY ROUTINE 00940000 L LINK,ACMPY LOAD ADCON OF CMPY RTN IN LINK REG 00960000 BALR RTN,LINK BRANCH TO CMPY RTN FOR COMPLEX MULT 00980000 BC 15,LOOP BRANCH TO LOOP TO TEST NEXT EXPN BIT 01000000 NEXT LTR EXPSW,EXPSW TEST IF EXPSW REG PLUS,MINUS,OR ZERO 01020000 BC 8,EXIT IF EXP NOT MINUS-TO EXIT 01040016 LA PLIST,PARAM1 SET PARAM LIST REG FOR CDVD ROUTINE 01060000 L LINK,ACDVD LOAD ADCON OF CDVD RTN IN LINK REG 01080000 BALR RTN,LINK BRANCH TO CDVD RTN FOR COMPLEX DVSN 01100000 BC 15,EXIT BRANCH TO EXIT(RESULT IN FP REG 0,2) 01140000 LOAD1 LE REAL,ONE LOAD ONE AS REAL RESULT IN REAL REG 01160000 LE IMAG,ZERO LOAD ZERO AS IMAG RESULT IN IMAG REG 01180000 EXIT L SAVE,4(SAVE) 01190016 LM RTN,BASADD,12(SAVE) 01200016 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 01220000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 01240000 ERROR LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 01260000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 01280000 STE REAL,BASER STORE FOR USER TO FIX UP 01285016 STE IMAG,BASEI 01290016 ST EXPN,EXPON 01295016 LA 2,EXPON 01300016 LA 3,MSGDATA 01305016 LM RTN,LINK,AERRMON ADDR ERMON IN 14, ADDR IBCOM IN 15 01310016 EX 0,82(LINK) ADDR OF I CONVERSION 01315016 BALR 0,1 01320016 DC X'040B' LL=4 WW=11 01325016 LA PLIST,ERRLIST 01330016 LR LINK,RTN ADDR OF ERRMON IN 15 FOR BALR 01335016 BALR 14,15 TO ERROR MONITOR 01340016 CLI RETCODE+3,X'00' DID USER FIX DATA 01345016 BZ EXIT RESULT IN REG ALREADY ZERO 01350016 FIXUP LA PLIST,ERRLIST+12 POINT TO ADCONS OF DATA 01355016 B BEGIN 01360016 EJECT 01365016 * FLOATING POINT REGISTERS 01380000 REAL EQU 0 REGISTER FOR REAL PART OF COMPLEX NO 01400000 IMAG EQU 2 REGISTER FOR IMAG PART OF COMPLEX NO 01420000 * GENERAL PURPOSE REGISTERS 01440000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01460000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01480000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01500000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01520000 EXPN EQU 2 EXP FOR COMPUTATION 01540016 ADDR EQU 3 INDEX PARAM 01560016 EXPSW EQU 4 TEST FOR MINUS EXPN 01580016 BASADD EQU 5 01600016 * ADCONS AND CONSTANTS AREA 01620000 SAVREG DS 18F 01640016 BASER DS F USED TO HOLD REAL PART BASE NO 01660000 BASEI DS F USED TO HOLD IMAG PART BASE NO 01680000 FACTR DC X'41100000' USED IN FACTORING REAL BASE NO 01700000 FACTI DC X'00000000' USED IN FACTORING IMAG BASE NO 01720000 ONE DC X'41100000' CONSTANT ONE IN SINGLE PREC F P 01740000 ZERO DC X'00000000' CONS OF ZERO IN SINGLE PREC F P 01760000 PARAM1 DC AL4(ONE) ADCON OF 1ST PARAM IN CDVD RTN 01780000 PARAM2 DC AL4(FACTR) ADCON OF 2ND PARAM IN CDVD RTN 01800000 PARAM3 DC AL4(BASER) ADCON OF 1ST PARAM IN CMPY RTN 01820000 DC AL4(BASER) ADCON OF 2ND PARAM IN CMPY RTN 01840000 ACMPY DC AL4(CMPY#) ADCON OF CMPY MATH LIBRARY RTN 01860000 ACDVD DC AL4(CDVD#) ADCON OF CDVD MATH LIBRARY RTN 01880000 AERRMON DC V(IHCERRM) 01890016 VIBCOM DC A(IBCOM#) ADCON OF STANDARD ERROR ROUTINE 01900000 EXPON DS F 01901016 ERRLIST DC A(MSGLNG) 01902016 DC A(RETCODE) 01903016 DC A(ERRNUM) 01904016 DC A(BASER) USER INFORMATION IS REAL BASE, 01905016 DC X'80' IMAG BASE, AND EXPONENT 01906016 DC AL3(EXPON) 01907016 ERRNUM DC F'246' 01908016 RETCODE DS F 01909016 EJECT 01910016 MSGLNG DC A(ENDMSG-MSG) 01911016 MSG DC C'IHC246I FCXPI COMPLEX*8 BASE=0.0+0.0I, INTEGER EXPONENX01912016 T=' 01913016 MSGDATA DS 11C 01914016 DC C', LE 0' 01915016 ENDMSG EQU * 01916016 END 01920000 ./ ADD SSI=02010722,NAME=IHCFDUMP,SOURCE=0 IHCFDUMP START 0 00020000 ENTRY DUMP POST-MORTEM DUMP 00040000 ENTRY PDUMP DYNAMIC DUMP 00060000 EXTRN IBCOM# 00080000 SPACE 3 00100000 * CALLING SEQUENCE 00120000 * LA S,SAVLOC 00140000 * LA A,ARGLST 00160000 * L L,=V(DUMP)/=V(PDUMP) 00180000 * BALR R,L 00200000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00220000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00240000 * DC AL4(A1) 00260000 * DC AL4(B1) 00280000 * DC AL4(F1) 00300000 * ... ... 00320000 * ... ... 00340000 * DC AL4(AN) 00360000 * DC AL4(BN) 00380000 * DC XL1'FF',AL3(FN) 00400000 * WHERE A AND B ARE CORE ADDRESSES WHICH INDICATE 00420000 * THE LIMITS OF STORAGE TO BE DUMPED, AND F IS AN 00440000 * INTEGER CONSTANT OR THE ADDRESS OF AN INTEGER 00460000 * VARIABLE WHICH INDICATES THE DESIRED DUMP FORMAT-- 00480000 * F = 0 HEXADECIMAL 00500000 * 1 LOGICAL * 1 00520000 * 2 LOGICAL * 4 00540000 * 3 INTEGER * 2 00560000 * 4 INTEGER * 4 00580000 * 5 REAL * 4 00600000 * 6 REAL * 8 00620000 * 7 COMPLEX * 8 00640000 * 8 COMPLEX * 16 00660000 * 9 LITERAL 00680000 SPACE 3 00700000 * ERROR CONDITIONS 00720000 * NONE 00740000 SPACE 3 00760000 * REGISTER DEFINITIONS 00780000 S EQU 13 SAVE AREA POINTER 00800000 R EQU 14 RETURN REGISTER 00820000 L EQU 15 LINKAGE REGISTER 00840000 A EQU 1 ARGUMENT LIST POINTER 00860000 GRX EQU 2 FIRST ARGUMENT 00880000 GRY EQU 3 SECOND ARGUMENT 00900000 INDEX EQU 4 PARAMETER LOCATOR 00920000 BUFADD EQU 5 START OF RECORD 00940000 BUFLIM EQU 6 END OF RECORD 00960000 LINES EQU 7 LINE COUNTER 00980000 BYTER EQU 8 ONE BYTE ONLY 01000000 COUNT EQU 9 BYTES TO DUMP 01020000 CALLER EQU 10 CALLING REGISTER 01040000 SPILL EQU 11 UTILITY REGISTER 01060000 BASE EQU 12 BASE REGISTER 01080000 SPACE 3 01100000 * BRANCHING CONDITIONS 01120000 ALWAYS EQU 15 UNCONDITIONAL 01140000 NONE EQU 8 NO BITS ON 01160000 ZPLUS EQU 10 ZERO OR PLUS 01180000 PLUS EQU 2 PLUS 01200000 LOEQ EQU 12 LOW OR EQUAL 01220000 ALL EQU 1 ALL BITS ON 01240000 SPACE 3 01260000 * MISCELLANEOUS CODES 01280000 ON EQU X'FF' ON CONDITION 01300000 OFF EQU X'00' OFF CONDITION 01320000 INIT EQU X'00' INITIALIZATION OPERATION 01340000 FMTOUT EQU X'FF' FORMATTED OUTPUT 01360000 RITE EQU X'02' WRITE OPERATION 01380000 NULL EQU X'00' NULL QUALIFIER 01400000 LINECT EQU 50 NUMBER OF LINES PER PAGE 01420000 FRTNUSR EQU X'7C' OFFSET IN IBCOM TO USER'S REG 14 01422016 ER904 EQU X'6C' OFFSET IN IBCOM OF RTN TO GIVE 01424016 * MESSAGE 904 WHEN ATTEMPT IS 01426016 * MADE TO DO I/O DURING A FIXUP 01428016 * ROUTINE FOR AN I/O TYPE ERROR. 01430016 * THIS CAN ONLY HAPPEN WHEN USING 01432016 * THE EXTENDED ERROR MESSAGE 01434016 * HANDLING FACILITY 01436016 EJECT 01440000 * 01460000 USING *,15 01480000 DUMP B 10(0,15) 01500000 DC AL1(4) 01520000 DC CL4'DUMP' 01540000 STM 14,12,12(13) 01560000 MVI EXITSW,ON SET FOR MONITOR EXIT 01580000 BC ALWAYS,COMMON 01600000 * 01620000 USING *,15 01640000 PDUMP B 10(0,15) 01660000 DC AL1(5) 01680000 DC CL5'PDUMP' 01700000 STM 14,12,12(13) 01720000 MVI EXITSW,OFF SET VS. MONITOR EXIT 01740000 SPACE 3 01760000 * 01780000 COMMON BALR BASE,0 LOAD BASE REGISTER 01800000 USING *,BASE 01820000 L L,VIBCOM INITIALIZE FOR CALLS 01840000 CLI EXITSW,ON IS THIS A DUMP CALL 01842016 BE DOMORE YES, GO ON 01844016 CLI FRTNUSR(15),X'FF' IS THIS A PDUMP DURING AN I/O 01846016 BE DOMORE FIXUP RTN? NO, DO PDUMP 01848016 L R,ER904(0,15) YES GET ADDRESS OF RTN IN IBCOM 01850016 LM 0,12,20(13) TO OUTPUT MSG 904 AND GO 01852016 BR R THERE 01854016 DOMORE EQU * 01856016 MVC FRTNUSR(16,L),12(13) MOVE USER'S REGS 14-1 TO IBCOM 01858016 LR INDEX,A GET ADDRESS OF ARGUMENT LIST 01860000 LA GRX,OUTPTR SELECT SYSTEM OUTPUT DEVICE 01880000 EX 0,74(0,L) LOAD GR1 WITH ADDRESS OF FIOCS 01900000 BALR 0,1 INITIALIZE FILE 01920000 DC AL1(INIT) 01940000 DC AL1(FMTOUT) 01960000 B OUTTST IF I/O ERROR IGNORE REMAINDER 01970016 SR GRX,GRX CLEAR RECORD LENGTH 01980000 EX 0,74(0,L) 02000000 BALR 0,1 SKIP A LINE 02020000 DC AL1(RITE) 02040000 DC AL1(NULL) 02060000 B OUTTST IF I/O ERROR IGNORE REMAINDER 02070016 LR BUFADD,GRX SAVE START OF RECORD 02080000 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 02100000 LA LINES,LINECT INITIALIZE LINE COUNT, 02120000 MVI 0(GRX),C'1' AND SET CC FOR EJECT. 02140000 MVI ARGSW,OFF INITIALIZE ARGUMENT SWITCH 02160000 SR BYTER,BYTER CLEAR ONE-BYTE REGISTER 02180000 * 02200000 GETARG MVC DMPLOC(4),0(INDEX) ASSUME FIRST LIMIT IS LOW 02220000 TM 0(INDEX),ON 02240000 BC NONE,SETARG 02260000 SR COUNT,COUNT ONLY ONE ARGUMENT 02280000 BC ALWAYS,LSTDMP 02300000 SETARG L COUNT,4(0,INDEX) 02320000 N COUNT,SETOFF CLEAR END INDICATOR 02340000 S COUNT,0(0,INDEX) GET BYTES BETWEEN LIMITS 02360000 BC ZPLUS,ARGTST 02380000 LPR COUNT,COUNT 02400000 MVC DMPLOC(4),4(INDEX) RESET FOR SECOND LIMIT LOW 02420000 ARGTST TM 4(INDEX),ON 02440000 BC NONE,GETFMT 02460000 LSTDMP MVI ARGSW,ON SET FOR END OF ARGUMENTS 02480000 SR SPILL,SPILL ASK FOR HEX FORMAT 02500000 BC ALWAYS,DIRECT 02520000 GETFMT TM 8(INDEX),ON 02540000 BC NONE,SETFMT 02560000 MVI ARGSW,ON SET FOR END OF ARGUMENTS 02580000 SETFMT L SPILL,8(0,INDEX) 02600000 N SPILL,SETOFF CLEAR END INDICATOR 02620000 CH SPILL,NINE IS FORMAT CODE GT 9 02640000 BC LOEQ,DIRECT NO, CODE IS CONSTANT. 02660000 L SPILL,0(0,SPILL) GET SPEC INDIRECTLY 02680000 CH SPILL,NINE 02700000 BC LOEQ,DIRECT BRANCH IF CODE IS LEGAL 02720000 SR SPILL,SPILL IF NOT, ASK FOR HEX FORMAT. 02740000 DIRECT IC CALLER,ADCONS(SPILL) 02760000 STC CALLER,FMTCAL+3 SET DISPLACEMENT OF IBCOM LOAD 02780000 SLA SPILL,2 POSITION TO WORD BOUNDARY 02800000 L CALLER,FORMAT(SPILL) 02820000 ST CALLER,PARAMS SET FORMAT SPECS 02840000 IC BYTER,PARAMS 02860000 AR COUNT,BYTER 02880000 * 02900000 SETLOC LA GRY,1(0,GRX) GET BUFFER POSITION 02920000 LA GRX,DMPLOC+1 AND ADDRESS OF DMPLOC. 02940000 EX 0,78(0,L) LOAD GR1 WITH ADDRESS OF FCVZO 02960000 BALR 0,1 BRANCH TO Z-OUTPUT 02980000 DC AL1(3) 03000000 DC AL1(6) 03020000 MVC 6(3,GRY),BLANKS 03040000 LA GRY,9(0,GRY) UPDATE BUFFER POSITION 03060000 L GRX,DMPLOC GET BEGINNING DUMP ADDRESS 03080000 BUFTST LR CALLER,GRY 03100000 IC BYTER,PARAMS+1 03120000 AR CALLER,BYTER BUFFER POSITION PLUS WIDTH 03140000 CR CALLER,BUFLIM 03160000 BC LOEQ,FMTCAL WITHIN BUFFER LIMITS 03180000 BAL CALLER,FLUSH NO, DUMP A LINE. 03200000 BC ALWAYS,SETLOC 03220000 CNOP 2,4 03240000 FMTCAL EX 0,0(0,L) LOAD GR1 WITH CONVERSION ADDRESS 03260000 BALR 0,1 BRANCH TO FORMAT CONVERSION 03280000 PARAMS DC AL4(0) 03300000 AR GRY,BYTER UPDATE BUFFER POSITION 03320000 IC BYTER,PARAMS 03340000 AR GRX,BYTER UPDATE DUMP ADDRESS 03360000 SR COUNT,BYTER IS COUNT EXHAUSTED 03380000 BC PLUS,BUFTST NO, CONTINUE. 03400000 BAL CALLER,FLUSH YES, DUMP A LINE. 03420000 TM ARGSW,ON ARE ARGUMENTS EXHAUSTED 03440000 BC ALL,OUTTST YES, TEST TYPE OF EXIT. 03460000 LA INDEX,12(0,INDEX) NO, RESET ARGUMENT POINTER. 03480000 MVI 0(GRX),C'0' SET CC FOR DOUBLE SPACE 03500000 BC ALWAYS,GETARG 03520000 * 03540000 FLUSH ST GRX,DMPLOC RESET DUMP LOCATION 03560000 SR GRY,BUFADD 03580000 LR GRX,GRY GET RECORD LENGTH 03600000 EX 0,74(0,L) LOAD GR1 WITH ADDRESS OF FIOCS 03620000 BALR 0,1 WRITE ONE RECORD 03640000 DC AL1(RITE) 03660000 DC AL1(NULL) 03680000 B OUTTST IF I/O ERROR IGNORE REMAINDER 03690016 LR BUFADD,GRX SAVE START OF RECORD 03700000 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 03720000 BCT LINES,NORMAL IS LINE COUNT EXHAUSTED 03740000 LA LINES,LINECT YES, RESET LINE COUNT 03760000 MVI 0(GRX),C'1' AND SET CC FOR EJECT. 03780000 BCR ALWAYS,CALLER 03800000 NORMAL MVI 0(GRX),C' ' NO, SET CC FOR SINGLE SPACE. 03820000 BCR ALWAYS,CALLER 03840000 * 03860000 OUTTST TM EXITSW,ON 03880000 MVI FRTNUSR(L),X'FF' RESET I/O ENDED SWITCH 03890016 BC ALL,EXIT DUMP ENTRY 03900000 LM 14,12,12(S) RESTORE MAIN REGISTERS 03920000 MVI 12(S),X'FF' 03940000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 03960000 EXIT LM 0,12,20(S) RESTORE MAIN REGISTERS 03980000 BAL R,68(0,L) TERMINATE JOB 04000000 DC AL2(0) 04020000 * 04040000 EJECT 04060000 * 04080000 * TABLE OF DUMP FORMAT PARAMETERS 04100000 * 04120000 FORMAT DS 0F 04140000 DC AL1(4) 0 -- HEXADECIMAL 04160000 DC AL1(10) 04180000 BCR 0,0 04200000 DC AL1(1) 1 -- LOGICAL * 1 04220000 DC AL1(3) 04240000 BCR 0,0 04260000 DC AL1(4) 2 -- LOGICAL * 4 04280000 DC AL1(3) 04300000 BCR 0,0 04320000 DC AL1(2) 3 -- INTEGER * 2 04340000 DC AL1(7) 04360000 BCR 0,0 04380000 DC AL1(4) 4 -- INTEGER * 4 04400000 DC AL1(12) 04420000 BCR 0,0 04440000 DC AL1(4) 5 -- REAL * 4 04460000 DC AL1(17) 04480000 DC AL1(8) 04500000 DC AL1(0) 04520000 DC AL1(8) 6 -- REAL * 8 04540000 DC AL1(25) 04560000 DC AL1(16) 04580000 DC AL1(0) 04600000 DC AL1(8) 7 -- COMPLEX * 8 04620000 DC AL1(35) 04640000 DC AL1(8) 04660000 DC AL1(0) 04680000 DC AL1(16) 8 -- COMPLEX * 16 04700000 DC AL1(51) 04720000 DC AL1(16) 04740000 DC AL1(0) 04760000 DC AL1(4) 9 -- LITERAL 04780000 DC AL1(4) 04800000 BCR 0,0 04820000 * 04840000 EJECT 04860000 * 04880000 * DATA AND STORAGE AREAS 04900000 * 04920000 VIBCOM DC AL4(IBCOM#) 04940000 OUTPTR DC X'04000000' 04960000 DMPLOC DS 1F CURRENT DUMP LOCATION 04980000 SETOFF DC X'00FFFFFF' MASK FOR LAST ARGUMENT 05000000 NINE DC AL2(9) 05020000 ADCONS DC X'4E5E5E5252565A626266' 05040000 EXITSW DC AL1(0) SET ON BY DUMP, OFF BY PDUMP 05060000 ARGSW DC AL1(0) LAST ARGUMENT SWITCH 05080000 BLANKS DC C' ' 05100000 * 05120000 SPACE 3 05140000 END 05160000 ./ ADD SSI=01012000,NAME=IHCFDVCH,SOURCE=0 IHCFDVCH START 0 00020000 ENTRY DVCHK DIVIDE-CHECK TEST 00040000 EXTRN IBCOM# USES DVCIND (SET BY IBFINT) 00060000 SPACE 3 00080000 * CALLING SEQUENCE 00100000 * LA S,SAVLOC 00120000 * LA A,ARGLST 00140000 * L L,=V(DVCHK) 00160000 * BALR R,L 00180000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00200000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00220000 * DC AL4(J) ADDRESS OF INTEGER VARIABLE 00240000 SPACE 3 00260000 * ERROR CONDITIONS 00280000 * NONE 00300000 SPACE 3 00320000 * REGISTER DEFINITIONS 00340000 S EQU 13 SAVE AREA POINTER 00360000 R EQU 14 RETURN REGISTER 00380000 L EQU 15 LINKAGE REGISTER 00400000 A EQU 1 ARGUMENT LIST POINTER 00420000 INDEX EQU 2 PARAMETER LOCATOR 00440000 I EQU 3 DIVIDE-CHECK INDICATOR 00460000 J EQU 4 STATUS INDICATOR 00480000 SPACE 3 00500000 * BRANCHING CONDITIONS 00520000 ALWAYS EQU 15 UNCONDITIONAL 00540000 NONE EQU 8 NO BITS ON 00560000 SPACE 3 00580000 * MISCELLANEOUS CODES 00600000 ON EQU X'FF' ON CONDITION 00620000 OFF EQU X'00' OFF CONDITION 00640000 EJECT 00660000 * 00680000 USING *,15 00700000 DVCHK B 10(0,15) 00720000 DC AL1(5) 00740000 DC CL5'DVCHK' 00760000 STM 14,4,12(13) 00780000 BCR 15,0 PIPE-LINE DRAIN FOR MOD 92 00800000 L INDEX,0(0,A) GET ADDRESS OF J 00820000 L I,VIBCOM 00840000 TM 73(I),ON TEST D-C INDICATOR 00860000 BC NONE,ITSOFF 00880000 LA J,1 ON, SET J = 1. 00900000 BC ALWAYS,STASHJ 00920000 ITSOFF LA J,2 OFF, SET J = 2. 00940000 STASHJ ST J,0(0,INDEX) 00960000 MVI 73(I),OFF RESET D-C INDICATOR 00980000 LM 14,4,12(S) RESTORE MAIN REGISTERS 01000000 MVI 12(S),X'FF' 01020000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01040000 * 01060000 SPACE 3 01080000 * 01100000 * DATA AND STORAGE AREAS 01120000 * 01140000 DS 0F 01160000 VIBCOM DC AL4(IBCOM#) 01180000 * 01200000 SPACE 3 01220000 END 01240000 ./ ADD SSI=02010725,NAME=IHCFDXPD,SOURCE=0 IHCFDXPD CSECT 00020000 EXTRN IBCOM# 00040000 EXTRN IHCERRM 00050016 EXTRN DLOG 00060000 EXTRN DEXP 00080000 ENTRY FDXPD# 00100000 * DBL PREC FLOATING POINT BASE, FLOATING POINT EXPONENT LIBRARY ROUTINE 00120000 USING *,15 00140000 FDXPD# B 12(0,15) 00160000 DC AL1(6) 00180000 DC CL6'FDXPD#' 00200000 STM 14,ADDR,12(13) 00220000 BALR BASADD,0 00222016 USING *,BASADD 00224016 LR ADDR,SAVE 00226016 LA SAVE,SAVREG 00228016 ST ADDR,4(SAVE) 00230016 ST SAVE,8(ADDR) 00232016 BEGIN EQU * 00234016 L ADDR,0(0,PLIST) LOAD PLIST OF BASE NO IN ADDR REG 00240000 LD BASE,0(0,ADDR) LOAD BASE NO INTO BASE NO REG 00260000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00280000 LD EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00300000 LTDR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00360000 BC 8,ERROR IF BASE NO IS ZERO, BRANCH TO ERROR 00380000 LTDR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00400000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00420000 STD EXPN,PARAM STORE EXPONENT FOR LATER USE IN RTN 00520000 L LINK,ACDLOG LOAD ADCON OF DLOG RTN IN LINK REG 00540000 BALR RTN,LINK BRANCH TO DLOG RTN FOR LOG OF BASE 00560000 LD EXPN,PARAM RELOAD EXPN REG WITH EXPONENT 00580000 MDR BASE,EXPN MULTIPLY LOG OF BASE NO BY EXPONENT 00600000 STD BASE,PARAM STORE RESULT AS EXP RTN PARAMETER 00620000 LA PLIST,ADCPAR MOD PLIST TO POINT TO EXP RTN PARAM 00640000 L LINK,ACDEXP LOAD ADCON OF DEXP RTN IN LINK REG 00660000 BALR RTN,LINK BRANCH TO DEXP RTN TO COMPUTE RESULT 00680000 BC 15,EXIT BRANCH TO EXIT (RESULT IN BASE REG) 00720000 LOAD1 LD BASE,ONE LOAD PLUS 1 AS RESULT IN BASE NO REG 00740000 EXIT L 13,4(13) 00750016 LM 14,ADDR,12(13) 00760016 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 00780000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 00800000 ERROR LTDR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00820000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 00840000 STD BASE,DATA 00845016 STD EXPN,DATA1 00850016 LA 3,MSGDATA 00855016 L 15,VIBCOM 00860016 LR 14,2 SAVE ADDRESSABILITY 00865016 LA 2,DATA1 00870016 EX 0,90(LINK) 00875016 BALR 0,1 00880016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 00885016 LR 2,14 RESTORE ADDRESSABILITY 00890016 LA PLIST,ERRLIST 00895016 L LINK,AERRMON 00900016 BALR 14,15 00905016 CLI RETCODE+3,X'00' DID USER FIX DATA 00910016 BZ EXIT RESULT IN REG ALREADY ZERO 00915016 FIXUP LA PLIST,ERRLIST+12 POINT TO ADCONS OF DATA 00920016 B BEGIN 00925016 * FLOATING POINT REGISTERS 00940000 BASE EQU 0 REGISTER FOR BASE NO, PASSING RESULT 00960000 EXPN EQU 2 REGISTER FOR EXPONENT IN COMPUTATION 00980000 * GENERAL PURPOSE REGISTERS 01000000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01020000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01040000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01060000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01080000 BASADD EQU 2 REGISTER USED FOR SECOND BASE ADDR 01100000 ADDR EQU 3 REGISTER FOR INDEXING PARAMETER ADDR 01120000 * CONSTANTS AND ADCON AREAS 01140000 PARAM DS D PARAM FOR DATA IN DEXP MATH RTN 01180000 DATA DS D 01186016 DATA1 DS D EXPONENT 01192016 ONE DC X'4110000000000000' CONSTANT ONE IN DOUBLE PREC F P 01200000 ADCPAR DC AL4(PARAM) ADCON OF PARAMETER FOR EXP RTN 01220000 ACDLOG DC AL4(DLOG) ADCON OF DLOG MATH LIBRARY RTN 01240000 ACDEXP DC AL4(DEXP) ADCON OF DEXP MATH LIBRARY RTN 01260000 VIBCOM DC A(IBCOM#) 01280000 SAVREG DS 18F 01281016 AERRMON DC V(IHCERRM) 01282016 ERRNUM DC F'245' 01283016 ERRLIST DC A(MSGLNG) 01284016 DC A(RETCODE) 01285016 DC A(ERRNUM) 01286016 DC A(DATA) 01287016 DC X'80' LAST LIST ITEM 01288016 DC AL3(DATA1) 01289016 RETCODE DS F 01290016 EJECT 01291016 MSGLNG DC A(ENDMSG-MSG) 01292016 MSG DC C'IHC245I FDXPD REAL*8 BASE=0.0, REAL*8 EXPONENT=' 01293016 MSGDATA DS 23C 01294016 DC C', LE 0' 01295016 ENDMSG EQU * 01296016 END 01300000 ./ ADD SSI=02010725,NAME=IHCFDXPI,SOURCE=0 IHCFDXPI CSECT 00020000 EXTRN IBCOM# 00040000 EXTRN IHCERRM 00050016 ENTRY FDXPI# 00060000 * DBL PREC FLOATING POINT BASE, FIXED POINT EXPONENT LIBRARY ROUTINE 00080000 USING *,15 00100000 FDXPI# B 12(0,15) 00120000 DC AL1(6) 00140000 DC CL6'FDXPI#' 00160000 STM 14,ADDR,12(13) 00180000 BEGIN EQU * 00190016 L ADDR,0(0,PLIST) LOAD PLIST OF BASE NO IN ADDR REG 00200000 LD BASE,0(0,ADDR) LOAD BASE NO INTO BASE NO REG 00220000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00240000 L EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00260000 LTDR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00280000 BC 8,ERROR IF BASE NO IS ZERO, BRANCH TO ERROR 00300000 SR EXPSW,EXPSW SET NEGATIVE EXPN SWITCH REG TO ZERO 00320000 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00340000 BC 2,PLUS IF EXPN IS POSITIVE, BRANCH TO PLUS 00360000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00380000 LCR EXPN,EXPN EXPN MINUS, CONVERT TO 2S COMPLIMENT 00400000 LA EXPSW,1(EXPSW) SET EXP SW REG TO ONE FOR MINUS EXPN 00420000 PLUS LD FACTOR,ONE LOAD FACTOR OF ONE IN FACTOR REG 00440000 LOOP SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 00460000 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 00480000 BC 10,JUMP IF SIGN BIT NOT MINUS,BRANCH TO JUMP 00500000 MDR FACTOR,BASE MULTIPLY FACTOR REG BY BASE NO REG 00520000 JUMP LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00540000 BC 8,NEXT IF EXPONENT NOW ZERO, BRANCH TO NEXT 00560000 MDR BASE,BASE MULTIPLY BASE NO BY DOUBLING ITSELF 00580000 BC 15,LOOP BRANCH TO LOOP TO TEST NEXT EXPN BIT 00600000 NEXT LTR EXPSW,EXPSW TEST IF EXPSW REG PLUS,MINUS,OR ZERO 00620000 BC 8,SWAP IF EXPN IS NOT MINUS, BRANCH TO SWAP 00640000 LD BASE,ONE LOAD ONE IN BASE NO REG AS DIVIDEND 00660000 DDR BASE,FACTOR DIV BASE REG BY FACTOR REG (RESULT) 00680000 BC 15,EXIT BRANCH TO EXIT (RESULT IN BASE REG) 00700000 SWAP LDR BASE,FACTOR LOAD FACTOR REG INTO BASE NO REG 00720000 BC 15,EXIT BRANCH TO EXIT (RESULT IN BASE REG) 00740000 LOAD1 LD BASE,ONE LOAD PLUS 1 AS RESULT IN BASE NO REG 00760000 EXIT LM RTN,ADDR,12(SAVE) RELOAD FORMER VALUES OF GP REG 14-3 00780000 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 00800000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 00820000 ERROR LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00840000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 00860000 STD BASE,DATA 00863016 ST EXPN,DATA1 00866016 LA 2,DATA1 00869016 LA 3,MSGDATA AREA IN MSG FOR DATA 00872016 LR 14,15 SAVE ADDRESSABILITY 00875016 LR PLIST,SAVE SAVE CALLER'S SAVE AREA ADDR 00878016 L 15,VIBCOM 00881016 LA SAVE,OFFSET(15) SAVE AREA IN IBCOM 00884016 ST PLIST,4(SAVE) STORE CALLER ADDR IN NEW SAVE 00887016 ST SAVE,8(PLIST) STORE NEW SAVE IN CALLER'S AREA 00890016 EX 0,82(15) FCVIO 00893016 BALR 0,1 00896016 DC X'040B' LL=4 WW=11 00899016 LR 0,14 SAVE ADDRESSABILITY 00902016 DROP 15 00905016 USING FDXPI#,14 00908016 LA PLIST,ERRLIST 00911016 L LINK,AERRMON 00914016 BALR 14,15 00917016 LR 15,0 RESTORE ADDRESSABILITY 00920016 DROP 14 00923016 USING FDXPI#,15 00926016 L 13,4(13) RESTORE 13 TO CALLER AREA 00929016 CLI RETCODE+3,X'00' DID USER FIX DATA 00932016 BZ EXIT RESULT IN REG ALREADY ZERO 00935016 FIXUP LA PLIST,ERRLIST+12 POINT TO ADCONS OF DATA 00938016 B BEGIN 00941016 * FLOATING POINT REGISTERS 00960000 BASE EQU 0 REGISTER FOR BASE NO, PASSING RESULT 00980000 FACTOR EQU 2 REGISTER FOR FACTOR,COMPUTING RESULT 01000000 * GENERAL PURPOSE REGISTERS 01020000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01040000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01060000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01080000 EXPSW EQU 0 REGISTER FOR TESTING FOR MINUS EXPN 01100000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01120000 EXPN EQU 2 REGISTER FOR EXPONENT IN COMPUTATION 01140000 ADDR EQU 3 REGISTER FOR INDEXING PARAMETER ADDR 01160000 * ADCONS AND CONSTANTS AREA 01180000 OFFSET EQU X'C4' 01190016 DS 0D FORCE TO NEXT DOUBLE WORD BOUNDARY 01200000 ONE DC X'4110000000000000' CONSTANT ONE IN DOUBLE PREC F P 01220000 DATA DS D 01226016 DATA1 DS F 01232016 VIBCOM DC A(IBCOM#) 01240000 AERRMON DC V(IHCERRM) 01241016 ERRLIST DC A(MSGLNG) 01242016 DC A(RETCODE) 01243016 DC A(ERRNUM) 01244016 DC A(DATA) 01245016 DC X'80' 01246016 DC AL3(DATA1) 01247016 ERRNUM DC F'243' 01248016 RETCODE DS F'0' 01249016 EJECT 01250016 MSGLNG DC A(ENDMSG-MSG) 01251016 MSG DC C'IHC243I FDXPI REAL*8 BASE=0.0, INTEGER EXPONENT=' 01252016 MSGDATA DS 11C 01253016 DC C', LE 0' 01254016 ENDMSG EQU * 01255016 END 01260000 ./ ADD SSI=01012000,NAME=IHCFEXIT,SOURCE=0 IHCFEXIT START 0 00020000 ENTRY EXIT PROGRAM TERMINATION 00040000 EXTRN IBCOM# USES THE IBEXIT ROUTINE 00060000 SPACE 3 00080000 * CALLING SEQUENCE 00100000 * L L,=V(EXIT) 00120000 * BALR R,L 00140000 SPACE 3 00160000 * ERROR CONDITIONS 00180000 * NONE 00200000 SPACE 3 00220000 * REGISTER DEFINITIONS 00240000 S EQU 13 SAVE AREA POINTER 00260000 R EQU 14 RETURN REGISTER 00280000 L EQU 15 LINKAGE REGISTER 00300000 SPACE 3 00320000 * 00340000 USING *,15 00360000 EXIT B 10(0,15) 00380000 DC AL1(4) 00400000 DC CL4'EXIT' 00420000 STM 14,15,12(13) 00440000 L L,VIBCOM 00460000 BAL R,68(0,L) TERMINATE JOB 00480000 DC AL2(0) 00500000 * 00520000 SPACE 3 00540000 * 00560000 * DATA AND STORAGE AREAS 00580000 * 00600000 DS 0F 00620000 VIBCOM DC AL4(IBCOM#) 00640000 * 00660000 SPACE 3 00680000 END 00700000 ./ ADD SSI=01012000,NAME=IHCFIFIX,SOURCE=0 IHCFIFIX START 0 00020000 ENTRY IFIX REAL TO INTEGER CONVERSION 00040000 ENTRY INT REAL TRUNCATION / CONVERSION 00060000 ENTRY IDINT DOUBLE TRUNCATION / CONVERSION 00080000 SPACE 3 00100000 * CALLING SEQUENCE 00120000 * LA S,SAVLOC 00140000 * LA A,ARGLST 00160000 * L L,=V(IFIX)/=V(INT)/=V(IDINT) 00180000 * BALR R,L 00200000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00220000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00240000 * DC AL4(X) ADDRESS OF FIRST ARGUMENT 00260000 SPACE 3 00280000 * ERROR CONDITIONS 00300000 * NONE 00320000 SPACE 3 00340000 * REGISTER DEFINITIONS 00360000 S EQU 13 SAVE AREA POINTER 00380000 R EQU 14 RETURN REGISTER 00400000 L EQU 15 LINKAGE REGISTER 00420000 A EQU 1 ARGUMENT LIST POINTER 00440000 ARGADD EQU 2 ADDRESS OF ARGUMENT 00460000 X EQU 4 FIRST ARGUMENT 00480000 Y EQU 6 SECOND ARGUMENT 00500000 RESULT EQU 0 RESULT REGISTER 00520000 SPACE 3 00540000 * BRANCHING CONDITIONS 00560000 ALWAYS EQU 15 UNCONDITIONAL 00580000 NONE EQU 8 NO BITS ON 00600000 NZERO EQU 7 NOT ZERO 00620000 ZPLUS EQU 10 ZERO OR PLUS 00640000 EJECT 00660000 * 00680000 USING *,15 00700000 IFIX DS 0H 00720000 INT B 8(0,15) 00740000 DC AL1(3) 00760000 DC CL3'INT' 00780000 STM 14,2,12(13) 00800000 L ARGADD,0(0,A) 00820000 SDR X,X 00840000 LE X,0(0,ARGADD) GET SINGLE ARGUMENT 00860000 BC ALWAYS,COMMON 00880000 * 00900000 USING *,15 00920000 IDINT B 10(0,15) 00940000 DC AL1(5) 00960000 DC CL5'IDINT' 00980000 STM 14,2,12(13) 01000000 L ARGADD,0(0,A) 01020000 LD X,0(0,ARGADD) GET DOUBLE ARGUMENT 01040000 SPACE 3 01060000 * 01080000 COMMON BALR L,0 LOAD BASE REGISTER 01100000 USING *,L 01120000 TM 0(ARGADD),X'40' 01140000 BC NONE,CLEAR BRANCH IF LT 1 01160000 LTDR X,X 01180000 BC NZERO,FIXIT 01200000 CLEAR SR RESULT,RESULT ZERO ARGUMENT, SET RESULT. 01220000 BC ALWAYS,EXIT 01240000 FIXIT LPDR Y,X 01260000 AW Y,CNSTRN UNNORMALIZE ABSF(X) 01280000 STD Y,DATUM 01300000 L RESULT,DATUM+4 PICKUP INTEGER 01320000 LTDR X,X 01340000 BC ZPLUS,EXIT 01360000 LNR RESULT,RESULT NEGATIVE ARGUMENT, SET SIGN. 01380000 EXIT LM 1,2,24(S) RESTORE MAIN REGISTERS 01400000 MVI 12(S),X'FF' 01420000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01440000 * 01460000 SPACE 3 01480000 * 01500000 * DATA AND STORAGE AREAS 01520000 * 01540000 DS 0D 01560000 CNSTRN DC X'4E00000000000000' 01580000 DATUM DS 1D 01600000 * 01620000 SPACE 3 01640000 END 01660000 ./ ADD SSI=01013277,NAME=IHCFINTH,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 0 20000016 IHCARITM 30000016 END 40000016 ./ ADD SSI=01011981,NAME=IHCFIOSH,SOURCE=0 GBLA &ERR 10000016 &ERR SETA 0 20000016 IHCFIOSM 30000016 END 40000016 ./ ADD SSI=02010725,NAME=IHCFIXPI,SOURCE=0 IHCFIXPI CSECT 00020000 EXTRN IBCOM# 00040000 EXTRN IHCERRM 00050016 ENTRY FIXPI# 00060000 * FIXED POINT BASE, FIXED POINT EXPONENT LIBRARY ROUTINE 00080000 USING *,15 00100000 FIXPI# B 12(0,15) 00120000 DC AL1(6) 00140000 DC CL6'FIXPI#' 00160000 STM 14,ADDR,12(13) 00180000 L ADDR,0(0,PLIST) LOAD PLIST OF BASE NO IN ADDR REG 00200000 L BASE,0(0,ADDR) LOAD BASE NO INTO BASE NO REG 00220000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00240000 L EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00260000 BEGIN LR RESULT,BASE 00280016 LTR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00300000 BC 8,ERROR IF BASE NO IS ZERO, BRANCH TO ERROR 00320000 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00340000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00360000 BCTR BASE,0 DECREMENT BY ONE VALUE OF BASE NO 00380000 LTR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00400000 BC 8,EXIT IF BASE NO NOW ZERO, BRANCH TO EXIT 00420000 LA BASE,2(BASE) INCREMENT BY TWO VALUE OF BASE NO 00440000 LTR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00460000 BC 8,TEST IF BASE NO NOW ZERO, BRANCH TO TEST 00480000 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00500000 BC 2,PLUS IF EXPN IS POSITIVE, BRANCH TO PLUS 00520000 SR RESULT,RESULT EXPN MINUS,MAKE VALUE OF RESULT ZERO 00540000 BC 15,EXIT BRANCH TO EXIT TO LEAVE THIS ROUTINE 00560000 PLUS LR BASE,RESULT RELOAD ORG BASE NO FROM RESULT REG 00580000 L FACTOR,ONE LOAD FACTOR OF ONE IN FACTOR REG 00600000 LOOP SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 00620000 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 00640000 BC 10,JUMP IF SIGN BIT NOT MINUS,BRANCH TO JUMP 00660000 MR FACT,BASE MULTIPLY FACTOR REGS BY BASE NO REGS 00680000 JUMP LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00700000 BC 8,NEXT IF EXPONENT NOW ZERO, BRANCH TO NEXT 00720000 MR BASE1,BASE MULTIPLY BASE NO BY DOUBLING ITSELF 00740000 BC 15,LOOP BRANCH TO LOOP TO TEST NEXT EXPN BIT 00760000 NEXT LR RESULT,FACTOR LOAD FACTOR (ANSWER) INTO RESULT REG 00780000 BC 15,EXIT BRANCH TO EXIT TO LEAVE THIS ROUTINE 00800000 TEST SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 00820000 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 00840000 BC 4,EXIT IF SIGN MINUS (EXPN ODD), GO TO EXIT 00860000 LOAD1 L RESULT,ONE LOAD RESULT REG WITH VALUE OF PLUS 1 00880000 EXIT LM RTN,LINK,12(SAVE) RELOAD FORMER VALUES OF GP REG 14-15 00900000 LM FACT,ADDR,28(SAVE) RELOAD FORMER VALUES OF GP REG 2-7 00920000 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 00940000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 00960000 ERROR LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00980000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 01000000 STM BASE,EXPN,DATA DATA IN ERROR 01003016 LA 2,DATA1 01006016 LA 3,MSGDATA AREA IN MSG FOR DATA 01009016 LR ADDR,SAVE SAVE ADDR OF CALLER'S SAVEAREA 01012016 LR 4,15 SAVE ADDRESSABILITY 01015016 LM 14,15,AERRMON 01018016 LA SAVE,OFFSET(15) ADDR OF SAVE AREA IN IBCOM 01021016 ST ADDR,4(SAVE) CALLER SAVE AREA IN IBCOM SAVE 01024016 ST SAVE,8(ADDR) STORE MY SAVEADDR IN CALLERAREA 01027016 EX 0,82(15) FCVIO 01030016 BALR 0,1 01033016 DC X'040B' LL=4 WW=11 01036016 * 01039016 * ADDRESSABILITY IN REG 4 WHEN BRANCHING TO ERMON 01042016 * 01045016 USING FIXPI#,4 01048016 DROP 15 01051016 LA PLIST,ERRLIST 01054016 LR LINK,RTN ADDR OF ERMON 01057016 BALR 14,15 01060016 LR 15,4 RESTORE ADDRESSABILITY 01063016 USING FIXPI#,15 01066016 DROP 4 01069016 L 13,4(13) RESTORE 13 TO CALLER AREA 01072016 L RESULT,RETCODE 01075016 LTR RESULT,RESULT DID USER FIX DATA 01078016 BZ EXIT RESULT IN REG ALREADY ZERO 01081016 FIXUP LM BASE,EXPN,DATA 01084016 B BEGIN 01087016 * GENERAL PURPOSE REGISTERS 01100000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01120000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01140000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01160000 RESULT EQU 0 REGISTER FOR PASSING ON FINAL RESULT 01180000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01200000 FACT EQU 2 REGISTER USED AS MPY REG FOR FACTOR 01220000 FACTOR EQU 3 REGISTER USED FOR FACTOR AND ANSWER 01240000 BASE1 EQU 4 REGISTER USED AS MPY REG FOR BASE NO 01260000 BASE EQU 5 REGISTER FOR BASE NO IN COMPUTATION 01280000 EXPN EQU 6 REGISTER FOR EXPONENT IN COMPUTATION 01300000 ADDR EQU 7 REGISTER FOR INDEXING PARAMETER ADDR 01320000 * ADCONS AND CONSTANTS AREA 01340000 ONE DC F'1' INTERGER CONSTANT OF ONE 01360000 OFFSET EQU X'C4' 01366016 AERRMON DC V(IHCERRM) 01372016 VIBCOM DC A(IBCOM#) 01380000 ERRLIST DC A(MSGLNG) 01381016 DC A(RETCODE) 01382016 DC A(ERRNUM) 01383016 DC A(DATA) 01384016 DC X'80' 01385016 DC AL3(DATA1) 01386016 DATA DS F 01387016 DATA1 DS F 01388016 ERRNUM DC F'241' 01389016 RETCODE DS F'0' 01390016 EJECT 01391016 MSGLNG DC A(ENDMSG-MSG) 01392016 MSG DC C'IHC241I FIXPI INTEGER BASE=0,INTEGER EXPONENT=' 01393016 MSGDATA DS 11C 01394016 DC C', LE 0' 01395016 ENDMSG EQU * 01396016 END 01400000 ./ ADD SSI=01012000,NAME=IHCFMAXD,SOURCE=0 IHCFMAXD START 0 00020000 ENTRY DMAX1 MAXIMUM DOUBLE SELECTION 00040000 ENTRY DMIN1 MINIMUM DOUBLE SELECTION 00060000 SPACE 3 00080000 * CALLING SEQUENCE 00100000 * LA S,SAVLOC 00120000 * LA A,ARGLST 00140000 * L L,=V(DMAX1)/=V(DMIN1) 00160000 * BALR R,L 00180000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00200000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00220000 * DC AL4(ARG1) 00240000 * DC AL4(ARG2) 00260000 * ... ... 00280000 * ... ... 00300000 * DC XL1'FF',AL3(ARGN) 00320000 SPACE 3 00340000 * ERROR CONDITIONS 00360000 * NONE 00380000 SPACE 3 00400000 * REGISTER DEFINITIONS 00420000 S EQU 13 SAVE AREA POINTER 00440000 R EQU 14 RETURN REGISTER 00460000 L EQU 15 LINKAGE REGISTER 00480000 A EQU 1 ARGUMENT LIST POINTER 00500000 ARGADD EQU 2 ADDRESS OF ARGUMENT 00520000 BRANCH EQU 3 BRANCH CONDITION 00540000 RESULT EQU 0 RESULT REGISTER 00560000 SPACE 3 00580000 * BRANCHING CONDITIONS 00600000 ALWAYS EQU 15 UNCONDITIONAL 00620000 NONE EQU 8 NO BITS ON 00640000 SPACE 3 00660000 * MISCELLANEOUS CODES 00680000 GENC EQU X'A0' HIGH OR EQUAL, NO CONVERT 00700000 LENC EQU X'C0' LOW OR EQUAL, NO CONVERT 00720000 ON EQU X'FF' ON CONDITION 00740000 EJECT 00760000 * 00780000 USING *,15 00800000 DMAX1 B 10(0,15) 00820000 DC AL1(5) 00840000 DC CL5'DMAX1' 00860000 STM 14,3,12(13) 00880000 MVI SWITCH,GENC SET FOR MAXF, NO CONVERSION. 00900000 BC ALWAYS,COMMON 00920000 * 00940000 USING *,15 00960000 DMIN1 B 10(0,15) 00980000 DC AL1(5) 01000000 DC CL5'DMIN1' 01020000 STM 14,3,12(13) 01040000 MVI SWITCH,LENC SET FOR MINF, NO CONVERSION. 01060000 SPACE 3 01080000 * 01100000 COMMON BALR L,0 LOAD BASE REGISTER 01120000 USING *,L 01140000 IC BRANCH,SWITCH 01160000 N BRANCH,BRMASK ISOLATE BRANCHING CONDITION 01180000 L ARGADD,0(0,A) 01200000 LD RESULT,0(0,ARGADD) GET FIRST ARGUMENT 01220000 BC ALWAYS,CHECK 01240000 NEXT LA A,4(0,A) 01260000 L ARGADD,0(0,A) 01280000 CD RESULT,0(0,ARGADD) COMPARE TO NEXT ARGUMENT 01300000 EX BRANCH,TEST 01320000 LD RESULT,0(0,ARGADD) GET NEXT ARGUMENT 01340000 CHECK TM 0(A),ON 01360000 BC NONE,NEXT BRANCH IF NOT LAST ARGUMENT 01380000 LM 14,3,12(S) RESTORE MAIN REGISTERS 01400000 MVI 12(S),X'FF' 01420000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01440000 * 01460000 SPACE 3 01480000 * 01500000 * DATA AND STORAGE AREAS 01520000 * 01540000 DS 0F 01560000 BRMASK DC X'000000F0' 01580000 TEST BC 0,CHECK 01600000 SWITCH DC AL1(0) TYPE AND CONVERSION SWITCH 01620000 * 01640000 SPACE 3 01660000 END 01680000 ./ ADD SSI=01012000,NAME=IHCFMAXI,SOURCE=0 IHCFMAXI START 0 00020000 ENTRY MAX0 MAXIMUM INTEGER SELECTION 00040000 ENTRY MIN0 MINIMUM INTEGER SELECTION 00060000 ENTRY AMAX0 MAXIMUM INTEGER SELECT / CONVERT 00080000 ENTRY AMIN0 MINIMUM INTEGER SELECT / CONVERT 00100000 SPACE 3 00120000 * CALLING SEQUENCE 00140000 * LA S,SAVLOC 00160000 * LA A,ARGLST 00180000 * L L,=V(MAX0)/=V(MIN0)/=V(AMAX0)/=V(AMIN0) 00200000 * BALR R,L 00220000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00240000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00260000 * DC AL4(ARG1) 00280000 * DC AL4(ARG2) 00300000 * ... ... 00320000 * ... ... 00340000 * DC XL1'FF',AL3(ARGN) 00360000 SPACE 3 00380000 * ERROR CONDITIONS 00400000 * NONE 00420000 SPACE 3 00440000 * REGISTER DEFINITIONS 00460000 S EQU 13 SAVE AREA POINTER 00480000 R EQU 14 RETURN REGISTER 00500000 L EQU 15 LINKAGE REGISTER 00520000 A EQU 1 ARGUMENT LIST POINTER 00540000 ARGADD EQU 2 ADDRESS OF ARGUMENT 00560000 BRANCH EQU 3 BRANCH CONDITION 00580000 WORK EQU 3 FIXED WORK REGISTER 00600000 RESULT EQU 0 RESULT REGISTER 00620000 SPACE 3 00640000 * BRANCHING CONDITIONS 00660000 ALWAYS EQU 15 UNCONDITIONAL 00680000 NONE EQU 8 NO BITS ON 00700000 ZPLUS EQU 10 ZERO OR PLUS 00720000 SPACE 3 00740000 * MISCELLANEOUS CODES 00760000 GENC EQU X'A0' HIGH OR EQUAL, NO CONVERT 00780000 LENC EQU X'C0' LOW OR EQUAL, NO CONVERT 00800000 GECV EQU X'AF' HIGH OR EQUAL, WITH CONVERT 00820000 LECV EQU X'CF' LOW OR EQUAL, WITH CONVERT 00840000 CONV EQU X'0F' CONVERSION REQUIRED 00860000 ON EQU X'FF' ON CONDITION 00880000 EJECT 00900000 * 00920000 USING *,15 00940000 MAX0 B 10(0,15) 00960000 DC AL1(4) 00980000 DC CL4'MAX0' 01000000 STM 14,3,12(13) 01020000 MVI SWITCH,GENC SET FOR MAXF, NO CONVERSION. 01040000 BC ALWAYS,COMMON 01060000 * 01080000 USING *,15 01100000 MIN0 B 10(0,15) 01120000 DC AL1(4) 01140000 DC CL4'MIN0' 01160000 STM 14,3,12(13) 01180000 MVI SWITCH,LENC SET FOR MINF, NO CONVERSION. 01200000 BC ALWAYS,COMMON 01220000 * 01240000 USING *,15 01260000 AMAX0 B 10(0,15) 01280000 DC AL1(5) 01300000 DC CL5'AMAX0' 01320000 STM 14,3,12(13) 01340000 MVI SWITCH,GECV SET FOR MAXF, WITH CONVERSION. 01360000 BC ALWAYS,COMMON 01380000 * 01400000 USING *,15 01420000 AMIN0 B 10(0,15) 01440000 DC AL1(5) 01460000 DC CL5'AMIN0' 01480000 STM 14,3,12(13) 01500000 MVI SWITCH,LECV SET FOR MINF, WITH CONVERSION. 01520000 SPACE 3 01540000 * 01560000 COMMON BALR L,0 LOAD BASE REGISTER 01580000 USING *,L 01600000 IC BRANCH,SWITCH 01620000 N BRANCH,BRMASK ISOLATE BRANCHING CONDITION 01640000 L ARGADD,0(0,A) 01660000 L RESULT,0(0,ARGADD) GET FIRST ARGUMENT 01680000 BC ALWAYS,CHECK 01700000 NEXT LA A,4(0,A) 01720000 L ARGADD,0(0,A) 01740000 C RESULT,0(0,ARGADD) COMPARE TO NEXT ARGUMENT 01760000 EX BRANCH,TEST 01780000 L RESULT,0(0,ARGADD) GET NEXT ARGUMENT 01800000 CHECK TM 0(A),ON 01820000 BC NONE,NEXT BRANCH IF NOT LAST ARGUMENT 01840000 TM SWITCH,CONV 01860000 BC NONE,EXIT BRANCH IF NO CONVERSION 01880000 LPR WORK,RESULT 01900000 ST WORK,INTGER+4 STASH ABSF (MAX OR MIN) 01920000 LD RESULT,CNSTRN 01940000 AD RESULT,INTGER NORMALIZE 01960000 LTR RESULT,RESULT 01980000 BC ZPLUS,EXIT 02000000 LNER RESULT,RESULT NEGATIVE NUMBER, SET SIGN. 02020000 EXIT LM 1,3,24(S) RESTORE MAIN REGISTERS 02040000 MVI 12(S),X'FF' 02060000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 02080000 * 02100000 SPACE 3 02120000 * 02140000 * DATA AND STORAGE AREAS 02160000 * 02180000 DS 0D 02200000 INTGER DC X'4E00000000000000' 02220000 CNSTRN DC X'4E00000000000000' 02240000 BRMASK DC X'000000F0' 02260000 TEST BC 0,CHECK 02280000 SWITCH DC AL1(0) TYPE AND CONVERSION SWITCH 02300000 * 02320000 SPACE 3 02340000 END 02360000 ./ ADD SSI=01012000,NAME=IHCFMAXR,SOURCE=0 IHCFMAXR START 0 00020000 ENTRY MAX1 MAXIMUM REAL SELECT / CONVERT 00040000 ENTRY MIN1 MINIMUM REAL SELECT / CONVERT 00060000 ENTRY AMAX1 MAXIMUM REAL SELECTION 00080000 ENTRY AMIN1 MINIMUM REAL SELECTION 00100000 SPACE 3 00120000 * CALLING SEQUENCE 00140000 * LA S,SAVLOC 00160000 * LA A,ARGLST 00180000 * L L,=V(MAX1)/=V(MIN1)/=V(AMAX1)/=V(AMIN1) 00200000 * BALR R,L 00220000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00240000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00260000 * DC AL4(ARG1) 00280000 * DC AL4(ARG2) 00300000 * ... ... 00320000 * ... ... 00340000 * DC XL1'FF',AL3(ARGN) 00360000 SPACE 3 00380000 * ERROR CONDITIONS 00400000 * NONE 00420000 SPACE 3 00440000 * REGISTER DEFINITIONS 00460000 S EQU 13 SAVE AREA POINTER 00480000 R EQU 14 RETURN REGISTER 00500000 L EQU 15 LINKAGE REGISTER 00520000 A EQU 1 ARGUMENT LIST POINTER 00540000 ARGADD EQU 2 ADDRESS OF ARGUMENT 00560000 BRANCH EQU 3 BRANCH CONDITION 00580000 WORK EQU 2 FLOATING WORK REGISTER 00600000 RESULT EQU 0 RESULT REGISTER 00620000 SPACE 3 00640000 * BRANCHING CONDITIONS 00660000 ALWAYS EQU 15 UNCONDITIONAL 00680000 NONE EQU 8 NO BITS ON 00700000 ZPLUS EQU 10 ZERO OR PLUS 00720000 SPACE 3 00740000 * MISCELLANEOUS CODES 00760000 GENC EQU X'A0' HIGH OR EQUAL, NO CONVERT 00780000 LENC EQU X'C0' LOW OR EQUAL, NO CONVERT 00800000 GECV EQU X'AF' HIGH OR EQUAL, WITH CONVERT 00820000 LECV EQU X'CF' LOW OR EQUAL, WITH CONVERT 00840000 CONV EQU X'0F' CONVERSION REQUIRED 00860000 ON EQU X'FF' ON CONDITION 00880000 EJECT 00900000 * 00920000 USING *,15 00940000 MAX1 B 10(0,15) 00960000 DC AL1(4) 00980000 DC CL4'MAX1' 01000000 STM 14,3,12(13) 01020000 MVI SWITCH,GECV SET FOR MAXF, WITH CONVERSION. 01040000 BC ALWAYS,COMMON 01060000 * 01080000 USING *,15 01100000 MIN1 B 10(0,15) 01120000 DC AL1(4) 01140000 DC CL4'MIN1' 01160000 STM 14,3,12(13) 01180000 MVI SWITCH,LECV SET FOR MINF, WITH CONVERSION. 01200000 BC ALWAYS,COMMON 01220000 * 01240000 USING *,15 01260000 AMAX1 B 10(0,15) 01280000 DC AL1(5) 01300000 DC CL5'AMAX1' 01320000 STM 14,3,12(13) 01340000 MVI SWITCH,GENC SET FOR MAXF, NO CONVERSION. 01360000 BC ALWAYS,COMMON 01380000 * 01400000 USING *,15 01420000 AMIN1 B 10(0,15) 01440000 DC AL1(5) 01460000 DC CL5'AMIN1' 01480000 STM 14,3,12(13) 01500000 MVI SWITCH,LENC SET FOR MINF, NO CONVERSION. 01520000 SPACE 3 01540000 * 01560000 COMMON BALR L,0 LOAD BASE REGISTER 01580000 USING *,L 01600000 IC BRANCH,SWITCH 01620000 N BRANCH,BRMASK ISOLATE BRANCHING CONDITION 01640000 L ARGADD,0(0,A) 01660000 LE RESULT,0(0,ARGADD) GET FIRST ARGUMENT 01680000 BC ALWAYS,CHECK 01700000 NEXT LA A,4(0,A) 01720000 L ARGADD,0(0,A) 01740000 CE RESULT,0(0,ARGADD) COMPARE TO NEXT ARGUMENT 01760000 EX BRANCH,TEST 01780000 LE RESULT,0(0,ARGADD) GET NEXT ARGUMENT 01800000 CHECK TM 0(A),ON 01820000 BC NONE,NEXT BRANCH IF NOT LAST ARGUMENT 01840000 TM SWITCH,CONV 01860000 BC NONE,EXIT BRANCH IF NO CONVERSION 01880000 SDR WORK,WORK 01900000 LPER WORK,RESULT GET ABSF (MAX OR MIN) 01920000 AW WORK,CNSTRN UNNORMALIZE 01940000 STD WORK,DATUM 01960000 L RESULT,DATUM+4 PICKUP INTEGER 01980000 LTER RESULT,RESULT 02000000 BC ZPLUS,EXIT 02020000 LNR RESULT,RESULT NEGATIVE NUMBER, SET SIGN. 02040000 EXIT LM 1,3,24(S) RESTORE MAIN REGISTERS 02060000 MVI 12(S),X'FF' 02080000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 02100000 * 02120000 SPACE 3 02140000 * 02160000 * DATA AND STORAGE AREAS 02180000 * 02200000 DS 0D 02220000 CNSTRN DC X'4E00000000000000' 02240000 DATUM DS 1D 02260000 BRMASK DC X'000000F0' 02280000 TEST BC 0,CHECK 02300000 SWITCH DC AL1(0) TYPE AND CONVERSION SWITCH 02320000 * 02340000 SPACE 3 02360000 END 02380000 ./ ADD SSI=02012000,NAME=IHCFMODI,SOURCE=0 IHCFMODI START 0 00020000 ENTRY MOD INTEGER REMAINDERING 00040000 SPACE 3 00060000 * CALLING SEQUENCE 00080000 * LA S,SAVLOC 00100000 * LA A,ARGLST 00120000 * L L,=V(MOD) 00140000 * BALR R,L 00160000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00180000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00200000 * DC AL4(X) ADDRESS OF FIRST ARGUMENT 00220000 * DC AL4(Y) ADDRESS OF SECOND ARGUMENT 00240000 SPACE 3 00260000 * ERROR CONDITIONS 00280000 * NONE 00300000 SPACE 3 00320000 * REGISTER DEFINITIONS 00340000 S EQU 13 SAVE AREA POINTER 00360000 R EQU 14 RETURN REGISTER 00380000 L EQU 15 LINKAGE REGISTER 00400000 A EQU 1 ARGUMENT LIST POINTER 00420000 X EQU 2 FIRST ARGUMENT 00440000 ARGADD EQU 3 ADDRESS OF ARGUMENT 00460000 Y EQU 4 SECOND ARGUMENT 00480000 RESULT EQU 0 RESULT REGISTER 00500000 SPACE 3 00520000 * BRANCHING CONDITIONS 00540000 ALWAYS EQU 15 UNCONDITIONAL 00560000 ZERO EQU 8 ZERO 00580000 ZPLUS EQU 10 ZERO OR PLUS 00600000 EJECT 00620000 * 00640000 USING *,15 00660000 MOD B 8(0,15) 00680000 DC AL1(3) 00700000 DC CL3'MOD' 00720000 STM 14,4,12(13) 00740000 L ARGADD,0(0,A) 00760000 L RESULT,0(0,ARGADD) GET FIRST ARGUMENT 00780000 L ARGADD,4(0,A) 00800000 L Y,0(0,ARGADD) GET SECOND ARGUMENT 00820000 LR X,RESULT 00840000 SRDA X,32 00860000 DR X,Y X / Y 00880000 LR RESULT,X 00900000 EXIT LM 1,4,24(S) RESTORE MAIN REGISTERS 00920000 MVI 12(S),X'FF' 00940000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 00960000 * 00980000 SPACE 3 01000000 END 01020000 ./ ADD SSI=03032291,NAME=IHCFMODR,SOURCE=0 IHCFMODR START 0 00020000 *HJNX 012400 4660 00030014 ENTRY AMOD REAL REMAINDERING 00040000 ENTRY DMOD DOUBLE REMAINDERING 00060000 SPACE 3 00080000 * CALLING SEQUENCE 00100000 * LA S,SAVLOC 00120000 * LA A,ARGLST 00140000 * L L,=V(AMOD)/=V(DMOD) 00160000 * BALR R,L 00180000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00200000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00220000 * DC AL4(X) ADDRESS OF FIRST ARGUMENT 00240000 * DC AL4(Y) ADDRESS OF SECOND ARGUMENT 00260000 SPACE 3 00280000 * ERROR CONDITIONS 00300000 * NONE 00320000 SPACE 3 00340000 * REGISTER DEFINITIONS 00360000 S EQU 13 SAVE AREA POINTER 00380000 R EQU 14 RETURN REGISTER 00400000 L EQU 15 LINKAGE REGISTER 00420000 A EQU 1 ARGUMENT LIST POINTER 00440000 ARGADD EQU 2 ADDRESS OF ARGUMENT 00460000 X EQU 4 FIRST ARGUMENT 00480000 Y EQU 6 SECOND ARGUMENT 00500000 RESULT EQU 0 RESULT REGISTER 00520000 SPACE 3 00540000 * BRANCHING CONDITIONS 00560000 ALWAYS EQU 15 UNCONDITIONAL 00580000 ZERO EQU 8 ZERO 00600000 ZPLUS EQU 10 ZERO OR PLUS 00620000 EJECT 00640000 * 00660000 USING *,15 00680000 AMOD B 10(0,15) 00700000 DC AL1(4) 00720000 DC CL4'AMOD' 00740000 STM 14,2,12(13) 00760000 L ARGADD,0(0,A) 00780000 SDR RESULT,RESULT 00800000 LE RESULT,0(0,ARGADD) GET FIRST ARGUMENT 00820000 L ARGADD,4(0,A) 00840000 SDR Y,Y 00860000 LE Y,0(0,ARGADD) GET SECOND ARGUMENT 00880000 BC ALWAYS,COMMON 00900000 * 00920000 USING *,15 00940000 DMOD B 10(0,15) 00960000 DC AL1(4) 00980000 DC CL4'DMOD' 01000000 STM 14,2,12(13) 01020000 L ARGADD,0(0,A) 01040000 LD RESULT,0(0,ARGADD) GET FIRST ARGUMENT 01060000 L ARGADD,4(0,A) 01080000 LD Y,0(0,ARGADD) GET SECOND ARGUMENT 01100000 SPACE 3 01120000 * 01140000 COMMON BALR L,0 LOAD BASE REGISTER 01160000 USING *,L 01180000 LDR X,RESULT 01200000 DDR X,Y X / Y 01220000 AW X,CNSTRN INTF (X/Y) 01240014 MDR X,Y Y * INTF(X/Y) 01260000 SDR RESULT,X X - Y * INTF(X/Y) 01280000 EXIT LM 14,2,12(S) RESTORE MAIN REGISTERS 01300000 MVI 12(S),X'FF' 01320000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01340000 * 01360000 SPACE 3 01380000 * 01400000 * DATA AND STORAGE AREAS 01420000 * 01440000 DS 0D 01460000 CNSTRN DC X'4E00000000000000' 01480000 * 01500000 SPACE 3 01520000 END 01540000 ./ ADD SSI=01012253,NAME=IHCFOPT,SOURCE=0 IHCFOPT CSECT 00300016 TITLE ' ERRSET,ERRSAV,ERRSTR ROUTINE TO MODIFY OPTION TABLE' 00600016 * THIS ROUTINE IS CALLED BY THE FORTRAN PROGRAMMER TO CHANGE * 00900016 * A TABLE ENTRY. THE PARAMETERS,IN ORDER, ARE * 01200016 * 1- ERROR NUMBER.FOR USER ERRORS THIS NUMBER MUST BE GREATER * 01500016 * THAN 301 * 01800016 * 2- NUMBER OF ERRORS OF THIS TYPE TO BE ALLOWED * 02100016 * 3- NUMBER OF MESSAGES TO BE PRINTED * 02400016 * 4- TRACEBACK INDICATOR. IF 0- DO NOT CHANGE THE TRACEBACK * 02700016 * INDICATOR ALREADY IN THE TABLE * 03000016 * 1- DO NOT PROVIDE TRACEBACK WITH MSG * 03300016 * 2- PROVIDE TRACEBACK WITH MESSAGES * 03600016 * 5- USER FIXUP ADDRESS FOR THIS ERROR TYPE. * 03900016 * 6- FOR AN ERROR OTHER THAN ERROR 212 THIS PARAMETER INDICATES * 04200016 * THAT A RANGE OF ERROR ENTRIES IS TO BE CHANGED. THIS * 04500016 * PARAMETER REPRESENTS THE UPPER LIMIT OF THE RANGE OF ERROR * 04800016 * ENTRIES TO BE CHANGED. THE FIRST PARAMETER IS THE LOWER LIMIT * 05100016 * FOR ERROR NUMBER 212 THIS PARAMETER INDICATES WHETHER OR NOT * 05400016 * A CARRIAGE CONTROL CHARACTER IS TO BE SUPPLIED WHEN A NEW * 05700016 * OUTPUT RECORD IS BEGUN AFTER ERROR 212 OCCURS AND THE TABLE * 06000016 * INDICATES THAT EXECUTION IS TO CONTINUE. * 06300016 * 1- SUPPLY CHARACTER NOTE: ANY OTHER NUMBER IS * 06600016 * 0- DO NOT SUPPLY CHARACTER TREATED LIKE ZERO * 06900016 * * 07200016 * NOTES: 1- IF PARAMETER 2 IS GIVEN AS ZERO OR GREATER THAN 256 * 07500016 * THIS INDICATESTHAT THE USER WANTS TO ALLOW ALL ERRORS. * 07800016 * 2- IF PARAMETER 3 IS SPECIFIED AS ZERO NO MESSAGES WILL * 08100016 * PRINTED. IF SPECIFIED AS > 256 THIS INDICATES THAT ALL * 08400016 * ERRORS OF THIS TYPE ARE TO BE PRINTED. 08700016 * 3- IF PARAMETER 5 IS 0 THIS INDICATES THAT THE USER * 09000016 * WISHES TO HAVE STANDARD FIXUP TAKE PLACE ON THE * 09300016 * CORRESPONDING ERROR CONDITION. * 09600016 * 4- IF PARAMETER 6 IS 0 OR LESS THAN PARAMETER 1 THEN IT * 09900016 * IS IGNORED(CASE 1 OF PARAMETER 6) * 10200016 * 5- IF THE FLAGS (I.E.PARAMETER 4 ) IS SPECIFIED AS OTHER * 10500016 * THAN 0,1, OR 2 THEN TRACE WILL BE GIVEN ON THE * 10800016 * CORRESPONDING ERROR CONDITION. 11100016 * * 11400016 * * 11700016 ENTRY ERRSET,ERRSAV,ERRSTR 12000016 USING *,15 12300016 USING ERRTBL,4 12600016 USING OPTIONTB,5 12900016 * 13200016 * 567000 23414 13300018 * STATUS - CHANGE LEVEL 01,20AUG69 RELEASE 18 13400018 * 13500016 * REGISTER USAGE 13800016 * 14100016 * 14400016 N EQU 1 14700016 W EQU 2 15000016 T EQU 3 15300016 F EQU 4 15600016 V EQU 5 15900016 S EQU 6 16200016 VN EQU 7 16500016 E EQU 8 16800016 TW EQU 9 17100016 LN EQU 10 17400016 L EQU 11 17700016 LV EQU 12 18000016 H EQU 13 18300016 ERRSET EQU * 18600016 SAVE (14,12),,* SAVE REGISTERS 18900016 L 2,0(0,1) GET ADDRESS OF FIRST PARAMETER 19200016 L 3,0(0,2) GET ERROR NUMBER 19500016 NEXT EQU * 19800016 ST 3,NOERR SAVE ERROR NUMBER FOR LATER USE 20100016 BAL 8,FINDENTR GET ADDRESS OF TABLE ENTRY 20400016 LTR 4,4 CAN TABLE ENTRY BE MODIFIED, WAS 20700016 * TABLE ENTRY FOUND 21000016 BZ IGNORITM NO IGNORE THIS NUMBER 21300016 SR 5,5 CLEAR INDEX REGISTER 21600016 ERRORS BAL 6,GETENTRY GET ENTRY FOR NUMBER OF ERRORS 21900016 LTR W,W NUMBER OF ERRORS LE 0? 22200016 BNH MESSAGES YES, GET NEXT PARAMETER 22500016 STC W,MAXERR STORE NUMBER OF ERRORS IN TABLE 22800016 C W,CON256 WAS NUMBER OF ERRORS GE 256 23100016 BL MESSAGES NO ,GET NEXT PARAMETER 23400016 MVI MAXERR,0 YES, INDICATE ALLOW ALL ERRORS 23700016 MESSAGES BAL 6,GETENTRY GET ENTRY FOR NUMBER OF MESSAGES 24000016 LTR W,W NUMBER OF MESSAGES = 0? 24300016 BH NORMAL > 0, GO TO MAKE TBL ENTRY 24600016 BE FLAGS YES,GET NEXT PARAMETER 24900016 SR W,W SET W TO ZEROES 25200016 NI BITS,FF-PRNTMSG SET TO ALLOW NO MESSAGES 25500016 NORMAL STC W,MAXMESS STORE NUMBER OF MESSAGES IN TBL 25800016 C W,CON256 WAS NUMBER OF MESSAGES GE 256 26100016 BL FLAGS NO, GET NEXT PARAMETER 26400016 OI BITS,PRNTMSG YES, SET TO ALLOW ALL MESSAGES 26700016 FLAGS BAL 6,GETENTRY GET ENTRY FOR FLAGS 27000016 LTR W,W ZERO INDICATES DON'T CHANGE ENTR 27300016 BNH USERAD GET NEXT PARAMETER 27600016 CH W,TWO IS TRACE WANTED? 27900016 BH USERAD LEAVE TRACE AS IS.GET NEXT PARAM 28200016 BE TRACEY SHOWS TRACE WANTED.GO TO SET IT. 28500016 NI BITS,FF-TRACE INDICATES NO TRACE 28800016 B USERAD GET NEXT PARAMETER 29100016 TRACEY OI BITS,TRACE INDICATE TRACE REQUESTED 29400016 USERAD BAL 6,GETENTRY GET ENTRY FOR USER ADDRESS 29700016 STOADDR LTR W,W ADDR = 0 I.E. NO USER EXIT? 30000016 BZ *+8 YES, BRANCH AROUND STORE 30300016 ST 2,USERADDR STORE USER'S ADDRESS IN TABLE 30600016 CLI SW1,ON EXIT. FIRST TIME THRU HERE? 30900016 BE NXTNM NO, BRANCH 31200016 CLC NOERR+2(2),E212 ERROR 212 31500016 BE ER212 YES BRANCH 31800016 GETHILM EQU * 32100016 BAL 6,GETENTRY GET UPPER LIMIT 32400016 MVI SW1,ON INDICATE THAT WE HAVE COME THRU 32700016 ST 2,MAX SAVE UPPER LIMIT 33000016 NXTNM L 3,NOERR 33300016 LA 3,1(0,3) INCREMENT ERROR NO. BY ONE 33600016 C 3,MAX IF ABOVE LIMIT THEN RETURN 33900016 BH FINISHED 34200016 B NEXT ELSE GO TO HANDLE NEXT NUMBER 34500016 ER212 BAL 6,GETENTRY GET USER OPTION 34800016 NI BITS,FF-CCHAR IF ZERO, SET OFF CARRIAGE CNTRL 35100016 CH W,ONE IF CODE=0 THEN NO CARRIAGE CNTRL 35400016 BNE FINISHED CHAR. REQUESTED SO BRANCH 35700016 OI BITS,CCHAR IF ONE, INDICATE USE OF CARRIAGE 36000016 * B FINISHED CONTROL CHARACTER 36300016 IGNORCAL EQU * 36600016 FINISHED EQU * 36900016 MVI SW1,0 TURN OFF FIRST TIME SWITCH 37200016 MVI SW2,OFF 37500016 RETURN (14,12),T RETURN AN RESTORE REGISTERS 37800016 IGNORITM EQU * 38100016 CLI SW1,ON 38400016 BE NXTNM 38700016 CLC NOERR+2(2),E212 IF FIRST TIME THRU SEE IF RANGE 39000016 BE IGNORCAL OF NUMBERS IS TO BE MODIFIED 39300016 LA 6,4 SET UP FOR BXLE LOOP 39600016 LA 7,16 I.E. SEE IF SIXTH PARAMETER IS 39900016 SR 5,5 SPECIFIED THEN GO TO GETHILM 40200016 RLOOP LA 2,0(5,1) TO CONTINUE BY GETTING THE UPPER 40500016 TM 0(2),LAST LIMIT OF THE RANGE AND GO ON WIT 40800016 BO FINISHED THE NEXT NUMBER EVEN THOUGH 41100016 BXLE 5,6,RLOOP THE CURRENT NUMBER WAS 41400016 SH 5,FOUR NOT MODIFIABLE. 41700016 B GETHILM 42000016 PRFNDENT EQU * 42300016 L 2,0(0,1) GET ADDRESS OF ERROR NUMBER 42600016 L 3,0(0,2) GET ERROR NUMBER 42900016 FINDENTR EQU * 43200016 ST 3,ERRORNO SAVE ERROR NUMBER 43500016 L 5,=V(IHCUOPT) GET OPTION TABLE ADDRESS 43800016 L 4,NUMENTR GET NUMBER OF ENTRIES IN TABLE 44100016 C 3,HLF206 COMPARE ERROR NUMBER TO FIRST 44400016 BNH BADERNO ENTRY(I.E. 207) IF LOW ERROR. 44700016 S 3,HLF206 ERROR NUMBER-206 > NUMBER OF 45000016 CR 3,4 ENTRIES INDICATES THAT NUMBER 45300016 BH BADERNO IS OUT OF RANGE OF TABLE. 45600016 SLL 3,3 COMPUTE ADDRESS OF TABLE ENTRY 45900016 LA 4,0(3,5) 46200016 TM BITS,MODIFY TABLE ENTRY MODIFIABLE? 46500016 BCR 1,8 YES, RETURN 46800016 L 5,16(0,13) NO, SEE IF THIS IS ENTRY FOR 47100016 C 5,=A(ERRSAV) SAVE FUNCTION IN WHICH CASE THIS 47400016 BCR 8,8 IS NOT AN ERROR. 47700016 LA 4,MS903 OTHERWISE, SET UP TO OUTPUT ERRO 48000016 LA 5,MS903LN NUMBER 903 48300016 LA 6,MS903DT 48600016 WRITE CLI SW2,ON IF FIOCS HAS BEEN ALREADY INIT- 48900016 BE WRITE2 IALIZED ON THIS CALL BRANCH 49200016 MVI SW2,ON ELSE SET INITIALIZATION 49500016 LA 2,OUTPARM SWITCH AND CALL FIOCS FOR 49800016 LR L,1 SAVE ADDR OF PARAM LIST 50100016 L 1,=V(FIOCS#) INITIALIZATION. 50400016 BALR 0,1 50700016 DC XL2'00FF' 51000016 NOP 0 51300016 LR TW,2 51600016 LR LN,3 51900016 WRITE2 LR 3,6 PUT ADDRESS OF WHERE TO PUT 52200016 LA 2,ERRORNO CONVERTED OUTPUT IN REG. 3 AND 52500016 LR VN,15 WHERE TO CONVERT FROM IN REG. 2 52800016 L 15,=V(IBCOM#) (SAVE REG 15 ) THEN CALL 53100016 EX 0,82(0,15) THE INTEGER OUTPUT ROUTINE 53400016 LR 15,VN 53700016 BALR 0,1 54000016 DC XL2'0405' 54300016 COMPR CR V,LN BUFFER LENGTH > MESSAGE LENGTH 54600016 BNH MOVETOBF YES, BRANCH 54900016 LR V,LN ELSE USE BUFFER LENGTH 55200016 MOVETOBF EQU * 55500016 BCTR V,0 SET UP TO EXECUTE A MOVE 55800016 EX 5,MOVE 56100016 L 1,=V(FIOCS#) WRITE THE MESSAGE VIA FIOCS 56400016 LA 2,2(5) 23414 56700018 BALR 0,1 57000016 DC XL2'0200' 57300016 NOP 0 57600016 LR TW,2 57900016 LR LN,3 58200016 SR 4,4 INDICATE TABLE ENTRY NOT 58500016 LR 1,L RESTORE PARAM LIST 58800016 BR 8 MODIFIABLE AND RETURN 59100016 GETENTRY LA 2,0(5,1) GET ADDRESS OF PARAMETER IN LIST 59400016 TM 0(2),LAST IS THIS LAST ENTRY 59700016 BO FINISHED YES, FINISHED 60000016 LA 5,4(0,5) INCREMENT TO NEXT ENTRY 60300016 L 2,0(5,1) GET ADDRESS OF PARAMETER 60600016 L 2,0(0,2) GET PARAMETER 60900016 BR 6 RETURN 61200016 BADERNO LA 4,MS902 SET UP TO OUTPUT ERROR MESSAGE 61500016 LA 5,MS902LN 902. 61800016 LA 6,MS902DT 62100016 BAL 8,WRITE WRITE MESSAGE 62400016 B FINISHED RETURN 62700016 USING *,15 63000016 ERRSAV EQU * 63300016 SAVE (14,12),,ERRSAV 63600016 L 15,=A(ERRSET) SET UP ADDRESSABILITY 63900016 USING ERRSET,15 64200016 BAL 8,PRFNDENT GET ADDRESS OF TABLE ENTRY 64500016 L 2,4(0,1) GET ADDRESS OF WHERE TO HOLD IT 64800016 MVC 0(TABSIZE,2),0(4) SAVE TABLE ENTRY 65100016 B FINISHED RETURN 65400016 USING *,15 65700016 ERRSTR EQU * 66000016 SAVE (14,12),,ERRSTR 66300016 L 15,=A(ERRSET) SET UP ADDRESSABILITY 66600016 USING ERRSET,15 66900016 BAL 8,PRFNDENT GET ADDRESS OF TABLE ENTRY 67200016 LTR 4,4 IS TABLE ENTRY MODIFIABLE? 67500016 BZ IGNORCAL NO, RETURN 67800016 L 2,4(0,1) YES,GET ADDRESS OF WHERE TO 68100016 RESTORE MVC 0(TABSIZE,4),0(2) RESTORE TABLE ENTRY FROM AND 68400016 B FINISHED RESTORE IT. RETURN 68700016 MOVE MVC 1(0,TW),0(F) 69000016 ONE DC H'1' 69300016 TWO DC H'2' 69600016 FOUR DC H'8' 69900016 E212 DC H'212' 70200016 TABSIZEH DC H'8' 70500016 ERRORNO DC F'0' 70800016 HLF206 DC F'206' 71100016 CON256 DC F'256' 71400016 MAX DC F'0' 71700016 NOERR DC F'0' ERROR NUMBER SAVE AREA 72000016 ON EQU X'FF' 72300016 OFF EQU X'00' 72600016 OUTPARM DC X'04000000' 72900016 SW1 DC FL1'0' 73200016 SW2 DC XL1'00' 73500016 SAVERR DC X'00' 73800016 EJECT 74100016 * MESSAGES 74400016 MS902 DC C'IHC902I ERROR NUMBER ' 74700016 MS902DT DC C' ' 75000016 DC C' OUT OF RANGE OF ERROR TABLE' 75300016 MS902E EQU * 75600016 MS902LN EQU MS902E-MS902 75900016 MS902D EQU MS902DT-MS902 76200016 MS903 DC C'IHC903I ATTEMPT TO CHANGE UNMODIFIABLE TABLE ENTRY. NUX76500016 MBER= ' 76800016 MS903DT DC C' ' 77100016 MS903E EQU * 77400016 MS903LN EQU MS903E-MS903 77700016 MS903D EQU MS903DT-MS903 78000016 EJECT 78300016 TABSIZE EQU 8 78600016 LAST EQU X'80' LAST PARAMETER INDICATION 78900016 FF EQU X'FF' 79200016 CCHAR EQU X'80' BIT INDICATING CONTROL CHAR. 79500016 * IS TO BE ADDED FOR ERROR 212 79800016 MODIFY EQU X'40' BIT INDICATING TABLE ENTRY 80100016 * CAN BE MODIFIED 80400016 PRNTBUF EQU X'10' BIT INDICATING THAT CURRENT 80700016 * BUFFER IS TO BE PRINTED ALONG 81000016 * WITH THE ERROR MESSAGE 81300016 PRNTMSG EQU X'04' BIT INDICATING ALWAYS PRINT MSG. 81600016 TRACE EQU X'02' BIT INDICATING GIVE TRACE 81900016 ERRTBL DSECT 82200016 MAXERR DS X MAX. NUMBER OF ERRORS 82500016 MAXMESS DS X MAX. NUMBER OF MESSAGES 82800016 NUMERR DS X NUMBER OF ERRORS SO FAR 83100016 BITS DS X BITS 83400016 USERADDR DS 4X ADDRESS OF USER'S FIXUP ROUTINE 83700016 * IF NONE IS PRESENT THIS WORD 84000016 * SHOULD CONTAIN A ONE TO INDICATE 84300016 * NO ADDRESS IS PRESENT 84600016 OPTIONTB DSECT 84900016 NUMENTR DS 4X NUMBER OF ENTRIES IN OPTION 85200016 * TABLE 85500016 DS 4X 85800016 ERRORENT DS 8X ENTRY IN TABLE PER ERROR 86100016 END 86400016 ./ ADD SSI=01012000,NAME=IHCFOVER,SOURCE=0 IHCFOVER START 0 00020000 ENTRY OVERFL EXPONENT OVERFLOW/UNDERFLOW TEST 00040000 EXTRN IBCOM# USES OVFIND (SET BY IBFINT) 00060000 SPACE 3 00080000 * CALLING SEQUENCE 00100000 * LA S,SAVLOC 00120000 * LA A,ARGLST 00140000 * L L,=V(OVERFL) 00160000 * BALR R,L 00180000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00200000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00220000 * DC AL4(J) ADDRESS OF INTEGER VARIABLE 00240000 SPACE 3 00260000 * ERROR CONDITIONS 00280000 * NONE 00300000 SPACE 3 00320000 * REGISTER DEFINITIONS 00340000 S EQU 13 SAVE AREA POINTER 00360000 R EQU 14 RETURN REGISTER 00380000 L EQU 15 LINKAGE REGISTER 00400000 A EQU 1 ARGUMENT LIST POINTER 00420000 INDEX EQU 2 PARAMETER LOCATOR 00440000 I EQU 3 OVERFLOW/UNDERFLOW INDICATOR 00460000 J EQU 4 STATUS INDICATOR 00480000 SPACE 3 00500000 * BRANCHING CONDITIONS 00520000 ALWAYS EQU 15 UNCONDITIONAL 00540000 ALL EQU 1 ALL BITS ON 00560000 SOME EQU 4 SOME BITS ON 00580000 SPACE 3 00600000 * MISCELLANEOUS CODES 00620000 ON EQU X'FF' ON CONDITION 00640000 OFF EQU X'00' OFF CONDITION 00660000 EJECT 00680000 * 00700000 USING *,15 00720000 OVERFL B 12(0,15) 00740000 DC AL1(6) 00760000 DC CL6'OVERFL' 00780000 STM 14,4,12(13) 00800000 BCR 15,0 PIPE-LINE DRAIN FOR MOD 92 00820000 L INDEX,0(0,A) GET ADDRESS OF J 00840000 L I,VIBCOM 00860000 TM 72(I),ON TEST O/U INDICATOR 00880000 BC ALL,OVER OVERFLOW 00900000 BC SOME,UNDER UNDERFLOW 00920000 LA J,2 NEITHER, SET J = 2. 00940000 BC ALWAYS,STASHJ 00960000 OVER LA J,1 OVERFLOW, SET J = 1. 00980000 BC ALWAYS,STASHJ 01000000 UNDER LA J,3 UNDERFLOW, SET J = 3. 01020000 STASHJ ST J,0(0,INDEX) 01040000 MVI 72(I),OFF RESET O/U INDICATOR 01060000 LM 14,4,12(S) RESTORE MAIN REGISTERS 01080000 MVI 12(S),X'FF' 01100000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01120000 * 01140000 SPACE 3 01160000 * 01180000 * DATA AND STORAGE AREAS 01200000 * 01220000 DS 0F 01240000 VIBCOM DC AL4(IBCOM#) 01260000 * 01280000 SPACE 3 01300000 END 01320000 ./ ADD SSI=02010725,NAME=IHCFRXPI,SOURCE=0 IHCFRXPI CSECT 00020000 EXTRN IBCOM# 00040000 EXTRN IHCERRM 00050016 ENTRY FRXPI# 00060000 * SGL PREC FLOATING POINT BASE, FIXED POINT EXPONENT LIBRARY ROUTINE 00080000 USING *,15 00100000 FRXPI# B 12(0,15) 00120000 DC AL1(6) 00140000 DC CL6'FRXPI#' 00160000 STM 14,ADDR,12(13) 00180000 BEGIN EQU * 00190016 L ADDR,0(0,PLIST) LOAD PLIST OF BASE NO IN ADDR REG 00200000 LE BASE,0(0,ADDR) LOAD BASE NO INTO BASE NO REG 00220000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00240000 L EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00260000 LTER BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00280000 BC 8,ERROR IF BASE NO IS ZERO, BRANCH TO ERROR 00300000 SR EXPSW,EXPSW SET NEGATIVE EXPN SWITCH REG TO ZERO 00320000 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00340000 BC 2,PLUS IF EXPN IS POSITIVE, BRANCH TO PLUS 00360000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00380000 LCR EXPN,EXPN EXPN MINUS, CONVERT TO 2S COMPLIMENT 00400000 LA EXPSW,1(EXPSW) SET EXP SW REG TO ONE FOR MINUS EXPN 00420000 PLUS LE FACTOR,ONE LOAD FACTOR OF ONE IN FACTOR REG 00440000 LOOP SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 00460000 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 00480000 BC 10,JUMP IF SIGN BIT NOT MINUS,BRANCH TO JUMP 00500000 MER FACTOR,BASE MULTIPLY FACTOR REG BY BASE NO REG 00520000 JUMP LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00540000 BC 8,NEXT IF EXPONENT NOW ZERO, BRANCH TO NEXT 00560000 MER BASE,BASE MULTIPLY BASE NO BY DOUBLING ITSELF 00580000 BC 15,LOOP BRANCH TO LOOP TO TEST NEXT EXPN BIT 00600000 NEXT LTR EXPSW,EXPSW TEST IF EXPSW REG PLUS,MINUS,OR ZERO 00620000 BC 8,SWAP IF EXPN IS NOT MINUS, BRANCH TO SWAP 00640000 LE BASE,ONE LOAD ONE IN BASE NO REG AS DIVIDEND 00660000 DER BASE,FACTOR DIV BASE REG BY FACTOR REG (RESULT) 00680000 BC 15,EXIT BRANCH TO EXIT (RESULT IN BASE REG) 00700000 SWAP LER BASE,FACTOR LOAD FACTOR REG INTO BASE NO REG 00720000 BC 15,EXIT BRANCH TO EXIT (RESULT IN BASE REG) 00740000 LOAD1 LE BASE,ONE LOAD PLUS 1 AS RESULT IN BASE NO REG 00760000 EXIT LM RTN,ADDR,12(SAVE) RELOAD FORMER VALUES OF GP REG 14-3 00780000 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 00800000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 00820000 ERROR LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00840000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 00860000 STE BASE,DATA 00863016 ST EXPN,DATA1 00866016 LA 2,DATA1 00869016 LA 3,MSGDATA AREA IN MSG FOR DATA 00872016 LR 14,15 SAVE ADDRESSABILITY 00875016 LR PLIST,SAVE SAVE CALLER'S SAVE AREA ADDR 00878016 L 15,VIBCOM 00881016 LA SAVE,OFFSET(15) SAVE AREA IN IBCOM 00884016 ST PLIST,4(SAVE) STORE CALLER ADDR IN NEW SAVE 00887016 ST SAVE,8(PLIST) STORE NEW SAVE IN CALLER'S AREA 00890016 EX 0,82(15) FCVIO 00893016 BALR 0,1 00896016 DC X'040B' LL=4 WW=11 00899016 DROP 15 00902016 USING FRXPI#,14 00905016 LA PLIST,ERRLIST 00908016 L LINK,AERRMON 00911016 LR 0,14 SAVE ADDRESSABILITY 00914016 BALR 14,15 00917016 LR 15,0 RESTORE ADDRESSABILITY 00920016 DROP 14 00923016 USING FRXPI#,15 00926016 L 13,4(13) RESTORE 13 TO CALLER AREA 00929016 CLI RETCODE+3,X'00' DID USER FIX DATA 00932016 BZ EXIT RESULT IN REG ALREADY ZERO 00935016 FIXUP LA PLIST,ERRLIST+12 POINT TO ADCONS OF DATA 00938016 B BEGIN 00941016 * FLOATING POINT REGISTERS 00960000 BASE EQU 0 REGISTER FOR BASE NO, PASSING RESULT 00980000 FACTOR EQU 2 REGISTER FOR FACTOR,COMPUTING RESULT 01000000 * GENERAL PURPOSE REGISTERS 01020000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01040000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01060000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01080000 EXPSW EQU 0 REGISTER FOR TESTING FOR MINUS EXPN 01100000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01120000 EXPN EQU 2 REGISTER FOR EXPONENT IN COMPUTATION 01140000 ADDR EQU 3 REGISTER FOR INDEXING PARAMETER ADDR 01160000 * ADCONS AND CONSTANTS AREA 01180000 OFFSET EQU X'C4' 01190016 DS 0F FORCE TO NEXT FULL WORD BOUNDARY 01200000 ONE DC X'41100000' CONSTANT ONE IN SINGLE PREC F P 01220000 VIBCOM DC A(IBCOM#) 01240000 AERRMON DC V(IHCERRM) 01241016 ERRLIST DC A(MSGLNG) 01242016 DC A(RETCODE) 01243016 DC A(ERRNUM) 01244016 DC A(DATA) 01245016 DC X'80' 01246016 DC AL3(DATA1) 01247016 DATA DS F 01248016 DATA1 DS F 01249016 ERRNUM DC F'242' 01250016 RETCODE DS F'0' 01251016 EJECT 01252016 MSGLNG DC A(ENDMSG-MSG) 01253016 MSG DC C'IHC242I FRXPI REAL*4 BASE=0.0, INTEGER EXPONENT=' 01254016 MSGDATA DS 11C 01255016 DC C', LE 0' 01256016 ENDMSG EQU * 01257016 END 01260000 ./ ADD SSI=02010725,NAME=IHCFRXPR,SOURCE=0 IHCFRXPR CSECT 00020000 EXTRN IBCOM# 00040000 EXTRN IHCERRM 00050016 EXTRN ALOG 00060000 EXTRN EXP 00080000 ENTRY FRXPR# 00100000 * SGL PREC FLOATING POINT BASE, FLOATING POINT EXPONENT LIBRARY ROUTINE 00120000 USING *,15 00140000 FRXPR# B 12(0,15) 00160000 DC AL1(6) 00180000 DC CL6'FRXPR#' 00200000 STM 14,ADDR,12(13) 00220000 BALR BASADD,0 00222016 USING *,BASADD 00224016 LR ADDR,SAVE 00226016 LA SAVE,SAVREG 00228016 ST ADDR,4(SAVE) 00230016 ST SAVE,8(ADDR) 00232016 BEGIN EQU * 00234016 L ADDR,0(0,PLIST) LOAD PLIST OF BASE NO IN ADDR REG 00240000 LE BASE,0(0,ADDR) LOAD BASE NO INTO BASE NO REG 00260000 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 00280000 LE EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 00300000 LTER BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 00360000 BC 8,ERROR IF BASE NO IS ZERO, BRANCH TO ERROR 00380000 LTER EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00400000 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 00420000 STE EXPN,PARAM STORE EXPONENT FOR LATER USE IN RTN 00520000 L LINK,ADCLOG LOAD ADCON OF ALOG RTN IN LINK REG 00540000 BALR RTN,LINK BRANCH TO ALOG RTN FOR LOG OF BASE 00560000 LE EXPN,PARAM RELOAD EXPN REG WITH EXPONENT 00580000 MER BASE,EXPN MULTIPLY LOG OF BASE NO BY EXPONENT 00600000 STE BASE,PARAM STORE RESULT AS EXP RTN PARAMETER 00620000 LA PLIST,ADCPAR MOD PLIST TO POINT TO EXP RTN PARAM 00640000 L LINK,ADCEXP LOAD ADCON OF EXP RTN IN LINK REG 00660000 BALR RTN,LINK BRANCH TO EXP RTN TO COMPUTE RESULT 00680000 BC 15,EXIT BRANCH TO EXIT (RESULT IN BASE REG) 00720000 LOAD1 LE BASE,ONE LOAD PLUS 1 AS RESULT IN BASE NO REG 00740000 EXIT L 13,4(13) 00750016 LM 14,ADDR,12(13) 00760016 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 00780000 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 00800000 ERROR LTER EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 00820000 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 00840000 STE BASE,DATA 00845016 STE EXPN,DATA1 00850016 LA 3,MSGDATA 00855016 L 15,VIBCOM 00860016 LR 14,2 SAVE ADDRESSABILITY 00865016 LA 2,DATA1 00870016 EX 0,86(15) FCVEO 00875016 BALR 0,1 00880016 DC X'040E0700' LL=4 WW=14 DD=7 SS=0 00885016 LR 2,14 RESTORE ADDRESSABILITY 00890016 L LINK,AERRMON 00895016 LA PLIST,ERRLIST 00900016 BALR 14,15 00905016 CLI RETCODE+3,X'00' DID USER FIX DATA 00910016 BZ EXIT RESULT IN REG ALREADY ZERO 00915016 FIXUP LA PLIST,ERRLIST+12 POINT TO ADCONS OF DATA 00920016 B BEGIN 00925016 * FLOATING POINT REGISTERS 00940000 BASE EQU 0 REGISTER FOR BASE NO, PASSING RESULT 00960000 EXPN EQU 2 REGISTER FOR EXPONENT IN COMPUTATION 00980000 * GENERAL PURPOSE REGISTERS 01000000 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 01020000 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 01040000 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 01060000 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 01080000 BASADD EQU 2 REGISTER USED FOR SECOND BASE ADDR 01100000 ADDR EQU 3 REGISTER FOR INDEXING PARAMETER ADDR 01120000 * CONSTANTS AND ADCON AREAS 01140000 SAVREG DS 18F 01160016 PARAM DS F PARAM FOR DATA IN EXP MATH RTN 01180000 ONE DC X'41100000' CONSTANT ONE IN SINGLE PREC F P 01200000 ADCPAR DC AL4(PARAM) ADCON OF PARAMETER FOR EXP RTN 01220000 ADCLOG DC AL4(ALOG) ADCON OF ALOG MATH LIBRARY RTN 01240000 ADCEXP DC AL4(EXP) ADCON OF EXP MATH LIBRARY RTN 01260000 VIBCOM DC A(IBCOM#) 01280000 AERRMON DC V(IHCERRM) 01281016 DATA DS F 01282016 DATA1 DS F 01283016 ERRNUM DC F'244' 01284016 RETCODE DS F 01285016 ERRLIST DC A(MSGLNG) 01286016 DC A(RETCODE) 01287016 DC A(ERRNUM) 01288016 DC A(DATA) 01289016 DC X'80' LAST LIST ITEM 01290016 DC AL3(DATA1) 01291016 EJECT 01292016 MSGLNG DC A(ENDMSG-MSG) 01293016 MSG DC C'IHC244I FRXPR REAL*4 BASE=0.0, REAL*4 EXPONENT=' 01294016 MSGDATA DS 14C 01295016 DC C', LE 0' 01296016 ENDMSG EQU * 01297016 END 01300000 ./ ADD SSI=02010725,NAME=IHCFSLIT,SOURCE=0 IHCFSLIT START 0 00020000 ENTRY SLITE SIMULATED SENSE LIGHT SET 00040000 ENTRY SLITET SIMULATED SENSE LIGHT TEST 00060000 EXTRN IBCOM# USES THE IBFERR ROUTINE 00080000 EXTRN IHCERRM 00090016 SPACE 3 00100000 * CALLING SEQUENCES 00120000 * 00140000 * LA S,SAVLOC 00160000 * LA A,ARGLST 00180000 * L L,=V(SLITE) 00200000 * BALR R,L 00220000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00240000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00260000 * DC AL4(I) ADDRESS OF INTEGER VALUE 00280000 * 00300000 * LA S,SAVLOC 00320000 * LA A,ARGLST 00340000 * L L,=V(SLITET) 00360000 * BALR R,L 00380000 * SAVLOC IS THE LOCATION OF A REGISTER STORAGE AREA, 00400000 * AND ARGLST IS OF THE FOLLOWING FORM ... 00420000 * DC AL4(I) ADDRESS OF INTEGER VALUE 00440000 * DC AL4(J) ADDRESS OF INTEGER VARIABLE 00460000 * 00480000 SPACE 3 00500000 * ERROR CONDITIONS 00520000 * I GT 4, LT 0 -- FOR SLITE 00540000 * I GT 4, LE 0 -- FOR SLITET 00560000 SPACE 3 00580000 * REGISTER DEFINITIONS 00600000 S EQU 13 SAVE AREA POINTER 00620000 R EQU 14 RETURN REGISTER 00640000 L EQU 15 LINKAGE REGISTER 00660000 A EQU 1 ARGUMENT LIST POINTER 00680000 INDEX EQU 2 PARAMETER LOCATOR 00700000 BASE EQU 2 BASE REG FOR ERROR CONDITION 00710016 I EQU 3 SENSE LIGHT NUMBER 00720000 J EQU 4 STATUS INDICATOR 00740000 SPACE 3 00760000 * BRANCHING CONDITIONS 00780000 ALWAYS EQU 15 UNCONDITIONAL 00800000 HIGH EQU 2 HIGH 00820000 MINUS EQU 4 MINUS 00840000 ZERO EQU 8 ZERO 00860000 ZMINUS EQU 12 ZERO OR MINUS 00880000 NONE EQU 8 NO BITS ON 00900000 SPACE 3 00920000 * MISCELLANEOUS CODES 00940000 ON EQU X'FF' ON CONDITION 00960000 OFF EQU X'00' OFF CONDITION 00980000 EJECT 01000000 * 01020000 USING *,15 01040000 SLITE B 10(0,15) 01060000 DC AL1(5) 01080000 DC CL5'SLITE' 01100000 STM 14,4,12(13) 01120000 L INDEX,0(0,A) GET ADDRESS OF I 01140000 L I,0(0,INDEX) GET I 01160000 CH I,LIMIT 01180000 BC HIGH,ERROR ERROR, I GT 4. 01200000 LTR I,I 01220000 BC MINUS,ERROR ERROR, I LT 0. 01240000 BC ZERO,ALLOFF I EQ 0 01260000 LA I,SLITES-1(I) 01280000 MVI 0(I),ON TURN ON SENSE LIGHT 01300000 BC ALWAYS,EXIT 01320000 ALLOFF LH I,LIMIT GET NUMBER OF SENSE LIGHTS 01340000 BUMPER LA INDEX,SLITES-1(I) 01360000 MVI 0(INDEX),OFF TURN OFF ALL LIGHTS 01380000 BCT I,BUMPER 01400000 EXIT LM 14,3,12(S) RESTORE MAIN REGISTERS 01420000 MVI 12(S),X'FF' 01440000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01460000 * 01480000 SPACE 3 01500000 * 01520000 USING *,15 01540000 SLITET B 12(0,15) 01560000 DC AL1(6) 01580000 DC CL6'SLITET' 01600000 STM 14,4,12(13) 01620000 L INDEX,0(0,A) GET ADDRESS OF I 01640000 L I,0(0,INDEX) GET I 01660000 L INDEX,4(0,A) GET ADDRESS OF J 01670016 CH I,LIMIT 01680000 BC HIGH,ERROR ERROR, I GT 4. 01700000 LTR I,I 01720000 BC ZMINUS,ERROR ERROR, I LE 0. 01740000 LA I,SLITES-1(I) 01780000 TM 0(I),ON TEST SENSE LIGHT STATUS 01800000 BC NONE,ITSOFF 01820000 LA J,1 ON, SET J = 1. 01840000 BC ALWAYS,STASHJ 01860000 ITSOFF LA J,2 OFF, SET J = 2. 01880000 STASHJ ST J,0(0,INDEX) 01900000 MVI 0(I),OFF TURN OFF SENSE LIGHT 01920000 LM 14,4,12(S) RESTORE MAIN REGISTERS 01940000 MVI 12(S),X'FF' 01960000 BCR ALWAYS,R RETURN TO MAIN PROGRAM 01980000 * 02000000 SPACE 3 02020000 * 02040000 ERROR BALR R,0 SET UP NEW BASE REGISTER 02042016 USING *,R TEMPORARILY IN 14 02044016 ST INDEX,DATA2 MOVE ADDR OF J IN PARM FOR RETRY 02046016 * IN CASE SLITET ERROR 02048016 ST I,DATA1 STORE ILLEGAL DATA 02050016 LA BASE,DATA1 SET UP FOR CONVERSION OF DATA 02052016 LA I,MSGDATA 02054016 L L,VIBCOM ADDR IBCOM# 02056016 EX 0,82(L) FCVIO 02058016 BALR 0,1 02060016 DC X'0404' LL=4 WW=4 02062016 SPACE 02064016 LR BASE,R SET UP BASE AS USING REGISTER 02066016 DROP R 02068016 USING ERROR+2,BASE 02070016 LR I,S LINK SAVE AREAS 02072016 LA S,OFFSET(L) ADDR COMMON SAVE AREA IN IBCOM 02074016 ST I,4(S) 02076016 ST S,8(I) 02078016 L L,AERRMON ADDR OF ERRMON 02080016 LA A,ERRLIST PARMS FOR ERRMON 02082016 BALR R,L 02084016 SPACE 02086016 LR S,I RESTORE SAVE AREA POINTER 02088016 L L,16(S) GET ENTRY POINT 02090016 LA A,ERRLIST+12 NEW ARG LIST FOR RETRY 02092016 CLI RETCODE+3,X'00' DID USER FIX DATA 02094016 BZ STANDFIX NO-TAKE STANDARD FIXUP 02096016 CLI 4(L),6 CHECK LENGTH OF NAME TO 02098016 * DETERMINE RETURN POINT (OFFSET 02100016 * TO ENTRY POINT IN 15. 02102016 * SKIP STM 02104016 BL 14(L) SLITE+14 02106016 B 16(L) SLITET+16 02108016 SPACE 02110016 STANDFIX CLI 4(L),6 CHECK IF SLITE OR SLITET BY 02112016 * LENGTH OF NAME AT ENTRY 02114016 DROP BASE 02116016 USING SLITE,L STANDARD FIXUP FOR SLITE 02118016 BL EXIT IS TO DO NOTHING 02120016 USING SLITET,L STANDARD FIXUP FOR SLITET IS TO 02122016 * SET J=2, I.E. SENSE LIGHT IS OFF 02124016 L INDEX,4(A) GET ADDRESS OF J FOR STASHJ 02126016 B ITSOFF 02128016 * 02160000 SPACE 3 02180000 * 02200000 * DATA AND STORAGE AREAS 02220000 * 02240000 DS 0F 02260000 VIBCOM DC AL4(IBCOM#) 02280000 SLITES DC AL4(0) SENSE LIGHT STORAGE 02300000 LIMIT DC AL2(*-SLITES) NUMBER OF SENSE LIGHTS 02320000 OFFSET EQU X'C4' 02321016 ERRLIST DC A(MSGLNG) 02322016 DC A(RETCODE) 02323016 DC A(ERRNUM) 02324016 DC X'80' 02325016 DC AL3(DATA1) 02326016 DATA2 DS F FOR ADDRESS OF J 02327016 DATA1 DS F FOR SENSE LIGHT NUMBER 02328016 ERRNUM DC F'216' 02329016 AERRMON DC V(IHCERRM) 02330016 RETCODE DS F 02331016 EJECT 02332016 MSGLNG DC A(ENDMSG-MSG) 02333016 MSG DC C'IHC216I SLITE-SLITET ' 02334016 MSGDATA DS 4C 02335016 DC C' IS AN ILLEGAL VALUE' 02336016 ENDMSG EQU * 02337016 * 02340000 SPACE 3 02360000 END 02380000 ./ ADD SSI=01010722,NAME=IHCIBERH,SOURCE=0 IHCIBERH CSECT 00020000 * 00040000 * CALLING SEQUENCE - 00060000 * LA 1,PARMLST 00080000 * L 15,=V(IBERH#) 00100000 * BAL 14,15 00120000 *PARMLST DC A(PARM) 00140000 *PARM DC AL4(ISN) 00160000 * WHERE ISN IS THE BINARY 4 BYTE VALUE OF 00180000 * THE INTERNAL STATEMENT NUMBER WHICH CANNOT 00200000 * BE EXECUTED BECAUSE OF A SOURCE LANGUAGE ERROR, 00220000 * OR FOR ANY OTHER REASON. 00240000 * THE LARGEST VALUE PROVIDED FOR IS 2 TO 15 - 1 00260000 * 00280000 ENTRY IBERH# 00300000 POSZONE EQU C'0' 00350016 IBCSV EQU X'C4' 00400016 USING *,15 00450016 IBERH# L 12,VIBCOM 00500016 STM 14,1,12(13) SAVE REGISTERS 00550016 L 1,0(1) 00600000 LH 2,2(0,1) 00620000 CVD 2,DECIM CONVERT ISN 00640000 UNPK ISN(5),DECIM+5(3) N BYTES INTO 2N-1 BYTES 00660000 OI ISN+4,POSZONE 00680000 L 1,4(13) 00700000 L 1,16(1) 00720000 SR 2,2 CLEAR EXECUTE REGISTER 00740000 IC 2,4(1) PICK UP THE NUMBER OF CHARACTERS 00760000 BCTR 2,0 DECREMENTCOUNT BY ONE 00780000 EX 2,EPMOVE EXECUTE THE MOVE INSTRUCTION 00800000 ST 13,IBCSV+4(0,12) STORE ADDR OF CALLER SAVE AREA 00820016 LA 13,IBCSV(0,12) IN COMMON SAVE AREA OF IBCOM 00840016 LA 1,PRAMS GO TO ERROR MONITOR 00860016 L 15,VIHCERRM 00880016 BALR 14,15 00900016 LR 15,12 00920016 BAL 14,68(0,15) 00940016 DC AL2(16) 00960016 DECIM DS 1D 01060000 VIBCOM DC V(IBCOM#) 01070016 VIHCERRM DC V(IHCERRM) 01080016 PRAMS DC A(MSGLNG) 01090016 DC A(DECIM) 01100016 DC XL1'80' 01110016 DC AL3(E230) 01120016 E230 DC F'230' 01130016 MSGLNG DC A(ENDMSG-MSG) 01140016 MSG EQU * 01150016 DC C'IHC230I - ' STANDARD ERROR FORM 01180000 DC C'SOURCE ERROR AT ' 01200000 DC C'ISN ' 01220000 ISN DC C'XXXXX - ' UP TO FIVE DIGIT ISN 01240000 DC C'EXECUTION FAILED' 01260000 DC C' AT SUBROUTINE-' 01280000 SBRTNE DC C' ' 01300000 ENDMSG EQU * 01320016 EPMOVE MVC SBRTNE(1),5(1) MOVES NAME INTO ERROR MESSAGE 01340000 END 01360000 ./ ADD SSI=01010722,NAME=IHCIBERR,SOURCE=0 IHCIBERR START 0 00020000 * 00040000 * CALLING SEQUENCE - 00060000 * L 15,=V(IBERR) 00080000 * BAL 14,15 00100000 * DC AL4(ISN) 00120000 * WHERE ISN IS THE BINARY 4 BYTE VALUE OF 00140000 * THE INTERNAL STATEMENT NUMBER WHICH CANNOT 00160000 * BE EXECUTED BECAUSE OF A SOURCE LANGUAGE ERROR, 00180000 * OR FOR ANY OTHER REASON. 00200000 * THE LARGEST VALUE PROVIDED FOR IS 2 TO 15 - 1 00220000 * 00240000 EJECT 00260000 ENTRY IBERR# 00280000 USING *,15 00380016 IBERR# EQU * 00480016 LH 2,2(0,14) LOAD ISN 00580000 CVD 2,DECIM CONVERT ISN 00600000 UNPK ISN(5),DECIM+5(3) N BYTES INTO 2N-1 BYTES 00620000 OI ISN+4,POSZONE 00640000 * MESSAGE IS SET UP. GO TO IHCERRM. 00690016 LA 1,PRAMS 00740016 L 15,VIHCERRM 00790016 BALR 14,15 00840016 DECIM DS 1D 00900000 PRAMS DC A(MSGLNG) *PARAMS FOR IHCERRM 00910016 DC A(0) * 00920016 DC XL1'80' * 00930016 DC AL3(E230) * 00940016 POSZONE EQU X'F0' FOR LAST DIGIT OF ISN 00950016 VIHCERRM DC V(IHCERRM) 00960016 E230 DC F'230' 00970016 MSGLNG DC A(ENDMSG-MSG) LENGTH OF MESSAGE 00980016 MSG EQU * 00990016 DC C'IHC230I - ' STANDARD ERROR FORM 01020000 DC C'SOURCE ERROR AT ' 01040000 DC C'ISN ' 01060000 ISN DC C'XXXXX - ' UP TO FIVE DIGIT ISN 01080000 DC C'EXECUTION FAILED' 01100000 ENDMSG EQU * 01120016 END 01140000 ./ ADD SSI=01011164,NAME=IHCLASCN,SOURCE=0 TITLE ' ASCN ARC SIN-COS (LONG) ' 00010000 IHCLASCN CSECT 00020000 *C020920 MAINT 00030020 * ARCSIN-ARCCOSINE FUNCTION (LONG) 00040000 * 1. IF X BETWEEN 0 AND 1/2, COMPUTE ARCSIN BY POLYNOMIAL 00060000 * 2. IF X BETWEEN 1/2 AND 1, 00080000 * ARSIN(X) = PI/2-2*ARSIN(SQRT((1-X)/2)) 00100000 * 3. IF X NEGATIVE, ARSIN(X) = -ARSIN(/X/) 00120000 * 4. ARCOS(X) = PI/2-ARSIN(X) 00140000 * STATUS -- CHANGE LEVEL 02, 21OCT70 RELEASE 20 * 00150020 EXTRN DSQRT 00160000 EXTRN IHCERRM 00170016 EXTRN IBCOM# 00180000 ENTRY DARSIN 00200000 ENTRY DARCOS 00220000 SPACE 00240000 GR2 EQU 2 ARGUMENT ADDRESS 00260018 GRA EQU 1 ARGUMENT POINTER 00280018 GRT EQU 3 PREVIOUS SAVE AREA POINTER 00300018 GRB EQU 4 MAIN BASE REGISTER 00320018 GRS EQU 13 SAVE AREA POINTER 00340018 GRR EQU 14 RETURN REGISTER 00360018 GRL EQU 15 LINK REGISTER 00380018 FR0 EQU 0 ANSWER REGISTER 00400018 FR2 EQU 2 SCRATCH REGISTERS 00420018 FR4 EQU 4 00440018 FR6 EQU 6 00460018 ISN EQU X'106' INDENTIFIER NUMBER FOR DSQRT CALL 00480018 SPACE 00500018 USING *,GRL 00520018 DARCOS BC 15,LACOS 00540018 DC AL1(6) 00560018 DC CL6'DARCOS' 00580018 LACOS STM GRR,GRB,12(GRS) SAVE REGISTERS 00600018 MVI SWICH1+1,X'00' SET SWICH1 TO 'BC 0' 00620018 BAL GRL,JOIN ADJUST BASE REGISTER AND SKIP TO JOIN 00640018 SPACE 00660018 USING *,GRL 00680018 DARSIN BC 15,LASIN 00700018 DC AL1(6) 00720018 DC CL6'DARSIN' 00740018 LASIN STM GRR,GRB,12(GRS) SAVE REGISTERS 00760018 MVI SWICH1+1,X'F0' SET SWICH1 TO 'BC 15' 00780018 SPACE 00860000 JOIN L GR2,0(GRA) BOTH ENTRIES MERGE HERE 00880000 LR GRB,GRL SWITCH BASE REGISTER TO GRB 00920000 USING DARSIN,GRB 00940000 DROP GRL 00960000 SPACE 00980000 BEGIN LD FR6,0(GR2) OBTAIN ARG X. LEAVE ADDR IN GR2 00990018 LPDR FR0,FR6 /X/ TO FR0 01000018 MVI SWICH2+1,X'10' 01010018 CE FR0,HALF IF/X/ SMALLER THAN 1/2, SET SWICH2 01020018 BC 12,MINMAX TO 'BC 1' AND SKIP TO MINMAX SECTION 01030018 SPACE 01040018 MVI SWICH2+1,X'80' IF /X/ GREATER THAN 1/2, SET SWICH2 01050018 LNER FR0,FR0 TO 'BC 8' AND COMPUTE 1-/X/ 01060018 LR GRT,GRS THIS CUTS DOWN ROUND-OFF ERROR 01070000 LA GRS,AREA (LSQRT LEAVES FR6 UNTOUCHED) 01080000 ST GRS,8(GRT) 01090000 ST GRT,AREA+4 SWITCH SAVE AREA POINTERS 01100000 AD FR0,ONE 01110000 BC 4,ERROR IF /X/ GREATER THAN 1, ERROR 01120018 HDR FR6,FR0 LET Z = SQRT((1-/X/)/2), 01130018 ADR FR0,FR0 KEEP Z**2 IN FR6 AND COMPUTE 01140018 STD FR0,BUFF 2*Z WHICH IS SQRT(2*(1-/X/)). 01150018 LA GRA,ABUFF 01160018 L GRL,ASQRT 01170018 BALR GRR,GRL GO TO SQRT 01180018 BC 0,ISN 01190018 LR GRS,GRT RESTORE SAVE AREA POINTER 01200018 BC 15,MERGE MERGE WITH MINIMAX EVALUATION SECTION 01210018 SPACE 01220018 MINMAX CE FR0,LOLIM IF /X/ IS SMALLER THAN 16**-7, 01230018 BC 2,*+6 SUBSTITUTE 0 FOR X**2 TO AVOID 01240018 SDR FR6,FR6 UNDERFLOW MESSAGE 01250018 MDR FR6,FR6 FOR /X/ LE 1/2, GET X**2 IN FR6 01260018 MERGE LD FR4,C5 COMMON CIRCIUT 01270018 ADR FR4,FR6 COMPUTE ARCSIN(/X/) 01280018 LD FR2,D4 OR 2*ARCSIN(Z) AS THE CASE MAY BE 01290018 DDR FR2,FR4 01300018 AD FR2,C4 FR0 CONTAINS /X/ OR 2*Z 01310018 ADR FR2,FR6 FR6 CONTAINS X**2 OR Z**2 01320018 LD FR4,D3 01330018 DDR FR4,FR2 USE MINIMAX APPROXIMATION OF FORM, 01340018 AD FR4,C3 01350018 ADR FR4,FR6 01360018 LD FR2,D2 ARCSIN(W) = W+F*W**3 WHERE 01370018 DDR FR2,FR4 01380018 AD FR2,C2 F = C1+D1/(WSQ+C2+D2/(WSQ+C3+D3 01390018 ADR FR2,FR6 01400018 LD FR4,D1 /(WSQ+C4+D4/(WSQ+C5)))) 01410018 DDR FR4,FR2 01420018 AD FR4,C1 01430018 MDR FR4,FR6 01440018 MDR FR4,FR0 POSTPONE COMBINING FR4 AND FR0 01450018 SPACE 01460018 TM SWICH1+1,X'80' IF ARSIN FOR BIG /X/ OR 01470018 SWICH2 BC 1,SIGN ARCOS FOR SMALL /X/, SUBTRACT 01480018 SD FR4,ONE THE WORK FROM PI/2. DO THIS CARE- 01490018 SD FR0,PO2M1 FULLY TO REDUCE ROUND-OFF ERROR 01500018 SIGN ADR FR0,FR4 AT THIS POINT COMBINE FR6 AND FR0 TO 01510018 LPDR FR0,FR0 COMPLETE COMPUTATION OF ANS FOR /X/ 01520018 TM 0(GR2),X'80' 01530018 BC 8,FIN IF ARG IS POSITIVE, DONE 01540018 LNER FR0,FR0 IF ARG NEGATIVE AND ARSIN, SWITCH SIGN 01550018 SWICH1 BC 15,FIN IF ARG NEGATIVE AND ARCOS, 01560018 AD FR0,PI SUBTRACT FR0 FROM PI 01570018 SPACE 01580018 FIN LM GRR,GRB,12(GRS) RESTORE REGISTERS 01590000 MVI 12(GRS),X'FF' AND RETURN 01600000 BCR 15,GRR 01610000 SPACE 01620000 ERROR STD FR6,DATA /X/ GT 1, STORE ARG 01630018 LM GRR,GRL,AERRMON ERMON ADDR IN 14, IBCOM IN 15 02028016 LA 2,DATA PREPARE FOR CONVERSION 02032016 LA 3,MSGDATA 02036016 EX 0,90(GRL) FCVDO 02040016 BALR 0,1 02044016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 02048016 LA 1,ERRLIST 02068016 LR GRL,GRR ADDR OF ERMON IN 15 02072016 BALR 14,15 GO TO ERMON 02076016 L GRS,4(GRS) RESTORE SAVE AREA POINTER 02080000 CLI RETCODE+3,X'00' DID USER FIX DATA 02084016 BNZ BEGIN YES-START AGAIN 02088016 SDR FR0,FR0 STANDARD FIXUP = 0 MAINT 02092020 B FIN 02096016 EJECT 02100016 DATA DS D 02104016 SPACE 02120000 BUFF DS D 02140000 C1 DC X'3F180CD96B42A610' 0.00587162904063511 02160018 D1 DC X'C07FE6DD798CBF27' -0.49961647241138661 02180018 C2 DC X'C1470EC5E7C7075C' -4.44110670602864049 02200018 D2 DC X'C1489A752C6A6B54' -4.53770940160639666 02220018 C3 DC X'C13A5496A02A788D' -3.64565146031194167 02240018 D3 DC X'C06B411D9ED01722' -0.41896233680025977 02260018 C4 DC X'C11BFB2E6EB617AA' -1.74882357832528117 02280018 D4 DC X'BF99119272C87E78' -0.03737027365107758 02300018 C5 DC X'C11323D9C96F1661' -1.19625261960154476 02320018 ONE DC X'4110000000000000' 1.0 02340018 PO2M1 DC X'40921FB54442D184' PI/2 - 1.0 02360018 PI DC X'413243F6A8885A30' PI -F 02380018 HALF DC X'40800000' 0.5 02400018 LOLIM DC X'3A100000' 16**-7 02420018 AERRMON DC V(IHCERRM) 02530016 ACOM DC A(IBCOM#) 02540000 ASQRT DC A(DSQRT) 02560000 ERRLIST DC A(MSGLNG) 02563016 DC A(RETCODE) 02566016 DC A(ERRNUM) 02569016 DC X'80' 02572016 DC AL3(DATA) 02575016 ABUFF DC X'80' 02580000 DC AL3(BUFF) 02600000 AREA DS 18F 02604016 ERRNUM DC F'267' 02608016 RETCODE DS F 02612016 EJECT 02616016 MSGLNG DC A(ENDMSG-MSG) 02620016 MSG DC C'IHC267I DARSIN-DARCOS /ARG/=/' 02624016 MSGDATA DS 23C 02628016 DC C'/, GT 1' 02632016 ENDMSG EQU * 02636016 END 02640000 ./ ADD SSI=02053630,NAME=IHCLATAN,SOURCE=0 LATN TITLE 'ARCTANGENT FUNCTION (LONG)' 00900018 IHCLATAN CSECT 01800018 * ARCTANGENT FUNCTION (LONG) 02700018 * 1. REDUCE THE CASE TO THE 1ST OCTANT BY USING 03600018 * ATAN(-X) = -ATAN(X), ATAN(1/X) = PI/2-ATAN(X). 04500018 * 2. REDUCE FURTHER TO THE CASE /X/ LESS THAN TAN(PI/12) 05400018 * BY ATAN(X) PI/6+ATAN((X*SQRT3-1)/(X+SQRT3)). 06300018 * 3. FOR THE BASIC RANGE (X LESS THAN TAN(PI/12)), USE 07200018 * A FRACTIONAL APPROXIMATION. 08100018 SPACE 09000018 ENTRY DATAN 09900018 SPACE 10800018 GRA EQU 1 ARGUMENT POINTER 11700018 GRS EQU 13 SAVE AREA POINTER 12600018 GRR EQU 14 RETURN REGISTER 13500018 GRL EQU 15 LINK REGISTER 14400018 GR0 EQU 0 SCRATCH REGISTERS 15300018 GR1 EQU 1 16200018 GR2 EQU 14 17100018 FR0 EQU 0 ANSWER REGISTER 18000018 FR2 EQU 2 SCRATCH REGISTERS 18900018 FR4 EQU 4 19800018 FR6 EQU 6 20700018 SPACE 21600018 USING *,GRL 22500018 DATAN BC 15,LATAN 23400018 DC AL1(5) 24300018 DC CL5'DATAN' 25200018 SPACE 26100018 LATAN STM GRR,GRL,12(GRS) SAVE REGISTERS 27000018 L GR1,0(GRA) 27900018 LD FR0,0(GR1) OBTAIN ARGUMENT 28800018 L GR0,0(GR1) SAVE ARG FOR SIGN CONTROL 29700018 LPER FR0,FR0 AND SET SIGN POSITIVE 30600018 LD FR4,ONE 31500018 SR GR1,GR1 GR1, GR2 FOR DISTINGUISHING CASES 32400018 LA GR2,ZERO 33300018 CER FR0,FR4 34200018 BC 12,SKIP1 35100018 LDR FR2,FR4 IF X GREATER THAN 1, TAKE INVERSE 36000018 DDR FR2,FR0 AND INCREMEMENT GR1 BY 16 36900018 LDR FR0,FR2 37800018 LA GR1,16 38700018 SPACE 39600018 SKIP1 CE FR0,SMALL IF ARG LESS THAN 16**-7, ANS=ARG. 40500018 BC 12,READY THIS AVOIDS UNDERFLOW EXCEPTION 41400018 CE FR0,TAN15 42300018 BC 12,SKIP2 43200018 LDR FR2,FR0 IF X GREATER THAN TAN(PI/12), 44100018 MD FR0,RT3M1 REDUCE X TO (X*SQRT3-1)/(X+SQRT3) 45000018 SDR FR0,FR4 COMPUTE X*SQRT3-1 AS 45900018 ADR FR0,FR2 X*(SQRT3-1)-1+X 46800018 AD FR2,RT3 TO GAIN ACCURACY 47700018 DDR FR0,FR2 48600018 LA GR2,8(GR2) INCREMENT GR2 BY 8 49500018 SPACE 50400018 SKIP2 LDR FR6,FR0 COMPUTE ATAN OF REDUCED ARGUMENT BY 51300018 MDR FR0,FR0 ATAN(X) = X+X*X**2*F, WHERE 52200018 LD FR4,C7 F = C1+C2/(X**2+C3+C4/ 53100018 ADR FR4,FR0 (X**2+C5+C6/(X**2+C7))) 54000018 LD FR2,C6 54900018 DDR FR2,FR4 55800018 AD FR2,C5 56700018 ADR FR2,FR0 57600018 LD FR4,C4 58500018 DDR FR4,FR2 59400018 AD FR4,C3 60300018 ADR FR4,FR0 61200018 LD FR2,C2 62100018 DDR FR2,FR4 63000018 AD FR2,C1 63900018 MDR FR0,FR2 64800018 MDR FR0,FR6 65700018 ADR FR0,FR6 66600018 SPACE 67500018 READY AD FR0,0(GR1,GR2) DEPENDING ON THE CASE, 68400018 LNR GR1,GR1 EITHER ADD 0 OR PI/6, OR 69300018 SD FR0,ZERO(GR1) SUBTRACT FROM PI/3 OR PI/2 70200018 LPER FR0,FR0 71100018 LTR GR0,GR0 DO THE LATTER IN TWO STEPS 72000018 BC 10,*+6 IF SIGN WAS NEGATIVE, 72900018 LNER FR0,FR0 ANSWER IS NEGATIVE 73800018 SPACE 74700018 EXIT L GRR,12(GRS) 75600018 MVI 12(GRS),X'FF' 76500018 BCR 15,GRR RETURN 77400018 SPACE 78300018 DS 0F 79200018 SMALL DC X'3A100000' 80100018 DS 0D 81000018 C1 DC X'BF1E31FF1784B965' -0.7371899082768562E-2 81900018 C2 DC X'C0ACDB34C0D1B35D' -0.6752198191404210 82800018 C3 DC X'412B7CE45AF5C165' 0.2717991214096480E+1 83700018 C4 DC X'C11A8F923B178C78' -0.1660051565960002E+1 84600018 C5 DC X'412AB4FD5D433FF6' 0.2669186939532663E+1 85500018 C6 DC X'C02298BB68CFD869' -0.1351430064094942 86400018 C7 DC X'41154CEE8B70CA99' 0.1331282181443987E+1 87300018 RT3M1 DC X'40BB67AE8584CAA8' SQRT(3)-1 88200018 ONE DC X'4110000000000000' THESE 89100018 RT3 DC X'411BB67AE8584CAB' SQRT(3) SIX 90000018 ZERO DC D'0' 0 CONSTANTS 90900018 DC X'40860A91C16B9B2C' PI/6 MUST 91800018 DC X'C0921FB54442D184' -PI/2+1 BE 92700018 DC X'BFC152382D736574' -(PI/3-F)+1 CONSECUTIVE 93600018 TAN15 DC X'40449851' 94500018 END 95400018 ./ ADD SSI=03011000,NAME=IHCLATN2,SOURCE=0 LAT2 TITLE 'ARCTANGENT FUNCTION (LONG, 2 ENTRY POINTS)' 00010018 IHCLATN2 CSECT 00020000 *HJNX 013600,0126-0130,0210-0234 18303 00030017 * 00040000 * ARCTANGENT FUNCTION (LONG, 2 ENTRY POINTS) 00060000 * 1. REDUCE THE CASE TO THE 1ST OCTANT BY USING 00080000 * ATAN(-X)=-ATAN(X), ATAN(1/X)=PI/2-ATAN(X) 00100000 * 2. REDUCE FURTHER TO THE CASE /X/ LESS THAN TAN(PI/12) 00120000 * BY ATAN(X)=PI/6+ATAN((X*SQRT3-1)/(X+SQRT3)). 00140000 * 3. FOR THE BASIC RANGE (X LESS THAN TAN(PI/12)), USE 00160000 * A CONTINUED FRACTION APPROXIMATION 00180000 * 4. DATAN2 ENTRY REQUIRES A PAIR OF ARGUMENTS Y AND X, 00200000 * AND COMPUTES ATAN(Y/X). ANSWER IS IN (-PI,PI) 00220000 SPACE 00240000 EXTRN IBCOM# 00260000 EXTRN IHCERRM 00270016 ENTRY DATAN 00280000 ENTRY DATAN2 00300000 SPACE 00320000 GR0 EQU 0 SCRATCH REGISTERS 00340000 GR1 EQU 1 00360000 GR2 EQU 14 00380000 GRA EQU 1 ARGUMENT POINTER 00400000 GRS EQU 13 SAVE AREA POINTER 00420000 GRR EQU 14 RETURN REGISTER 00440000 GRL EQU 15 LINK REGISTER 00460000 FR0 EQU 0 ANSWER REGISTER 00480000 FR2 EQU 2 SCRATCH REGISTERS 00500000 FR4 EQU 4 00520000 FR6 EQU 6 00540000 SPACE 00560000 USING *,GRL 00570018 DATAN2 BC 15,LATN2 DATAN2 ENTRY POINT 00580018 DC AL1(6) 00590018 DC CL6'DATAN2' 00600018 SPACE 00610018 LATN2 STM GRR,GR0,12(GRS) SAVE REGISTERS 00620018 MVI XFLAG,X'80' PRESET XFLAG TO MINUS 00630018 BAL GRL,MERGE ADJUST BASE REGISTER AND MERGE 00640018 SPACE 00650018 USING *,GRL 00660018 DATAN BC 15,LATN DATAN ENTRY POINT 00670018 DC AL1(5) 00680018 DC CL5'DATAN' 00690018 SPACE 00700018 LATN STM GRR,GRL,12(GRS) SAVE REGISTERS 00710018 MVI XFLAG,X'00' PRESET XFLAG TO PLUS 00720018 SPACE 00730018 MERGE L GR2,0(GRA) BOTH ENTRIES JOIN HERE 00740018 LD FR0,0(GR2) OBTAIN 1ST (OR ONLY) ARGUMENT X1 00750018 L GR0,0(GR2) SAVE ITS SIGN 00760018 LPER FR0,FR0 FORCE SIGN POSITIVE 00770018 TM XFLAG,X'80' 00780018 BC 8,ATAN1 IF ATAN ENTRY, SKIP TO MAIN CIRCUIT 00790018 SPACE 00800018 L GR2,4(GRA) 00810018 LD FR6,0(GR2) OBTAIN 2ND ARGUMENT X2 00820018 LPDR FR2,FR6 FORCE SIGN POSITIVE 00830018 BC 8,VERTL IF X2=0, OR IF /X1/X2/ IS GREATER 00840018 STE FR0,XFLAG THAN 16**14, GIVE + OR -PI/2 AS 00850018 L GR2,XFLAG ANSWER TO AVOID IBFINT TROUBLE 00860018 STE FR2,XFLAG 00870018 S GR2,XFLAG 00880018 STE FR6,XFLAG SAVE SIGN OF X2 00890018 C GR2,LIM1 00900018 BC 2,VERTL1 00910018 LTER FR6,FR6 IF X2 GRT 0, GIVE NOISY UNDERFLOW 00920018 BC 10,NORML 00930018 C GR2,LIM2 00940018 BC 10,NORML 00950018 SDR FR0,FR0 IF X2 LST 0 AND /X1/X2/ LST 16**-14, 00960018 BC 15,XNEG GIVE + OR - PI AND AVOID UNDERFLOW 00970018 SPACE 00980018 VERTL LTER FR0,FR0 00990018 BC 8,ERROR IF X1=X2=0, ERROR 01000018 VERTL1 LD FR0,ONE IF X2=0 AND X1 NOT =0, OR /X1/X2/ 01010018 SD FR0,MPO2P1 GRT 16**6, GIVE + OR - PI/2 01020018 BC 15,STEST 01030018 SPACE 01040018 NORML DDR FR0,FR2 JOIN MAIN CIRCUIT WITH X=X1/X2 01050018 SPACE 01060018 ATAN1 LD FR4,ONE MAIN CIRCUIT 01070018 SR GR1,GR1 GR1, GR2 FOR DISTINGUISHING CASES 01080018 LA GR2,ZERO 01090018 CER FR0,FR4 01100018 BC 12,SKIP1 01110018 LDR FR2,FR4 IF X GREATER THAN 1, TAKE INVERSE 01120018 DDR FR2,FR0 AND INCREMEMENT GR1 BY 16 01130018 LDR FR0,FR2 01140018 LA GR1,16 01150018 SPACE 01160018 SKIP1 CE FR0,SMALL IF ARG LESS THAN 16**-7, ANS=ARG. 01170018 BC 12,READY THIS AVOIDS UNDERFLOW EXCEPTION 01180018 CE FR0,TAN15 01190018 BC 12,SKIP2 01200018 LDR FR2,FR0 IF X GREATER THAN TAN(PI/12), 01210018 MD FR0,RT3M1 REDUCE X TO (X*SQRT3-1)/(X+SQRT3) 01220018 SDR FR0,FR4 COMPUTE X*SQRT3-1 AS 01230018 ADR FR0,FR2 X*(SQRT3-1)-1+X 01240018 AD FR2,RT3 TO GAIN ACCURACY 01250018 DDR FR0,FR2 01260018 LA GR2,8(GR2) INCREMENT GR2 BY 8 01270018 SPACE 01280018 SKIP2 LDR FR6,FR0 COMPUTE ATAN OF REDUCED ARGUMENT BY 01290018 MDR FR0,FR0 ATAN(X) = X+X*X**2*F, WHERE 01300018 LD FR4,C7 F = C1+C2/(X**2+C3+C4/ 01310018 ADR FR4,FR0 (X**2+C5+C6/(X**2+C7))) 01320018 LD FR2,C6 01330018 DDR FR2,FR4 01340018 AD FR2,C5 01350018 ADR FR2,FR0 01360018 LD FR4,C4 01370018 DDR FR4,FR2 01380018 AD FR4,C3 01390018 ADR FR4,FR0 01400018 LD FR2,C2 01410018 DDR FR2,FR4 01420018 AD FR2,C1 01430018 MDR FR0,FR2 01440018 MDR FR0,FR6 01450018 ADR FR0,FR6 01460018 SPACE 01470018 READY AD FR0,0(GR1,GR2) DEPENDING ON THE CASE, 01480018 LNR GR1,GR1 EITHER ADD 0 OR PI/6, OR 01490018 SD FR0,ZERO(GR1) SUBTRACT FROM PI/3 OR PI/2 01500018 LPER FR0,FR0 DO THE LATTER IN TWO STEPS 01510018 TM XFLAG,X'80' 01520018 BC 8,STEST IF DATAN2 ENTRY AND X2 IS NEGATIVE 01530018 XNEG SD FR0,PI SUBTRACT FR0 FROM PI 01540018 LPER FR0,FR0 01550018 SPACE 01560018 STEST LTR GR0,GR0 SIGN OF ANS SHOULD AGREE 01570018 BC 10,*+6 WITH SIGN OF ARG 01580018 LCER FR0,FR0 01590018 SPACE 01600018 EXIT L GRR,12(GRS) 01610018 MVI 12(GRS),X'FF' RETURN 01620018 BCR 15,GRR 01630018 SPACE 02680000 SPACE 02720000 ERROR STD FR0,DATA1 02724016 STD FR6,DATA2 02726018 ST GRA,24(GRS) SAVE REG 1 FOR TRACEBACK 02728018 LR GRR,GRL SAVE ADDRE 02732016 LR GR1,GRS 02736016 L GRL,ACOM 02740016 LA GRS,OFFSET(GRL) SAVEAREA IN IBCOM 02744016 ST GR1,4(GRS) 02748016 ST GRS,8(GR1) LINK SAVE AREAS 02752016 DROP 15 02756016 USING DATAN,14 02760016 LR 0,GRR SAVE ADDRESSABILITY 02764016 L 15,AERRMON 02768016 LA 1,ERRLIST 02772016 BALR 14,15 02776016 LR GRL,0 RESTORE ADDRESSABILITY 02780016 DROP 14 02784016 USING DATAN,15 02788016 L GRS,4(GRS) RESTORE SAVE AREA ADDR 02792016 CLI RETCODE+3,X'00' DID USER FIX DATA 02796016 BZ EXIT NO-STANDARD FIXUP = 0.0 02800016 LA GR1,ERRLIST+12 POINT TO NEW DATA LIST 02804016 B MERGE START AGAIN 02808016 EJECT 02810018 DS 0D 02812018 C1 DC X'BF1E31FF1784B965' -0.7371899082768562E-2 02814018 C2 DC X'C0ACDB34C0D1B35D' -0.6752198191404210 02816018 C3 DC X'412B7CE45AF5C165' 0.2717991214096480E+1 02818018 C4 DC X'C11A8F923B178C78' -0.1660051565960002E+1 02820018 C5 DC X'412AB4FD5D433FF6' 0.2669186939532663E+1 02822018 C6 DC X'C02298BB68CFD869' -0.1351430064094942 02824018 C7 DC X'41154CEE8B70CA99' 0.1331282181443987E+1 02826018 PI DC X'413243F6A8885A31' 02828018 RT3M1 DC X'40BB67AE8584CAA8' SQRT(3)-1 02830018 ONE DC X'4110000000000000' THESE 02832018 RT3 DC X'411BB67AE8584CAB' SQRT(3) SIX 02834018 ZERO DC D'0' 0 CONSTANTS 02836018 DC X'40860A91C16B9B2C' PI/6 MUST 02838018 MPO2P1 DC X'C0921FB54442D184' -PI/2+1 BE 02840018 DC X'BFC152382D736574' -(PI/3-F)+1 CONSECUTIVE 02842018 DATA1 DS D FOR DATA IN ERROR 02844018 DATA2 DS D 02855016 AERRMON DC V(IHCERRM) 02915018 LIM1 DC X'0E000000' 02975018 LIM2 DC X'F2000000' 03035018 SMALL DC X'3A100000' 03095018 XFLAG DS F 03155018 TAN15 DC X'40449851' 03215018 ACOM DC A(IBCOM#) 03340000 OFFSET EQU X'C4' 03341016 ERRLIST DC A(MSGLNG) 03342016 DC A(RETCODE) 03343016 DC A(ERRNUM) 03344016 DC A(DATA1) 03345016 DC X'80' 03346016 DC AL3(DATA2) 03347016 ERRNUM DC F'265' 03348016 RETCODE DS F 03349016 MSGLNG DC A(ENDMSG-MSG) 03350016 MSG DC C'IHC265I DATAN2 ARGUMENTS=0.0' 03351016 ENDMSG EQU * 03352016 FLAG DS C 03353016 END 03360000 ./ ADD SSI=01013621,NAME=IHCLERF,SOURCE=0 TITLE ' ERF ERROR FUNCTION (LONG) ' 00500018 IHCLERF CSECT 01000018 * 1. ERF(X) = (2/SQRTPI)*(INTEGRAL FROM 0 TO X OF E**(-U*U)*DU) 01500018 * 2. ERFC(X) = 1-ERF(X) THESE ARE FOR DEFINITION ONLY 02000018 SPACE 02500018 ENTRY DERF 03000018 ENTRY DERFC 03500018 EXTRN DEXP 04000018 SPACE 04500018 GRA EQU 1 ARGUMENT LIST POINTER 05000018 GR2 EQU 2 ARGUMENT ADDRESS 05500018 GR3 EQU 3 INDEX REGISTERS 06000018 GR4 EQU 4 06500018 GR5 EQU 5 07000018 GRS EQU 13 SAVE AREA POINTER 07500018 GRR EQU 14 RETURN REGISTER 08000018 GRL EQU 15 LINK REGISTER - BASE REGISTER 08500018 FR0 EQU 0 ANSWER REGISTER 09000018 FR2 EQU 2 SCRATCH REGISTER 09500018 FR4 EQU 4 10000018 FR6 EQU 6 10500018 ISN EQU X'108' IDENTIFIER CODE FOR DEXP CALL 11000018 SPACE 11500018 USING *,GRL 12000018 DERFC BC 15,LERFC 12500018 DC AL1(5) 13000018 DC CL5'DERFC' 13500018 LERFC STM GRR,GR5,12(GRS) SAVE REGISTERS, SET TEST TO 14000018 MVI TEST+1,X'00' NO BRANCH ADJUST BASE REGISTER 14500018 BAL GRL,MERGE AND MERGE WITH THE OTHER ENTRY 15000018 SPACE 15500018 USING *,GRL 16000018 DERF BC 15,LERF 16500018 DC AL1(4) 17000018 DC CL4'DERF' 17500018 LERF STM GRR,GR5,12(GRS) SAVE REGISTERS, SET TEST TO 18000018 MVI TEST+1,X'F0' UNCONDITIONAL BRANCH 18500018 SPACE 19000018 MERGE L GR2,0(GRA) SAVE ARGUMENT ADDRESS IN GR2 19500018 LD FR2,0(GR2) OBTAIN ARG IN FR2 20000018 LPDR FR4,FR2 /ARG/ IN FR4 20500018 LM GR3,GR5,INDEX PRESET INDEX FOR SECT3 ... 0,8,48 21000018 CE FR4,LIM2 JUMP TO LARGE IF /ARG/ IS GRT THAN 2.0404 21500018 BC 10,LARGE 22000018 CE FR4,LIM1 JUMP TO SECT2 IF /ARG/ IS IN (1,2.0404) 22500018 BC 10,SECT2 23000018 SPACE 23500018 SECT1 LD FR0,KA0M1 CASE WHEN /ARG/ IS LESS THAN 1 24000018 CE FR4,LIM0 IF /ARG/ IS LESS THAN 16**-7, GIVE 24500018 BC 4,XPRES A0*/X/ AS THE ANSWER. THIS AVOIDS 25000018 MDR FR2,FR2 INTERMEDIATE INDERFLOW 25500018 LA GR5,32(GR5) OTHERWISE SET INDEX TO 0,8,80, AND 26000018 LD FR0,KA COMPUTE ERF(/X/) AS FOLLOWS 26500018 LOOP1 MDR FR0,FR2 27000018 AD FR0,KA+8(GR3) /X/*(A0+A1*XSQ+A2*X**4+..+A11*X**22) 27500018 BXLE GR3,GR4,LOOP1 28000018 XPRES MDR FR0,FR4 COMBINE A0 IN 2 STEPS 28500018 ADR FR0,FR4 TO MINIMIZE ROUND-OFF ERRORS 29000018 TM TEST+1,X'80' IF ERF(X) WANTED, JUMP TO TRUE 29500018 BC 1,TRUE IF ERFC(X) WANTED, TAKE COMPLEMENT 30000018 SPACE 30500018 COMPL SD FR0,ONE COMPLEMENTATION 31000018 LPER FR0,FR0 31500018 SPACE 32000018 TRUE TM 0(GR2),X'80' NOW ANSWER FOR /ARG/ IS READY 32500018 BC 8,FIN IF POSITIVE ARG, SKIP TO EXIT 33000018 TM TEST+1,X'80' IF NEGATIVE ARG, AND 33500018 BC 1,*+8 IF ERFC WANTED, SUBTRACT FROM 2 34000018 COMPL2 SD FR0,TWO IF ERF WANTED, JUST CHANGE SIGN 34500018 LCER FR0,FR0 35000018 SPACE 35500018 FIN LM GRR,GR5,12(GRS) RESTORE REGISTERS (INCLUDING GRR) 36000018 MVI 12(GRS),X'FF' AND RETURN 36500018 BCR 15,GRR 37000018 SPACE 37500018 SECT2 LA GR5,88(GR5) CASE WHEN /ARG/ IS IN (1.0,2.040452) 38000018 SD FR4,OSHFT COMPUTE ERFC(1.709472+Z) WHERE 38500018 LD FR0,KB Z=/X/-1.709472 BY A MINIMAX 39000018 LOOP2 MDR FR0,FR4 POLYNOMIAL OF DEGREE 18 IN Z 39500018 AD FR0,KB+8(GR3) IN THIS RANGE, ERFC(/X/) IS BETWEEN 40000018 BXLE GR3,GR4,LOOP2 1/256 AND 0.1573 40500018 SPACE 41000018 TEST BC 0,COMPL SWITCH FOR /X/ GRT THAN 1.0 41500018 BC 15,TRUE IF ERF, COMPLEMENT, IF ERFC, LEAVE IT 42000018 SPACE 42500018 LARGE CE FR4,LIM3 CASE WHEN /X/ GRT THAN 2.040452 43000018 BC 4,SECT3 IF /X/ IN (2.04,6.092), JUMP TO SECT3 43500018 LE FR0,BOMB PRELOAD BOMB. 1-BOMB=1, BOMB**2=UNDFLO 44000018 TM TEST+1,X'80' IF ERF ENTRY AND /X/ GRT THAN 6.092, 44500018 BC 1,COMPL TAKE 1.0 AS ERF(/X/) QUIETLY 45000018 TM 0(GR2),X'80' IF ERFC ENTRY AND X LESS THAN -6.092, 45500018 BC 1,COMPL2 TAKE 2.0 AS ERFC(X) QUIETLY 46000018 CE FR4,LIM4 IF ERFC ENTRY AND X BETWEEN 6.092 AND 46500018 BC 4,SECT3 13.306, GO TO SECT3 47000018 MDR FR0,FR0 IF ERFC ENTRY AND X GRT THAN 13.306 47500018 BC 15,FIN GIVE 0 AS ANSWER WITH UNDERFLOW NOISE 48000018 SPACE 48500018 SECT3 MDR FR2,FR2 CASE WHEN /X/ IS GREATER THAN 2.040452 49000018 LD FR6,KC AND THE RESULT IS NON-DEGENERATING 49500018 LOOP3 ADR FR6,FR2 50000018 LDR FR0,FR6 COMPUTE ERFC(/X/) AS FOLLOWS 50500018 LD FR6,KD(GR3) 51000018 DDR FR6,FR0 (E**-XSQ)*F(XSQ)/(/X/) WHERE 51500018 AD FR6,KC+8(GR3) 52000018 BXLE GR3,GR4,LOOP3 F=C0+D1/(XSQ+C1+D2/(XSQ+C2+D3/... 52500018 DDR FR6,FR4 ...+D7/(XSQ+C7))))))) 53000018 SPACE 53500018 LNER FR2,FR2 LEAVE F(XSQ)/(/X/) IN FR6 54000018 STD FR2,NEGSQ WHICH IS UNAFFECTED BY DEXP CALL 54500018 LA GRA,ADSQ 55000018 LR GR4,GRS SWITCH SAVE AREA POINTERS 55500018 LA GRS,AREA 56000018 ST GRS,8(GR4) 56500018 ST GR4,AREA+4 57000018 LR GR3,GRL SAVE BASE REGISTER 57500018 L GRL,ADEXP 58000018 BALR GRR,GRL OBTAIN E**(-XSQ) BY CALLING DEXP 58500018 BC 0,ISN 59000018 LR GRL,GR3 RESTORE BASE REGISTER 59500018 LR GRS,GR4 RESTORE SAVE AREA POINTER 60000018 MDR FR0,FR6 COMBINE FACTORS TO OBTAIN ERFC(/X/) 60500018 BC 15,TEST AND JUMP TO TEST 61000018 SPACE 61500018 NEGSQ DS D 62000018 KA DC X'B93575CB03288888' -0.0000000007779473 = A11 62500018 DC X'3A3AE362DA85FB5B' 0.0000000137109838 = A10 63000018 DC X'BB2B80E5106F2933' -0.0000001620631488 = A9 63500018 DC X'3C1B97FD43205DA9' 0.0000016447131768 = A8 64000018 DC X'BCFA6526BD76ED33' -0.0000149247123228 = A7 64500018 DC X'3D7E68AEAA7DF3C6' 0.0001205529357828 = A6 65000018 DC X'BE3805B607BC8808' -0.0008548325929373 = A5 65500018 DC X'3F1565BCCF92B9D6' 0.0052239776061200 = A4 66000018 DC X'BF6E0B38C47EA601' -0.0268661706431117 = A3 66500018 DC X'401CE2F21A040D17' 0.1128371967094419 = A2 67000018 DC X'C06049D1AC0DE6F5' -0.3761263890318352 = A1 +2F ABS 67500018 KA0M1 DC X'4020DD750429B6D2' 0.128379167095513 = A0-1.0 +1F 68000018 OSHFT DC X'411B5A0000000000' 1.709472 ORIGIN FOR SECT2 68500018 KB DC X'3B167F03888C890D' 0.0000000838046807 = B18 69000018 DC X'3B9FD941F87D786C' 0.0000005954826731 = B17 69500018 DC X'3AC808E74EBC9B87' 0.0000000465742265 = B16 70000018 DC X'BC37F7ABFD191862' -0.0000033359210544 = B15 70500018 DC X'3C6E75AECE8102D4' 0.0000065839110963 = B14 71000018 DC X'3CF38568C997EC42' 0.0000145149904597 = B13 71500018 DC X'BD50F5F506D2E9A0' -0.0000772102070427 = B12 72000018 DC X'3D2AFBA45E9EA010' 0.0000409917610466 = B11 72500018 DC X'3E1C591036E309F0' 0.0004325546823446 = B10 73000018 DC X'BE4642A0283F3525' -0.0010720864304375 = B9 73500018 DC X'BE1855E9E68608D0' -0.0003713317915058 = B8 74000018 DC X'3F198E1E4DA67774' 0.0062390502665986 = B7 74500018 DC X'BF2BDE716F1D2638' -0.0107101851479655 = B6 75000018 DC X'BF11572275A37AED' -0.0042334886622643 = B5 75500018 DC X'3FC98FE2BB6FE2CA' 0.0492094856954216 = B4 +100F 76000018 DC X'C01919E57C233961' -0.0980513980932520 = B3 76500018 DC X'401A925CDF5B78DA' 0.1037958188348712 = B2 +1F 77000018 DC X'BFF8B37923BCC168' -0.0607180339828094 = B1 +8F ABS 77500018 DC X'3F3FFFFB678ECA0C' 0.0156249828805124 = B0 +1F 78000018 KC DC X'41138FECB70009CB' 1.222637858242353 = C7 78500018 DC X'413E5E34C316AA85' 3.897999536575896 = C6 79000018 DC X'4170C114C5AD499D' 7.047138950515183 = C5 79500018 DC X'4174A6EBF5930F54' 7.290752372050481 = C4 80000018 DC X'4157F3CD556493C7' 5.497021993223130 = C3 80500018 DC X'4137FFFA4C4FE189' 3.499994562238586 = C2 81000018 DC X'4117FFFFFFD414E3' 1.499999999360903 = C1 81500018 DC X'40906EBA8214DB0E' 0.5641895835477550 = C0 82000018 KD DC X'C114FC5D7B70143C' -1.311612589053097 = D7 82500018 DC X'C17B2C0FAAD4F477' -7.698257129012999 = D6 83000018 DC X'C1E847FA259245A1' -14.51757254291838 = D5 83500018 DC X'C1A67578C4A4803C' -10.40367962659367 = D4 84000018 DC X'C14FFE9B53FB1274' -4.999659851121717 = D3 84500018 DC X'C117FFFFE7BADE7F' -1.499999909587046 = D2 85000018 DC X'C048375D4109A0B4' -0.2820947917731498 = D1 85500018 ONE DC X'4110000000000000' 1.0 86000018 TWO DC X'41200000' 2.0 THESE 4 WORDS 86500018 INDEX DC X'00000000' MUST BE CONSECUTIVE 87000018 DC F'8' STARTING AT A DOUBLE 87500018 DC F'48' WORD BOUNDARY 88000018 LIM0 DC X'3A100000' 16**-7 88500018 LIM1 EQU ONE 1.0 89000018 LIM2 DC X'4120A5B1' 2.040452 89500018 LIM3 DC X'41617A56' 6.092368 90000018 LIM4 DC X'41D4E560' 13.306 90500018 BOMB EQU KA+4 1-BOBM=1, BOMB**2=UNDERFLOW 91000018 AREA DS 7F 91500018 ADSQ DC X'80' 92000018 DC AL3(NEGSQ) 92500018 ADEXP DC A(DEXP) 93000018 END 93500018 ./ ADD SSI=02013623,NAME=IHCLEXP,SOURCE=0 LEXP TITLE 'EXPONENTIAL FUNCTION (LONG)' 00010018 IHCLEXP CSECT 00020018 * 00030018 * EXPONENTIAL FUNCTION (LONG) 00040018 * 1. WRITE X = (4A-B-C/16)*LOGE(2)+R, WHERE A,B, AND 00050018 * C ARE INTEGERS, B BETWEEN 0 AND 3, C BETWEEN 0 00060018 * AND 15. R IS A FRACTION BETWEEN -1/16 AND 0. 00070018 * 2. THEN E**X = 2**Y = (16**A)(2**-B)(2**-C/16)(E**R). 00080018 SPACE 00090018 EXTRN IBCOM# 00100018 EXTRN IHCERRM 00110018 ENTRY DEXP 00120018 SPACE 00130018 GRA EQU 1 ARGUMENT POINTER 00140018 GRS EQU 13 SAVE AREA POINTER 00150018 GRR EQU 14 RETURN REGISTER 00160018 GRL EQU 15 LINK REGISTER 00170018 GR0 EQU 0 SCRATCH REGISTERS 00180018 GR1 EQU 1 00190018 GR2 EQU 14 00200018 * REGISTERS 2 AND 3 ARE SAVED AND USED IN 'ERROR' 00210018 REG2 EQU 2 00220018 REG3 EQU 3 00230018 FR0 EQU 0 ANSWER REGISTER 00240018 FR2 EQU 2 SCRATCH REGISTER 00250018 SPACE 00260018 USING *,GRL 00270018 DEXP BC 15,LEXP 00280018 DC AL1(4) 00290018 DC CL5'DEXP' 00300018 SPACE 00310018 LEXP STM GRR,GRL,12(GRS) SAVE REGISTERS 00320018 L GR2,0(GRA) 00330018 BEGIN LD FR0,0(GR2) OBTAIN ARGUMENT 00340018 CE FR0,MAX MAX = 63*LOG16 = 174.67309 00350018 BC 2,ERROR IF ARG GREATER THAN THIS, ERROR 00360018 CE FR0,MIN MIN = -65*LOG16 = -180.21867 00370018 BC 12,SMALL IF ARG LESS THAN THIS, GIVE UNDERFLOW 00380018 SPACE 00390018 LER FR2,FR0 DECOMPOSE X = P*LOG2+R, 00400018 DE FR2,LOG2H P MULTIPLE OF 1/16, ACCURATELY 00410018 AU FR2,SCALER FIRST (UNDER)ESTIMATE P BY 00420018 STE FR2,FIELDS DIVIDING HIGH PART X BY LOG2H 00430018 ME FR2,LOG2H 00440018 SDR FR0,FR2 LOG(2) = LOG2H+LOG2L, 00450018 LD FR2,FIELDS WHERE LOG2H IS ROUNDED UP. 00460018 MD FR2,LOG2L TOTAL PRECISION 80 BITS 00470018 SDR FR0,FR2 X = P'*LOG2+R', /R'/ MAY BE 00480018 L GR0,FIELDS SLIGHTLY OVER (LOG2)/16 00490018 BC 12,ZMINUS 00500018 SPACE 00510018 LCR GR0,GR0 CASE WHEN X AND R' ARE POSITIVE 00520018 PLUS BCTR GR0,0 CHANGE SIGN OF P AND SUBTRACT 00530018 AD FR0,ML216 (LOG2)/16 UNTIL R BECOMES NEGATIVE, 00540018 BC 2,PLUS EACH TIME SUBTRACT 1 FROM -P 00550018 BC 15,READY 00560018 SPACE 00570018 ZMINUS CD FR0,ML216 CASE WHEN X AND R' 0 OR NEGATIVE 00580018 BC 2,READY IF R' SMALLER THAN -(LOG2)/16, 00590018 SD FR0,ML216 ADD (LOG2)/16, AND INCREMENT 00600018 SH GR0,INCR GR0 WHOSE LOW PART IS -P 00610018 SPACE 00620018 READY SR GR1,GR1 GR1 = -P = -4A+B+C/16 00630018 SRDL GR0,4 C IN HIGH GR1 00640018 SRL GR1,25 00650018 SRDL GR0,2 B IN HIGH GR1, C IN LOW GR1 00660018 SLL GR0,24 00670018 LCR GR2,GR0 A (IN SCALE B7) IN GR2, CHAR MODIFIER 00680018 SR GR0,GR0 00690018 SLDL GR0,2 B IN GR0, 8*C IN GR1 00700018 SPACE 00710018 CE FR0,NEAR0 IF /R/ IS LESS THAN 2**-60, AVOID 00720018 BC 2,SKIP1 UNDERFLOW BY TAKING E**R = 1 00730018 LDR FR2,FR0 COMPUTE E**R FOR R BETWEEN 00740018 ME FR0,C6 -(LOG2)/16 AND 0 BY MINIMAX 00750018 AD FR0,C5 POLYNOMIAL APPROX OF DEGREE 6 00760018 MDR FR0,FR2 00770018 AD FR0,C4 00780018 MDR FR0,FR2 00790018 AD FR0,C3 00800018 MDR FR0,FR2 00810018 AD FR0,C2 00820018 MDR FR0,FR2 00830018 AD FR0,C1 00840018 MDR FR0,FR2 E**R-1 READY 00850018 MD FR0,MCONST(GR1) 00860018 SPACE 00870018 SKIP1 AD FR0,MCONST(GR1) (E**R)*2**(-C/16) READY 00880018 SPACE 00890018 LTR GR0,GR0 MULTIPLY BY 2**(-B) 00900018 BC 8,SKIP2 BY HALVING B TIMES 00910018 HDR FR0,FR0 00920018 BCT GR0,*-2 00930018 SPACE 00940018 SKIP2 STE FR0,FIELDS ADD A TO CHARACTERISTIC 00950018 A GR2,FIELDS 00960018 ST GR2,FIELDS 00970018 LE FR0,FIELDS 00980018 SPACE 00990018 EXIT L GRR,12(GRS) 01000018 MVI 12(GRS),X'FF' 01010018 BCR 15,GRR RETURN 01020018 SPACE 01030018 SMALL LE FR0,BOMB LOAD BOMB 01040018 MDR FR0,FR0 AND GO OUT WITH A BANG! 01050018 BC 15,EXIT 01060018 SPACE 01960000 ERROR STD FR0,DATA ARG GT 174.673 01963016 STM 0,1,20(GRS) SAVE REG 0,1 FOR TRACEBACK 01967018 LR GRR,GRL SAVE ADDRESSABILITY 01972016 DROP 15 01975016 USING DEXP,GRR 01978016 L GRL,ACOM 01981016 LR GR1,GRS GET ADDRESS OF IBCOM 01981318 LA GRS,OFFSET(GRL) COMMON SAVE AREA 01981618 ST GR1,4(GRS) AND LINKWITH CALLERS 01981918 ST GRS,8(GR1) 01982218 STM REG2,REG3,12(GRS) SAVE 2,3 IN IBCOM AREA FOR 01982518 LA REG2,DATA CONVERSION 01982818 LA REG3,MSGDATA 01983118 EX 0,86(GRL) FCVDO 01984016 BALR 0,1 01987016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 01990016 LM REG2,REG3,12(GRS) RESTORE 2,3 02000018 LA 1,ERRLIST PARM FOR ERMON 02014016 L GRL,AERRMON 02017016 BALR GRR,GRL TO ERMON 02020016 L GRS,4(GRS) RESTORE SAVE AREA POINTER 02023018 L GRL,16(GRS) RESTORE ADDRESSABILITY 02026018 DROP GRR 02029018 USING DEXP,GRL 02032018 LA GR2,DATA POINT TO NEW DATA 02035018 CLI RETCODE+3,X'00' DID USER FIX DATA 02041016 BNZ BEGIN YES-START AGAIN 02044016 LD FR0,INFINY STANDARD FIXUP-INFINITY 02047016 B EXIT 02050016 SPACE 02060000 ACOM DC A(IBCOM#) 02080000 LOG2H DC X'40B17218' LOG(2) ROUNDED UP 02090018 MAX DC X'42AEAC4E' 174.6731 02100018 MIN DC X'C2B437DF' -180.2187 02110018 FIELDS DC D'0' 02120018 DATA DS D 02130018 INFINY DC X'7FFFFFFFFFFFFFFF' STANDARD FIXUP 02170016 NEAR0 DC X'B2100000' -2**60 02180018 C6 DC X'3E591893' 0.13594970E-2 02190018 C5 DC X'3F2220559A15E158' 0.8331617720039062E-2 02200018 C4 DC X'3FAAAA9D6AC1D734' 0.4166661730788750E-1 02210018 C3 DC X'402AAAAAA794AA99' 0.1666666659481656 02220018 C2 DC X'407FFFFFFFFAB64A' 0.4999999999951906 02230018 C1 DC X'40FFFFFFFFFFFCFC' 0.9999999999999892 02240018 LOG2L DC X'B982E308654361C4' LOG(2)-LOG2H TO 80 BITS 02250018 MCONST DC X'4110000000000000' 2**(-0/16) 02260018 DC X'40F5257D152486CD' 2**(-1/16) +F 02270018 DC X'40EAC0C6E7DD243A' 2**(-2/16) +F 02280018 DC X'40E0CCDEEC2A94E1' 2**(-3/16) 02290018 DC X'40D744FCCAD69D6B' 2**(-4/16) 02300018 DC X'40CE248C151F8481' 2**(-5/16) 02310018 DC X'40C5672A115506DB' 2**(-6/16) 02320018 DC X'40BD08A39F580C37' 2**(-7/16) 02330018 DC X'40B504F333F9DE65' 2**(-8/16) 02340018 DC X'40AD583EEA42A14B' 2**(-9/16) 02350018 DC X'40A5FED6A9B15139' 2**(-10/16) 02360018 DC X'409EF5326091A112' 2**(-11/16) 02370018 DC X'409837F0518DB8AA' 2**(-12/16)+F 02380018 DC X'4091C3D373AB11C4' 2**(-13/16)+F 02390018 DC X'408B95C1E3EA8BD7' 2**(-14/16) 02400018 DC X'4085AAC367CC487C' 2**(-15/16)+F 02410018 ML216 DC X'BFB17217F7D1CF7A' -LOG(2)/16 ROUNDED UP 02420018 SCALER DC X'45000000' 02430018 BOMB EQU C5+4 02440018 INCR EQU C1+2 02450018 AERRMON DC V(IHCERRM) 02681016 OFFSET EQU X'C4' 02683016 ERRNUM DC F'262' 02684016 ERRLIST DC A(MSGLNG) 02685016 DC A(RETCODE) 02686016 DC A(ERRNUM) 02687016 DC X'80' 02688016 DC AL3(DATA) 02689016 RETCODE DS F 02690016 EJECT 02691016 MSGLNG DC A(ENDMSG-MSG) 02692016 MSG DC C'IHC262I DEXP ARG=' 02693016 MSGDATA DS 23C 02694016 DC C', GT 174.673' 02695016 ENDMSG EQU * 02696016 END 02700000 ./ ADD SSI=01013623,NAME=IHCLGAMA,SOURCE=0 TITLE ' GAMA GAMMA-LOGGAMMA (LONG) ' 00010018 IHCLGAMA CSECT 00020000 * LONG FORM GAMMA-LOGGAMMA FUNCTIONS 00040000 * 1. GAMMA(X) = INTEGRAL FROM 0 TO +NF OF T**(Z-1)*E**(-T)*DT 00060000 * X MUST LIE BETWEEN 2**(-252) AND 57.5744 00080000 * 2. LOGGAMMA(X) = LOG(GAMMA(X)) 00100000 * X MUST BE POSITIVE AND BE LESS THAN 4.2937*10**73 00120000 SPACE 00140000 ENTRY DGAMMA 00160000 ENTRY DLGAMA 00180000 EXTRN DEXP 00200000 EXTRN DLOG 00220000 EXTRN IBCOM# 00240000 EXTRN IHCERRM 00250016 SPACE 00260000 GR0 EQU 0 DUMMY REGISTER, MAY BE CLOBBERED 00280000 GRA EQU 1 ARGUMENT LIST POINTER 00300000 GR2 EQU 2 MAIN BASE REGISTER 00320000 GR3 EQU 3 INDEX REGISTERS 00340000 GR4 EQU 4 00360000 GR5 EQU 5 00380000 GRS EQU 13 SAVE AREA POINTER 00400000 GRR EQU 14 RETURN REGISTER 00420000 GRL EQU 15 LINK REGISTER 00440000 FR0 EQU 0 ANSWER REGISTER 00460000 FR2 EQU 2 SCRATCH REGISTERS 00480000 FR4 EQU 4 00500000 FR6 EQU 6 00520000 ISN1 EQU X'10A' IDENTIFIER CODE FOR 1ST DLOG CALL 00540000 ISN2 EQU X'10C' IDENTIFIER CODE FOR 2ND DLOG CALL 00560000 ISN3 EQU X'10E' IDENTIFIER CODE FOR 3RD DLOG CALL 00580000 ISN4 EQU X'110' IDENTIFIER CODE FOR DEXP CALL 00600000 SPACE 00620000 USING *,15 00640000 DLGAMA B 12(0,15) 00660000 DC AL1(6) 00680000 DC CL6'DLGAMA' 00700000 STM GRR,GR5,12(GRS) SAVE REGISTERS 00720000 MVI TEST+1,X'00' SET SWITCH TO NO BRANCH 00740000 LA GRL,DGAMMA-DLGAMA(GRL) ADJUST BASE REGISTER AND 00760000 USING DGAMMA,GRL 00780000 BC 15,MERGE 00800000 DGAMMA B 10(0,15) 00820000 DC AL1(5) 00840000 DC CL5'DGAMMA' 00860000 STM GRR,GR5,12(GRS) SAVE REGISTERS 00880000 MVI TEST+1,X'F0' SET SWITCH TO UNCOND. BRANCH 00900000 SPACE 00920000 MERGE LR GR2,GRL SWITCH BASE REGISTER TO GR2 00940000 DROP GRL 00960000 USING DGAMMA,GR2 00980000 LR GR5,GRS SWITCH SAVE AREA POINTERS 01000000 LA GRS,AREA 01020000 ST GRS,8(GR5) 01040000 ST GR5,4(GRS) 01060000 BEGIN L GR3,0(GRA) 01066018 LD FR2,0(GR3) OBTAIN ARGUMENT 01072018 L GRL,ADLOG SET GRL READY FOR DLOG CALL 01080000 CE FR2,MIN TEST THE SIZE OF ARGUMENT 01140000 BC 2,OK1 01160018 TM TEST+1,X'80' CASE WHEN ARG IS LESS OR EQ 2**(-252) 01180000 BC 1,ERROR1 IF GAMMA ENTRY, GIVE ERROR 01200000 LTER FR2,FR2 01220000 BC 12,ERROR2 IF ARG 0 OR NEGATIVE, GIVE ERROR 01240000 BALR GRR,GRL OTHERWISE, LOGGAMMA(X) = -LOG(X) 01260000 BC 0,ISN1 01280000 LCER FR0,FR0 01300000 BC 15,FIN SKIP TO EXIT 01320000 SPACE 01340000 OK1 CE FR2,MAX1 ARG IS GREATER THAN 2**(-252) 01360018 BC 12,OK2 01380018 TM TEST+1,X'80' IF GAMMA ENTRY AND IF ARG IS 01400000 BC 1,ERROR1 GREATER THAN 57.5744, GIVE ERROR 01420000 CE FR2,MAX2 IF LOGGAMMA WANTED, AND IF ARG IS 01440000 BC 2,ERROR2 GREATER THAN 4.2937*10**73, GIVE ERROR 01460000 SPACE 01480000 OK2 EQU * ARGUMENT IN RANGE, JUMP TO 01490018 CE FR2,EIGHT SECTION 1 IF ARG IS IN (2**-252,1) 01500018 BC 10,SECT4 SECTION 2 IF ARG IS IN (1,2) 01510018 CE FR2,ONE SECTION 3 IF ARG IS IN (2,8) 01520018 BC 4,SECT1 SECTION 4 IF ARG IS GREATER THAN 8 01530018 MVI MRDDR,X'2C' FOR SECTION 2 AND 3, SET MRDDR TO 01540018 LD FR4,ONE 'MDR FR0,FR4' FR4=1.0 FOR SECTION 2 01550018 SPACE 01560018 SECT3 CE FR2,TWO IF ARG IS IN (2,8), REDUCE ARG BY 1.0 01570018 BC 12,SECT2 AT A TIME, BUILD FACTOR (X-1)*(X-2)* 01580018 SD FR2,ONE ...*(X-N) TILL ARG IS REDUCED TO 01590018 MDR FR4,FR2 (1,2) 01600018 BC 15,SECT3 01610018 SPACE 01620018 SECT1 MVI MRDDR,X'2D' IF ARG IS IN (2**-252,1) 01630018 LDR FR4,FR2 EFFECTIVELY RAISE ARG BY 1, SUBTRACTING 01640018 SD FR2,HALF 0.5 INSTEAD OF 1.5. SET MRDDR TO 01650018 BC 15,MINMAX 'DDR FR0,FR4 01660018 SPACE 01670018 SECT2 SD FR2,ONHLF NOW ARG IS IN (1,2). SUBTRACT 1.5 01680018 MINMAX LD FR0,A6 COMPUTE GAMMA(1.5+Z) WHERE Z=X-1.5 01690018 MDR FR0,FR2 BY MEANS OF MINIMAX FRACTION OF DEGREE 01700018 LD FR6,B6 (7,7) FOR Z IN (-0.5,0.5) 01710018 ADR FR6,FR2 01720018 LM GR3,GR5,INDEX Z(A0+A1*Z+A2*Z**2+...+A6*Z**6) 01730018 LOOP AD FR0,A5(GR3) C0 + ------------------------------- 01740018 MDR FR0,FR2 B0+B1*Z+B2*Z**2+...+B6*Z**6+Z**7 01750018 MDR FR6,FR2 01760018 AD FR6,B5(GR3) 01770018 BXLE GR3,GR4,LOOP 01780018 DDR FR0,FR6 01790018 AD FR0,C0 01800018 SPACE 01810018 MRDDR MDR FR0,FR4 'MDR FR0,FR4' OR 'DDR FR0,FR4' 01820018 SPACE 01830018 TEST BC 15,FIN 'BC 15' IF GAMMA, 'BC 0' IF LOGGAMMA 01840018 STD FR0,BUFF IF LOGGAMMA WANTED, GO TO DLOG 01850018 LA GRA,ABUFF TO OBTAIN LOG OF THE RESULT 01860018 BALR GRR,GRL 01870018 BC 0,ISN2 01880018 SPACE 01890018 FIN L GRS,AREA+4 RETURN TO CALLING PROGRAM 01900018 LM GRR,GR5,12(GRS) 01910018 MVI 12(GRS),X'FF' 01920018 BCR 15,GRR 01930018 SPACE 01940018 SECT4 SDR FR6,FR6 CASE WHEN ARG IS GREATER THAN 8 01950018 CE FR2,LMBIG 01960018 BC 2,BIG LOGGAMMA(X) = X*(LOG(X)-1)-(LOG(X))/2 01970018 LD FR0,ONE +LOG(2PI)/2+G(1/X) 01980018 DDR FR0,FR2 01990018 LDR FR4,FR0 HERE G(1/X) = DO/X+D1/X**3+D2/X**5 02000018 MDR FR4,FR4 +D3/X**7+D4/X**9 02010018 LE FR6,D4 02020018 MER FR6,FR4 IF X GREATER THAN 2**25, SET G(1/X) 02030018 AE FR6,D3 TO 0 TO AVOID INTERMEDIATE 02040018 MER FR6,FR4 UNDERFLOW 02050018 AD FR6,D2 02060018 MDR FR6,FR4 02070018 AD FR6,D1 02080018 MDR FR6,FR4 02090018 AD FR6,D0 02100018 MDR FR6,FR0 02110018 BIG STD FR6,BUFF G(1/X) IS READY. SAVE IT 02120018 BALR GRR,GRL OBTAIN LOG(X) IN FR0 02130018 BC 0,ISN3 02140018 HDR FR2,FR0 LOG(X)/2 IN FR2 02150018 SD FR0,ONE 02160018 MD FR0,0(GR3) X*(LOG(X)-1) IN FR0 02170018 SD FR2,BUFF ASSEMBLE LOGGAMMA(X) 02180018 SD FR2,LG2PI 02190018 STE FR0,BUFF GIVE BIAS TO X*(LOG(X)-1) TO 02200018 MVC BIAS(1),BUFF COMPENSATE FOR ROUND OFF 02210018 AW FR0,BIAS 02220018 SDR FR0,FR2 02230018 SPACE 02240018 TM TEST+1,X'80' 02250018 BC 8,FIN IF LOGGAMMA WANTED, SKIP TO EXIT 02260018 STD FR0,BUFF IF GAMMA WANTED, RAISE TO E'S POWER 02270018 LA GRA,ABUFF BY GOING TO DEXP SUBROUTINE 02280018 L GRL,ADEXP 02290018 BALR GRR,GRL 02300018 BC 0,ISN4 02310018 BC 15,FIN SKIP TO EXIT 02320018 SPACE 02330018 SPACE 2 02980000 ERROR1 MVI MSG+5,X'F0' SET MSG TO IHC300I 02984016 LA GRR,LIST1 GET LIST TO SET UP FOR ERROR1 02988016 B ERRORS ARG LE 2**-252 OR GE 57.5744 02992016 ERROR2 MVI MSG+5,X'F1' SET MSG TO IHC301I 02996016 LA GRR,LIST2 GET LIST TO SET UP FOR ERROR2 03000016 * ARG LE 0 OR GE 4.2937*10**73 03004016 SPACE 03008016 ERRORS STD FR2,BUFF STORE ILLEGAL DATA IN AREA 03012016 MVC NAME(4),4(GRR) ADD 'DGAM' OR 'DLGA' TO NAME IN 03016016 MVC SUFFIX(22),8(GRR) MSG AND APPEND MSG TEXT 03020016 ST GRR,ERRLIST+8 STORE ADDR OF ERRNUM TO PARM 03024016 LM GRR,GRL,AERRMON 14=ADDR IHCERRM 15= ADDR IBCOM 03028016 LA GR3,MSGDATA POINT TO DATA AREA IN MESSAGE 03032016 LR GR4,GR2 SAVE ADDRESSABILITY 03036016 LA GR2,BUFF POINT TO DATA 03040016 EX 0,90(GRL) FCVDO 03044016 BALR 0,1 03048016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 03052016 LA GR3,AHEXDATA(GR3) PLACE IN MSG FOR HEX DATA 03056016 EX 0,78(GRL) FCVZO 03060016 BALR 0,1 03064016 DC X'0810' LL=8 WW=16 03068016 SPACE 03072016 LR GR2,GR4 RESTORE ADDRESSABILITY 03080016 LA GRA,ERRLIST PARAMS FOR ERRMON 03084016 LR GRL,GRR ADDR IHCERRM 03088016 BALR GRR,GRL 03092016 SPACE 03093018 LA GRA,ERRLIST+12 SET UP ARG POINTER 03094018 CLI RETCODE+3,X'00' DID USER FIX DATA 03096016 BNE BEGIN YES-TRY WITH NEW DATA 03100016 LD FR0,INFINY STANDARD FIXUP FOR BOTH ERRORS 03104016 * IS LARGEST FLOATING NUMBER 03108016 B FIN RETURN 03112016 SPACE 03140000 BUFF DS D 03160000 INFINY DC X'7FFFFFFFFFFFFFFF' 03170016 A6 DC X'C0C1B71B59A1A1F6' A6 = - 0.7567002385928 03190018 A5 DC X'41B33F20CFA73CB3' A5 = 11.2029121505218 03210018 DC X'4153CF867C239860' A4 = 5.2381653641874 03230018 DC X'C23EBA40FFB0397B' A3 = - 62.7275543027149 03250018 DC X'43441182D7048BE6' A2 = 1089.0944433381650 03270018 DC X'43C3CDE7AC8F2232' A1 = 3132.8690610495717 -3F 03290018 DC X'42E8A532ACC72020' A0 = 232.6453044878145 03310018 B6 DC X'C1A5004D879829C5' B6 = - 10.3125739380508 03330018 B5 DC X'41E62A3573ECF95D' B5 = 14.3853048828456 03350018 DC X'42C97F1D84DC37A0' B4 = 201.4965441739693 03370018 DC X'C327558408F56C71' B3 = - 629.3447351061687 03390018 DC X'C358DA535E278586' B2 = -1421.6453534644901 03410018 DC X'4411F52476FDA8AB' B1 = 4597.1424406563556 03430018 DC X'441C1A16BED21CC5' B0 = 7194.0888491935961 03450018 C0 DC X'40E2DFC48DA77B56' GAMMA(1.5) = 0.8862269254527580'+F 03470018 D4 DC X'3E31E4F7' D4 = 0.00076132793 03490018 D3 DC X'BE26EC11' D3 = -0.00059390466 03510018 D2 DC X'3E340314721524AF' D2 = 0.00079364060555471 03530018 D1 DC X'BEB60B60907F58F2' D1 = -0.00277777774362899 03550018 D0 DC X'4015555555554ADC' D0 = 0.08333333333329612 03570018 LG2PI DC X'40EB3F8E4325F5C5' 0.5*LOG(2PI) +32F 03590018 HALF DC X'4080000000000000' 03610018 ONE DC X'4110000000000000' 03630018 BIAS DC X'0000000000000001' 03650018 ONHLF DC X'41180000' 4 WORDS FROM ONHLF MUST 03670018 INDEX DC X'00000000' BE LOCATED TOGETHER STARTING 03690018 DC F'8' AT DOUBLE WORD BOUNDARY 03710018 DC F'40' 03730018 TWO DC X'41200000' 03750018 EIGHT DC X'41800000' 03770018 MIN DC X'02100000' 2**(-252) 03790018 MAX1 DC X'4239930C' 57.5744 03810018 MAX2 DC X'7E184D2F' 4.2937*10**73 03830018 LMBIG DC X'47200000' 2**25 03850018 AREA DS 18F SAVE AREA FOR SUBROUTINES,ERRM 03880016 ADLOG DC A(DLOG) 03900000 ADEXP DC A(DEXP) 03920000 AERRMON DC V(IHCERRM) 03930016 ADCOM DC A(IBCOM#) 03940000 RETCODE DS F RETURN CODE FROM ERMON 03944016 ERRLIST DC A(MSGLNG) PARAMETERS FOR ERMON AND 03948016 DC A(RETCODE) FIXUP ROUTINE 03952016 DS F POINTER TO APPROPRIATE ERROR NUM 03956016 ABUFF DC X'80' 03960000 DC AL3(BUFF) 03980000 EJECT 04081016 LIST1 DC F'300' ERROR NUMBER 04082016 DC C'DGAM' PART OF NAME FOR MSG 04083016 DC C'2**-252 OR GE 57.5744 ' SUFFIX OF MSG FOR ERROR1 04084016 LIST2 DC F'301' 04085016 DC C'DLGA' 04086016 DC C'0. OR GE 4.2937*10**73' 04087016 MSGLNG DC A(ENDMSG-MSG) *MSG SKELETON 04088016 MSG DC C'IHC30*I ' * 04089016 NAME DS 4C * 04090016 DC C'MA ARG=' * 04091016 MSGDATA DS 23C * 04092016 DC C'(HEX=' * 04093016 HEXDATA DS 16C * 04094016 DC C'), LE ' * 04095016 SUFFIX DS 22C * 04096016 ENDMSG EQU * * 04097016 AHEXDATA EQU HEXDATA-MSGDATA 04098016 END 04100000 ./ ADD SSI=02013623,NAME=IHCLLOG,SOURCE=0 LLOG TITLE 'LOGARITHMIC FUNCTION (LONG)' 00010018 IHCLLOG CSECT 00020018 * 00030018 * LOGARITHMIC FUNCTION (LONG) 00040018 * 1. WRITE X = (M*2**-Q)*16**P, M MANTISSA BETWEEN 1/2 00050018 * AND 1, Q INTEGER BETWEEN 0 AND 3. DEFINE A=1, B=0 00060018 * IF M GREATER THAN SQRT2/2, OTHERWISE A=1/2, B=1. 00070018 * 2. WRITE Z = (M-A)/(M+A), THEN 00080018 * LOG(X) = (4P-Q-B)LOG(2)+LOG((1+Z)/(1-Z)). 00090018 SPACE 00180000 EXTRN IBCOM# 00200000 EXTRN IHCERRM 00210016 ENTRY DLOG 00220000 ENTRY DLOG10 00240000 SPACE 00260000 GR0 EQU 0 SCRATCH REGISTERS 00280000 GR1 EQU 1 00300000 GR2 EQU 2 00320000 GR3 EQU 3 00340000 GRA EQU 1 ARGUMENT POINTER 00360000 GRS EQU 13 SAVE AREA POINTER 00380000 GRR EQU 14 RETURN REGISTER 00400000 GRL EQU 15 LINK REGISTER 00420000 FR0 EQU 0 ANSWER REGISTER 00440000 FR2 EQU 2 SCRATCH REGISTER 00460000 FR4 EQU 4 00470018 FR6 EQU 6 00480018 SPACE 00490018 USING *,GRL 00500018 DLOG10 BC 15,LLOG10 COMMON LOG ENTRY 00510018 DC AL1(6) 00520018 DC CL7'DLOG10' 00530018 SPACE 00540018 LLOG10 STM GRR,GR3,12(GRS) SAVE REGISTERS 00550018 MVI MDTM,X'6C' SET MDTM TO MD 00560018 BAL GRL,MERGE ADJUST BASE REGISTER AND MERGE 00570018 SPACE 00580018 USING *,GRL 00590018 DLOG BC 15,LLOG NATURAL LOG ENTRY 00600018 DC AL1(4) 00610018 DC CL5'DLOG' 00620018 LLOG STM GRR,GR3,12(GRS) SAVE REGISTERS 00630018 MVI MDTM,X'91' SET MDTM TO TM (NOP) 00640018 SPACE 00650018 MERGE L GR2,0(GRA) 00660018 BEGIN EQU * 00810016 LM GR2,GR3,0(GR2) OBTAIN ARGUMENT IN GR2, GR3 00830018 LTR GR0,GR2 00850018 BC 12,ERROR IF ARG IS 0 OR NEGATIVE, ERROR 00870018 SRDL GR0,24 CHAR IN LOW GR0, 1ST DIGIT IN HIGH GR1 00890018 SLL GR0,2 00910018 STH GR0,IPART+2 FLOAT 4*CHAR AND SAVE IT 00930018 SRL GR1,29 1ST THREE BITS OF M IN GR1 00950018 IC GR1,TABLE(GR1) NUMBER OF LEADING ZEROS (=Q) IN GR1 00970018 SLDL GR2,0(GR1) 00990018 STM GR2,GR3,BUFF 01010018 MVI BUFF,X'40' M = FRACTION*2**Q IN CELL BUFF 01030018 SPACE 01050018 SR GR2,GR2 IF M LESS THAN SQRT2/2, GR2=0 01070018 LD FR0,BUFF PICK UP M IN FR0 01090018 CE FR0,LIMIT IF M GREATER THAN SQRT2/2, GR2=8 01110018 BC 2,READY 01130018 LA GR2,8 01150018 LA GR1,1(GR1) CRANK GR1 BY 1. Q+B IN GR1 01170018 SPACE 01190018 READY HDR FR2,FR0 COMPUTE 2Z = (M-A)/(0.5M+0.5A), 01210018 SD FR0,ONE(GR2) A = 1 OR 1/2 01230018 AD FR2,HALF(GR2) 0.5M+0.5A HAS 56 BITS 01250018 DDR FR0,FR2 01270018 SPACE 01290018 LDR FR2,FR0 COMPUTE LOG((1+Z)/(1-Z)) BY MINIMAX 01310018 MDR FR2,FR2 APPROXIMATION OF THE FORM 01330018 LD FR4,C6 W+C1*W**3(W**2+C2+C3/ 01350018 ADR FR4,FR2 (W**2+C4+C5/(W**2+C6))) 01370018 LD FR6,C5 01390018 DDR FR6,FR4 01410018 AD FR6,C4 01430018 ADR FR6,FR2 01450018 LD FR4,C3 01470018 DDR FR4,FR6 01490018 AD FR4,C2 01510018 ADR FR4,FR2 01530018 MD FR4,C1 01550018 MDR FR4,FR2 01570018 MDR FR4,FR0 01590018 ADR FR4,FR0 01610018 SPACE 01630018 LD FR0,IPART 4*(P+64) 01650018 LA GR1,256(GR1) 4*64+Q+B 01670018 STH GR1,IPART+2 FLOAT THIS AND SUBTRACT FROM FR0 01690018 SE FR0,IPART TO OBTAIN 4P-Q-B 01710018 MD FR0,LOGE2 MULTIPLY BY LOG(2) BASE E 01730018 ADR FR0,FR4 AND ADD TO LOG((1+Z)/(1-Z)) 01750018 SPACE 01770018 MDTM MD FR0,LOGTE TM (EFFECTIVE NOP) IF DLOG ENTRY 01790018 EXIT EQU * 01950016 LM GR2,GR3,28(GRS) 01960000 MVI 12(GRS),X'FF' 01980000 BCR 15,GRR RETURN 02000000 SPACE 02020000 ERROR STM GR2,GR3,DATA SAVE ARG, LE ZERO 02024018 LR GRR,GRL SAVE ADDRESSABILITY 02028016 LA 2,DATA 02032016 LA 3,MSGDATA 02036016 L GRL,ACOM 02040016 EX 0,86(GRL) FCVDO 02044016 BALR 0,1 02048016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 02052016 LR 3,GRS 02056016 LA GRS,OFFSET(GRL) SAVE AREA IN IBCOM 02060016 ST 3,4(GRS) LINK SAVE AREAS 02064016 ST GRS,8(3) 02068016 LR 3,GRR SAVE ADDRESSABILITY 02072016 DROP GRL 02076016 USING DLOG,3 02080016 LA 1,ERRLIST 02084016 L GRL,AERRMON 02088016 BALR GRR,GRL TO ERMON 02092016 LR GRL,3 RESTORE ADDRESSABILITY 02096016 DROP 3 02100016 USING DLOG,GRL 02104016 L GRS,4(GRS) RESTORE 13 02108016 L GRR,12(GRS) RESTORE 14 02112016 CLI RETCODE+3,X'00' DID USER FIX DATA 02120016 BNZ BEGIN YES-TRY AGAIN 02124016 NI DATA,X'7F' MAKE DATA POSITIVE 02128016 L GR0,DATA 02132016 LTR GR0,GR0 WAS DATA NEG OR ZERO 02136016 BNZ BEGIN NEG-START AGAIN WITH POSITIVE 02140016 LD FR0,INFINY STANDARD FIXUP-NEG INIFINITY 02144016 B EXIT 02148016 SPACE 02160000 BUFF DS D 02180000 INFINY DC X'FFFFFFFFFFFFFFFF' NEGATIVE INFINITY-STANDARD 02186016 * FIX FOR ZERO ARGUMENT 02192016 C6 DC X'C158FA4E0E40C0A5' -0.5561109595943017E+1 02212018 C5 DC X'C12A017578F548D1' -0.2625356171124214E+1 02232018 C4 DC X'C16F2A64DDFCC1FD' -0.6947850100648906E+1 02252018 C3 DC X'C38E5A1C55CEB1C4' -0.2277631917769813E+4 02272018 C2 DC X'422FC604E13C20FE' 0.4777351196020117E+2 02292018 C1 DC X'3DDABB6C9F18C6DD' 0.2085992109128247E-3 02312018 IPART DC X'4600000000000000' 02332018 LOGE2 DC X'40B17217F7D1CF7B' LOG(2) BASE E + FUDGE 1 02352018 LOGTE DC X'406F2DEC549B943A' LOG(E) BASE 10 + FUDGE 1 02372018 ONE DC X'4110000000000000' THESE THREE 02392018 HALF DC X'4080000000000000' CONSTANTS MUST 02412018 DC X'4040000000000000' BE CONSECUTIVE 02432018 TABLE DC X'0302010100000000' 02452018 LIMIT DC X'40B504F3' 1/SQRT 2 02480000 ACOM DC A(IBCOM#) 02500000 AERRMON DC V(IHCERRM) 02501016 DATA EQU BUFF 02502016 OFFSET EQU X'C4' 02503016 ERRNUM DC F'263' 02504016 ERRLIST DC A(MSGLNG) 02505016 DC A(RETCODE) 02506016 DC A(ERRNUM) 02507016 DC X'80' 02508016 DC AL3(DATA) 02509016 RETCODE DS F 02510016 MSGLNG DC A(ENDMSG-MSG) 02511016 MSG DC C'IHC263I DLOG-DLOG10 ARG=' 02512016 MSGDATA DS 23C 02513016 DC C' LE ZERO' 02514016 ENDMSG EQU * 02515016 FLAG DS C 02516016 END 02520000 ./ ADD SSI=01013621,NAME=IHCLSCN,SOURCE=0 LSCN TITLE 'SINE-COSINE FUNCTIONS (LONG)' 00010018 IHCLSCN CSECT 00020018 * 00030018 * SINE-COSINE FUNCTIONS (LONG) 00040018 * 1. DIVIDE MAGNITUDE OF ARG BY PI/4 TO FIND OCTANT 00050018 * AND FRACTION. 00060018 * 2. IF COSINE, ADD 2 TO OCTANT NUMBER. 00070018 * 3. IF SINE, ADD 0(4) TO OCTANT NUMBER FOR +ARG(-ARG). 00080018 * 4. COMPUTE SINE OR COSINE OF FRACTION*PI/4 DEPENDING 00090018 * ON THE OCTANT. 00100018 * 5. IF OCTANT NUMBER IS FOR LOWER PLANE, MAKE SIGN -. 00110018 SPACE 00220000 EXTRN IBCOM# 00240000 EXTRN IHCERRM 00245016 ENTRY DCOS 00260000 ENTRY DSIN 00280000 SPACE 00300000 GR0 EQU 0 SCRATCH REGISTERS 00320000 GR1 EQU 1 00340000 GR2 EQU 14 00350018 GRA EQU 1 ARGUMENT POINTER 00360000 GRS EQU 13 SAVE AREA POINTER 00380000 GRR EQU 14 RETURN REGISTER 00400000 GRL EQU 15 LINK REGISTER 00420000 FR0 EQU 0 ANSWER REGISTER 00440000 FR2 EQU 2 SCRATCH REGISTERS 00460000 FR4 EQU 4 00480000 ON EQU X'FF' 00486014 OFF EQU X'00' 00492014 SPACE 00500000 USING *,GRL 00520018 DCOS BC 15,LCOS COSINE ENTRY 00540018 DC AL1(4) 00560018 DC CL5'DCOS' 00580018 LCOS STM GRR,GR0,12(GRS) SAVE REGISTERS 00600018 LA GR0,2 FOR COSINE, OCTANT CRANK IS 2 00620018 L GR2,0(GRA) COS(X) = SIN(PI/2+X) 00640018 BAL GRL,MERGE ADJUST BASE REGISTER AND MERGE 00660018 SPACE 00680018 USING *,GRL 00700018 DSIN BC 15,LSIN SINE ENTRY 00720018 DC AL1(4) 00740018 DC CL5'DSIN' 00760018 LSIN STM GRR,GR0,12(GRS) SAVE REGISTERS 00780018 L GR2,0(GRA) ADDR OF DATA 00800018 CRANK EQU * 00820016 SR GR0,GR0 FOR SINE, OCTANT CRANK IS 0 IF +ARG 00840018 TM 0(GR2),X'80' OCTANT CRANK IS 4 IF ARG NEG 00860018 BC 8,*+8 SIN(-X) = SIN(PI+X) 00880018 LA GR0,4 00900000 SPACE 00920000 MERGE LD FR0,0(GR2) PICK UP THE ARGUMENT 00940018 LPER FR0,FR0 FORCE SIGN OF ARG TO + 00960000 CE FR0,MAX 00980000 BC 10,ERROR ERROR IF /X/ GRT THAN OR = PI*2**50 01000000 SPACE 01020000 DD FR0,PIOV4 DIVIDE BY PI/4 AND SEPARATE INTEGER 01030018 LDR FR2,FR0 PART AND FRACTION PART OF QUOTIENT 01040018 AW FR2,SCALER FORCE CHARACTERISTIC X'4E' 01050018 STD FR2,BUFF INTEGER PART UNNORMALIZED = OCTANT 01060018 AD FR2,SCALER INTEGER PART NORMALIZED 01070018 SDR FR0,FR2 FRACTION PART TO FR0 01080018 AL GR0,BUFF+4 ADJUST OCTANT NUMBER WITH CRANK 01090018 ST GR0,OCTNT AND SAVE IT 01100018 SPACE 01110018 TM OCTNT+3,X'01' IF ODD OCTANT, TAKE COMPLEMENT 01120018 BC 8,EVEN OF FRACTION TO OBTAIN MODIFIED ARG 01130018 SD FR0,C0 01140018 SPACE 01150018 EVEN LPDR FR4,FR0 01160018 SR GR1,GR1 GR1 = 0 FOR COSINE POLYNOMIAL 01170018 TM OCTNT+3,X'03' THIS IS FOR OCTANT 2, 3, 6, OR 7 01180018 BC 4,*+8 GR1 = 8 FOR SINE POLYNOMIAL 01190018 LA GR1,8 THIS IS FOR OCTANT 1, 4, 5, OR 8 01200018 SPACE 01210018 CE FR4,UNFLO IF X IS LESS THAN 16**-7, SET X TO 0 01220018 BC 2,*+6 THIS PREVENTS UNDERFLOW 01230018 SDR FR0,FR0 01240018 SPACE 01250018 MDR FR0,FR0 COMPUTE SINE OR COSINE OF MODIFIED 01260018 LDR FR2,FR0 ARG USING PROPER CHEBYSHEV 01270018 MD FR0,C7(GR1) INTERPOLATION POLYNOMIAL 01280018 AD FR0,C6(GR1) 01290018 MDR FR0,FR2 SIN(X)/X POLYNOMIAL OF DEG 6 IN X**2 01300018 AD FR0,C5(GR1) COS(X) POLYNOMIAL OF DEG 7 IN X**2 01310018 MDR FR0,FR2 01320018 AD FR0,C4(GR1) 01330018 MDR FR0,FR2 01340018 AD FR0,C3(GR1) 01350018 MDR FR0,FR2 01360018 AD FR0,C2(GR1) 01370018 MDR FR0,FR2 01380018 AD FR0,C1(GR1) 01390018 SPACE 01400018 LTR GR1,GR1 01410018 BC 8,COSF 01420018 MDR FR0,FR4 COMPLETE SINE POLYNOMIAL BY 01430018 BC 15,SIGN MULTIPLYING BY X 01440018 SPACE 01450018 COSF MDR FR0,FR2 COMPLETE COSINE POLYNOMIAL 01460018 AD FR0,C0 (ONE MORE DEGREE) 01470018 SPACE 01920000 SIGN TM OCTNT+3,X'04' IF MODIFIED OCTANT IS IN 01940000 BC 8,*+6 LOWER PLANE, SIGN IS NEGATIVE 01960000 LNER FR0,FR0 01980000 EXIT EQU * 01983016 SPACE 02000000 L GRR,12(GRS) RETURN POINT 02010018 MVI 12(GRS),X'FF' RETURN 02020000 BCR 15,GRR 02040000 SPACE 02060000 ERROR MVC DATA(8),0(GR2) STORE DATA- GE PI*2**5/ IN ABS 02062018 ST GR0,SCNSW SAVE SIN-COS SWITCH 02063018 ST GRA,24(GRS) SAVE REG 1 FOR TRACEBACK 02064018 LR GRR,GRL SAVE ADDRESS ABILITY 02066016 LR GR1,GRS SAVE ADDR SAVE AREA 02068016 L GRL,ACOM 02070016 LA GRS,OFFSET(GRL) COMMON SAVEAREA ADDR OF IBCOM 02072016 ST GR1,4(GRS) 02074016 ST GRS,8(GR1) LINK SAVE AREAS 02076016 STM 2,3,20(GRS) SAVE 2,3 FOR CONVERSION 02078016 DROP 15 02080016 USING DSIN,14 02082016 LA 2,DATA DATA IN INTERNAL FORM 02084016 LA 3,MSGDATA DATA IN EXTERNAL FORM FOR MSG 02086016 EX 0,90(0,GRL) FCVDO 02088016 BALR 0,1 02090016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 02092016 LA 3,HEXDATA FOR HEX DATA IN MSG 02094016 EX 0,78(0,15) FCVZO 02096016 BALR 0,1 02098016 DC X'0810' LL=8 WW=16 02100016 LR 0,GRR SAVE ADDRESSABILITY 02102016 LM 2,3,20(GRS) RELOAD 2,3 02104016 LA 1,ERRLIST 02106016 L 15,AERRMON 02108016 BALR 14,15 02110016 LR GRL,0 RESTORE ADDRESSABILITY 02112016 DROP 14 02114016 USING DSIN,15 02116016 LA GR2,DATA POINT TO DATA 02118018 L GRS,4(GRS) CALLER'S SAVE AREA 02120016 LD FR0,ONOVSQT2 02124016 CLI RETCODE+3,X'00' DID USER FIX DATA 02126016 BZ EXIT NO USER FIXUP 02128016 L GR0,SCNSW RESTORE SIN-COS SWITCH 02130018 FIXUP TM SCNSW+3,X'02' WAS THIS COS 02132018 BO MERGE BRANCH TO DCOS (MERGE) 02134016 B CRANK BRANCH TO DSIN 02136016 SPACE 02160000 BUFF DS D 02161018 OCTNT EQU BUFF 02162018 C7 DC X'B66C992E84B6AA37' COS C7 02163018 DC X'3778FCE0E5AD1685' SIN C6 02164018 C6 DC X'387E731045017594' COS C6 02165018 DC X'B978C01C6BEF8CB3' SIN C5 02166018 C5 DC X'BA69B47B1E41AEF6' COS C5 02167018 DC X'3B541E0BF684B527' SIN C4 02168018 C4 DC X'3C3C3EA0D06ABC29' COS C4 02169018 DC X'BD265A599C5CB632' SIN C3 02170018 C3 DC X'BE155D3C7E3C90F8' COS C3 02171018 DC X'3EA335E33BAC3FBD' SIN C2 02172018 C2 DC X'3F40F07C206D6AB1' COS C2 02173018 DC X'C014ABBCE625BE41' SIN C1 02174018 C1 DC X'C04EF4F326F91777' COS C1 -2F 02175018 PIOV4 DC X'40C90FDAA22168C2' SIN C0 02176018 C0 DC X'4110000000000000' COS C0 02177018 SCALER DC X'4E00000000000000' 02178018 ONOVSQT2 DC X'40B504F333F9DE70' 02190016 UNFLO DC X'3A100000' 02280018 MAX DC X'4DC90FDA' 02370018 SCNSW DS F TO SAVE SIN-COS SWITCH 02460018 ACOM DC A(IBCOM#) 02560000 OFFSET EQU X'C4' 02562016 DATA EQU BUFF 02563018 AERRMON DC V(IHCERRM) 02564016 ERRLIST DC A(MSGLNG) 02565016 DC A(RETCODE) 02566016 DC A(ERRNUM) 02567016 DC X'80' 02568016 DC AL3(DATA) 02569016 RETCODE DS F 02570016 ERRNUM DC F'264' 02571016 EJECT 02572016 MSGLNG DC A(ENDMSG-MSG) 02573016 MSG DC C'IHC264I DSIN-DCOS /ARG/=/' 02574016 MSGDATA DS 23C 02575016 DC C'(HEX=' 02576016 HEXDATA DS 16C 02577016 DC C')/, GE PI*2**50' 02578016 ENDMSG EQU * 02579016 END 02580000 ./ ADD SSI=01013630,NAME=IHCLSCNH,SOURCE=0 TITLE ' SCNH HYPERBOLIC SIN-COS (LONG) ' 00010018 IHCLSCNH CSECT 00020000 * HYPERBOLIC SINE-COSINE FUNCTION (LONG) 00040000 * SINH(X) = (E**X-E**(-1))/2 00060000 * COSH(X) = (E**X+E**(-1))/2 00080000 * SINH(X) FOR SMALL X IS COMPUTED DIRECTLY BY POLYNOMIAL 00100000 * FOR OTHER CASES, ELABORATE USE OF $EXP IS MADE 00120018 SPACE 00140000 EXTRN DEXP 00160000 EXTRN IHCERRM 00170016 EXTRN IBCOM# 00180000 ENTRY DSINH 00200000 ENTRY DCOSH 00220000 SPACE 00240000 GR2 EQU 2 SCRATCH 00260000 GRA EQU 1 ARGUMENT POINTER 00280000 GR1 EQU 1 00290018 GRB EQU 2 MAIN BASE REGISTER 00300000 GRS EQU 13 SAVE AREA POINTER 00320000 GRR EQU 14 RETURN REGISTER 00360000 GRL EQU 15 LINK REGISTER 00380000 FR0 EQU 0 ANSWER REGISTER 00400000 FR2 EQU 2 SCRATCH REGISTERS 00420000 FR4 EQU 4 00440000 ISN EQU X'104' IDENTIFIER NUMBER FOR DEXP CALL 00460000 SPACE 00480000 USING *,GRL 00490018 DCOSH BC 15,DCH COSH ENTRY 00500018 DC AL1(5) 00510018 DC CL5'DCOSH' 00520018 DCH STM GRR,GRB,12(GRS) SAVE REGISTERS 00530018 MVI FLAG,X'30' SET INSTRUCTION 'FLAG' TO 'LPER' 00540018 BAL GRL,JOIN JOIN WITH COMMON CIRCUIT 00550018 SPACE 00560018 USING *,GRL 00570018 DSINH BC 15,DSH SINH ENTRY 00580018 DC AL1(5) 00590018 DC CL5'DSINH' 00600018 DSH STM GRR,GRB,12(GRS) SAVE REGISTERS 00610018 MVI FLAG,X'31' SET INSTRUCTION 'FLAG' TO 'LNER' 00620018 SPACE 00630018 JOIN EQU * 00640018 LR GRB,GRL SWITCH BASE REGISTERS TO GRB 00650018 USING DSINH,GRB 00660018 DROP GRL 00670018 BEGIN EQU * 00680018 L GR1,0(GRA) GET ARGUMENT POINTER 00690018 LD FR4,0(GR1) OBTAIN THE ARGUMENT X IN FR4 00700018 LPDR FR0,FR4 /X/ TO FR0 00710018 TM FLAG,X'01' 00720018 BC 8,EXPN1 IF COSH ENTRY, SKIP 00730018 CE FR0,LIMIT 00740018 BC 10,EXPN2 IF SINH, AND /X/ GE 0.88137, SKIP 00750018 SPACE 00760018 CE FR0,UNFLO IF SINH, AND /X/ LE 0.1626E-9, AVOID 00770018 BC 4,SIGN INTERMEDIATE UNDERFLOW, ANS = X 00780018 MDR FR0,FR0 00790018 LDR FR2,FR0 00800018 MD FR0,C6 FOR SINH OF MODEST ARGUMENT, USE 00810018 AD FR0,C5 00820018 MDR FR0,FR2 SINH(X) = X+X*XSQ*F(XSQ) 00830018 AD FR0,C4 00840018 MDR FR0,FR2 WHERE F(XSQ) IS A POLYNOM&AL 00850018 AD FR0,C3 00860018 MDR FR0,FR2 OF DEGREE 5 IN XSQ 00870018 AD FR0,C2 00880018 MDR FR0,FR2 USE OF EXPONENTIAL FOR THESE 00890018 AD FR0,C1 ARGUMENTS WOULD RESULT IN A 00900018 MDR FR0,FR2 LOSS OF ACCURACY 00910018 MDR FR0,FR4 00920018 ADR FR0,FR4 00930018 BC 15,FIN 00940018 SPACE 00950018 EXPN1 LPER FR4,FR4 COSH(X) IS ALWAYS POSITIVE 00960018 EXPN2 LR GRR,GRS SWITCH SAVE AREA POINTERS AND 00970018 LA GRS,AREA REPORT NEW AND OLD SAVE AREAS 00980018 ST GRS,8(GRR) 00990018 ST GRR,AREA+4 01000018 CE FR0,MAX 01010018 BC 2,ERROR IF /X/ TOO LARGE, GIVE ERROR 01020018 AD FR0,LNV 01030018 STD FR0,XABS COMPUTATION BY EXPONENTIAL 01040018 LA GRA,AXABS COMPUTE EXP(/X/+LOG(V)) 01050018 L GRL,ADEXP 01060018 BALR GRR,GRL NOTE FR4 IS NOT ALTERED BY DEXP 01070018 BC 0,ISN 01080018 L GRS,AREA+4 RESTORE SAVE AREA POINTER 01090018 LD FR2,VSQ COMPUTE V**2/EXP(/X/+LOG(V)) 01100018 DDR FR2,FR0 01110018 FLAG LNER FR2,FR2 'LPER' FOR COSH, 'LNER' FOR SINH 01120018 STD FR0,XABS SPECIAL MANEUVER TO MINIMIZE ROUNDING 01130018 ADR FR0,FR2 ERROR IN EFFECTIVELY EVALUATING 01140018 MD FR0,DELTA (E**X + OR - E**-X)/2 01150018 ADR FR0,FR2 HERE DELTA IS SUCH THAT 1+DELTA=1/2V, 01160018 AD FR0,XABS V IS CHOSEN SLIGHTLY LESS THAN 0.5. 01170018 SPACE 01180018 SIGN LTER FR4,FR4 01190018 BC 10,*+6 IF X IS NEGATIVE, SINH(X) = -SINH(/X/) 01200018 LNER FR0,FR0 01210018 FIN LM GRR,GRB,12(GRS) RESTORE REGISTERS 01220018 MVI 12(GRS),X'FF' FINALIZE AND RETURN 01230018 BCR 15,GRR 01240018 SPACE 01860000 ERROR EQU * 01862018 MVC DATA(8),0(GR1) STORE DATA, GT 175.366 01864018 STM GRB,3,12(GRS) SAVE BASE AND REG3 01866018 L GRL,ACOM 01868016 LA 3,MSGDATA 01872016 LA 2,DATA 01880016 EX 0,90(GRL) FCVDO 01884016 BALR 0,1 01888016 DC X'00171000' LL=8 WW=23 DD=16 SS=0 01892016 LM GRB,3,12(GRS) RESTORE 2,3 AFTER CONVERSION 01902018 LA 1,ERRLIST 01916016 L 15,AERRMON 01920016 BALR 14,15 GO TO ERMON 01924016 LD FR0,INFINY STANDARD FIXUP=INFINITY 01928016 L GRS,AREA+4 RESTORE SAVE AREA POINTER 01932018 CLI RETCODE+3,X'00' DID USER FIX DATA 01936016 BZ FIN NO-EXIT 01940016 LA GRA,ERRLIST+12 POINT TO NEW DATA 01944018 B BEGIN START AGAIN 01948016 SPACE 01960000 DS 0D 01966016 INFINY DC X'7FFFFFFFFFFFFFFF' STANDARD FIXUP= INFINITY 01972016 XABS DS D 01980000 C6 DC X'38B2D4C184418A97' 0.1626459177981471(-9) 01990018 C5 DC X'3A6B96B8975A1636' 0.2504995887597646(-7) 02000018 C4 DC X'3C2E3BC881345D91' 0.2755733025610683(-5) 02010018 C3 DC X'3DD00D00CB06A6F5' 0.1984126981270711(-3) 02020018 C2 DC X'3F2222222222BACE' 0.8333333333367232(-2) 02030018 C1 DC X'402AAAAAAAAAAA4D' 0.1666666666666653 +2F 02040018 VSQ DC X'403FDF9434F03D26' 0.2495052937740537 = V**2 02050018 LNV DC X'C0B1B30000000000' -0.6941375732421875 = LOG(V) 02060018 DELTA DC X'3E40F0434B741C6D' 0.0009908832830238=1/2V-1 +F 02070018 MAX DC X'42AF5DC0' 175.366 02080018 LIMIT DC X'40E1A1B8' 0.881374 02090018 UNFLO EQU C6 02100018 ACOM DC A(IBCOM#) 02180000 ADEXP DC A(DEXP) 02200000 ERRLIST DC A(MSGLNG) 02205016 DC A(RETCODE) 02210016 DC A(ERRNUM) 02215016 AXABS DC X'80' 02220000 DC AL3(XABS) 02240000 AREA DS 18F SAVE AREA 02260016 DATA EQU XABS 02281016 AERRMON DC V(IHCERRM) 02282016 RETCODE DS F 02283016 ERRNUM DC F'266' 02284016 EJECT 02285016 MSGLNG DC A(ENDMSG-MSG) 02286016 MSG DC C'IHC266I DSINH-DCOSH /ARG/=/' 02287016 MSGDATA DS 23C 02288016 DC C'/, GE 175.366' 02289018 ENDMSG EQU * 02290016 END 02300000 ./ ADD SSI=21460005,NAME=IHCLSQRT,SOURCE=0 LSQR TITLE 'SQUARE ROOT FUNCTION (LONG)' 00010000 IHCLSQRT CSECT 00020000 * 00030000 * STATUS - CHANGE LEVEL 01 21MAY72 RELEASE 21.6 00032021 * 00034021 *A004820-004860 A50154 00036021 * 00038021 * SQUARE ROOT FUNCTION (LONG) 00040000 * 1. WRITE X = M*16**(2P+Q), M MANTISSA, Q = 0 OR 1. 00050000 * 2. THEN SQRT(X) = SQRT(M*16**-Q)*16**(P+Q). 00060000 * P+Q IS THE EXPONENT OF THE ANSWER. 00070000 SPACE 00120000 EXTRN IBCOM# 00140000 EXTRN IHCERRM 00150016 ENTRY DSQRT 00160000 SPACE 00180000 GRA EQU 1 ARGUMENT POINTER 00190000 GRS EQU 13 SAVE AREA POINTER 00200000 GRR EQU 14 RETURN REGISTER 00210000 GRL EQU 15 LINK REGISTER 00220000 GR0 EQU 0 SCRATCH REGISTERS 00230000 GR1 EQU 1 00240000 GR2 EQU 14 00250000 FR0 EQU 0 ANSWER REGISTER 00260000 FR2 EQU 2 SCRATCH REGISTERS 00270000 FR4 EQU 4 00280000 SPACE 00290000 USING *,GRL 00300000 DSQRT BC 15,LSQRT 00310000 DC AL1(5) 00320000 DC CL5'DSQRT' 00330000 SPACE 00340000 LSQRT STM GRR,GRL,12(GRS) SAVE REGISTERS 00350000 L GR2,0(GRA) 00360000 BEGIN LD FR0,0(GR2) OBTAIN ARGUMENT 00370000 LTDR FR4,FR0 00380000 BC 4,ERROR IF NEGATIVE ARG, ERROR 00390000 BC 8,EXIT IF ARG IS 0, ANSWER IS 0. RETURN 00400000 STE FR4,BUFF 00410000 SPACE 00420000 L GR0,BUFF COMPUTE TARGET CHARACTERISTIC - 8 00430000 AL GR0,BIAS = X'31000000' CHAR OF X'41' MINUS 2*8 00440000 SRDL GR0,25 LOW GR0 = X'40'+P+Q-8 00450000 STC GR0,BUFF GIVE THIS CHARACTERISTIC TO M AND B 00460000 STC GR0,B THIS SEEMINGLY ARTIFICIAL CHAR WAS 00470000 LE FR2,BUFF CHOSEN TO AID THE FINAL ROUNDING 00480000 LE FR2,BUFF TO AID FINAL ROUNDING 50154 00482021 STC GR0,B THIS CHAR IS USED TO 50154 00484021 LE FR2,BUFF AID FINAL ROUNDING 50154 00486021 AE FR2,B (M+B)*16**(P+Q-8) 00490000 ME FR2,A A*(M+B)*16**(P+Q), A IS SCALED BY 8 00500000 LTR GR1,GR1 00510000 BC 10,*+8 IF Q=1, 1ST APPROX. Y0 IS READY 00520000 AER FR2,FR2 IF Q=0, MULTIPLY BY 4 TO OBTAIN Y0 00530000 AER FR2,FR2 00540000 SPACE 00550000 DER FR4,FR2 NEWTON-RAPHSON ITERATIONS 00560000 AUR FR4,FR2 00570000 HER FR4,FR4 Y1 = (Y0+ARG/Y0)/2 IN SHORT PRECISION 00580000 LER FR2,FR0 00590000 DER FR2,FR4 00600000 AUR FR2,FR4 00610000 HER FR2,FR2 Y2 = (Y1+ARG/Y1)/2 IN SHORT PRECISION 00620000 LDR FR4,FR0 00630000 DDR FR4,FR2 00640000 AWR FR4,FR2 00650000 HDR FR4,FR4 Y3 = (Y2+ARG/Y2)/2 IN LONG PRECISION 00660000 SPACE 00670000 DDR FR0,FR4 Y4 = (ARG/Y3-Y3)/2-D+D+Y3 FOR ROUNDING 00680000 SDR FR0,FR4 1ST APPOXROX IS SO CHOSEN THAT 00690000 HER FR0,FR0 ARG/Y3-Y3 IS LESS THAN 16**(P+Q-8) 00700000 SU FR0,B HENCE 'HER' IS GOOD ENOUGH 00710000 AU FR0,B -D+D IS TO CHOP OFF EXCESS DIGITS OF 00720000 ADR FR0,FR4 NEGATIVE VALUE (ARG/Y3-Y3)/2 00730000 SPACE 00740000 EXIT L GRR,12(GRS) 00750000 MVI 12(GRS),X'FF' 00760000 BCR 15,GRR RETURN 00770000 SPACE 01280000 ERROR STD FR0,DATA SAVE ERRONEOUS DATA 01283016 STM GR0,GRA,20(GRS) SAVE 0,1 FOR TRACEBACK 01284000 LR GRR,GRL SAVE ADDRESSABILITY 01286016 LR 1,GRS 01289016 L GRL,ACOM 01292016 LA GRS,OFFSET(GRL) IBCOM'S COMMON SAVE AREA 01295016 ST GRS,8(1) 01298016 ST 1,4(GRS) 01301016 STM 2,3,20(GRS) SAVE 2-3, USED FOR CONVERSION 01304016 DROP 15 01307016 USING DSQRT,14 01310016 LA 2,DATA DATA TO BE CONVERTED 01313016 LA 3,MSGDATA DATA AREA IN MSG 01316016 EX 0,86(GRL) FCVDO 01319016 BALR 0,1 01322016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 01325016 LM 2,3,20(GRS) RESTORE 2 AND 3 01328016 LA GR1,ERRLIST PARAM FOR ERMON 01331016 L GRL,AERRMON 01334016 LR 0,GRR SAVE ADDRESSABILITY 01337016 BALR GRR,GRL TO ERMON 01340016 L GRS,4(GRS) RESTORE 13 01343016 LR GRL,0 RESTORE ADDRESSABILITY 01346016 DROP 14 01349016 USING DSQRT,15 01352016 CLI RETCODE+3,X'00' DID USER FIX DATA 01358016 BNZ FIXUP YES 01361016 STNDFIX XI DATA,X'80' MAKE ARGUMENT POSITIVE 01364016 FIXUP LA GR2,DATA POINT TO FIXED DATA 01367000 B BEGIN START AGAIN 01370016 SPACE 01380000 AERRMON DC V(IHCERRM) 01385016 DS 0D 01390016 DATA DS F SECOND WORD OF DATA IS BUFF 01395016 BUFF DS F 01400000 ACOM DC A(IBCOM#) 01420000 BIAS DC X'31000000' 01430000 B DC X'00423A2A' 0.2587, TARGET CHAR -8 TO BE AFFIXED 01440000 A DC X'48385F07' 0.2202*16**8 01450000 OFFSET EQU X'C4' 01461016 ERRNUM DC F'261' 01462016 ERRLIST DC A(MSGLNG) 01463016 DC A(RETCODE) 01464016 DC A(ERRNUM) 01465016 DC X'80' 01466016 DC AL3(DATA) 01467016 RETCODE DS F 01468016 MSGLNG DC A(ENDMSG-MSG) 01469016 MSG DC C'IHC261I DSQRT NEGATIVE ARGUMENT=' 01470016 MSGDATA DS 23C 01471016 ENDMSG EQU * 01472016 END 01520000 ./ ADD SSI=02013622,NAME=IHCLTANH,SOURCE=0 LTNH TITLE 'HYPERBOLIC TANGENT FUNCTION (LONG)' 00900018 IHCLTANH CSECT 01800018 * 02700018 * HYPERBOLIC TANGENT FUNCTION (LONG) 03600018 * 1. IF /X/ LESS THAN 0.54931, USE A FRACTION APPROX. 04500018 * 2. IF /X/ GREATER THAN 20.101, ANSWER IS +1 OR -1. 05400018 * 3. FOR OTHER VALUE OF X, USE EXTERNAL DEXP FUNCTION. 06300018 SPACE 07200018 EXTRN DEXP 08100018 ENTRY DTANH 09000018 SPACE 09900018 GRA EQU 1 ARGUMENT POINTER 10800018 GRS EQU 13 SAVE AREA REGISTER 11700018 GRR EQU 14 RETURN REGISTER 12600018 GRL EQU 15 LINK REGISTER 13500018 GR0 EQU 0 SCRATCH REGISTERS 14400018 GR1 EQU 1 15300018 FR0 EQU 0 ANSWER REGISTER 16200018 FR2 EQU 2 SCRATCH REGISTERS 17100018 FR4 EQU 4 18000018 FR6 EQU 6 18900018 ISN EQU X'102' IDENTIFIER NUMBER FOR DEXP CALL 19800018 SPACE 20700018 USING *,GRL 21600018 DTANH BC 15,LTANH 22500018 DC AL1(5) 23400018 DC CL5'DTANH' 24300018 SPACE 25200018 LTANH STM GRR,GRL,12(GRS) SAVE REGISTERS 26100018 L GR1,0(GRA) 27000018 LD FR6,0(GR1) OBTAIN ARGUMENT X 27900018 LD FR4,ONE FR4 AND FR6 TRANSPARENT TO DEXP 28800018 LPDR FR0,FR6 /X/ TO FR2 29700018 CE FR0,MLIM 30600018 BC 12,SMALL IF /X/ LESS THAN 0.54931, JUMP 31500018 CE FR0,HLIM IF /X/ GREATER THAN 20.101 32400018 BC 10,BIG ANS = + OR -1, JUMP 33300018 SPACE 34200018 ADR FR0,FR0 FOR /X/ BETWEEN 0.54931 AND 20.101, 35100018 STD FR0,BUFF /ANS/ = 1-2/(1+E**/2X/) 36000018 LA GRR,AREA 36900018 ST GRR,8(GRS) SWITCH SAVE AREA POINTER 37800018 ST GRS,AREA+4 AND CALL EXP(/X/) 38700018 LR GRS,GRR 39600018 LA GRA,ABUFF 40500018 L GRL,ADEXP 41400018 BALR GRR,GRL 42300018 BC 0,ISN 43200018 USING *-4,GRR TEMPORARY BASE REGISTER 44100018 DROP GRL 45000018 L GRS,AREA+4 RESTORE SAVE AREA POINTER 45900018 LM GRR,GRL,12(GRS) AND RESTORE RET AND LINK REGISTER 46800018 DROP GRR 47700018 USING DTANH,GRL REGULAR BASE REGISTER 48600018 ADR FR0,FR4 49500018 LDR FR2,FR4 50400018 ADR FR2,FR2 51300018 DDR FR2,FR0 52200018 LDR FR0,FR4 53100018 SDR FR0,FR2 54000018 SPACE 54900018 SIGN LTER FR6,FR6 TANH(/X/) READY, ADJUST SIGN 55800018 BC 10,*+6 56700018 LNER FR0,FR0 57600018 SPACE 58500018 EXIT MVI 12(GRS),X'FF' 59400018 BCR 15,GRR RETURN 60300018 SPACE 61200018 BIG LDR FR0,FR4 CASE OF BIG ARGUMENT 62100018 BC 15,SIGN 63000018 SPACE 63900018 SMALL CE FR0,LLIM IF /X/ LESS THAN 2**-28, ANS=ARG. 64800018 BC 12,SIGN THIS AVOIDS UNDERFLOW 65700018 MDR FR0,FR0 /X/ SMALLER THAN 0.54931 66600018 LD FR4,C5 TANH(X) = X+X*F, WHERE 67500018 ADR FR4,FR0 F = C0*X**2/(X**2+C1+C2/ 68400018 LD FR2,C4 (X**2+C3+C4/(X**2+C5))) 69300018 DDR FR2,FR4 70200018 AD FR2,C3 71100018 ADR FR2,FR0 72000018 LD FR4,C2 72900018 DDR FR4,FR2 73800018 AD FR4,C1 74700018 ADR FR4,FR0 75600018 MD FR0,C0 76500018 DDR FR0,FR4 77400018 MDR FR0,FR6 78300018 ADR FR0,FR6 79200018 BC 15,EXIT TANH(X) READY, SET TO RETURN 80100018 SPACE 81000018 DS 0F 81900018 ABUFF DC X'80' 82800018 DC AL3(BUFF) 83700018 ADEXP DC A(DEXP) 84600018 HLIM DC X'421419DB' 85500018 LLIM DC X'3A100000' 86400018 MLIM DC X'408C9F95' 87300018 BUFF DS D 88200018 C0 DC X'C0F6E12F40F5590A' -0.9643735440816707 89100018 C1 DC X'419DA5D6FD3DBC84' 0.9852988232825539E+1 90000018 C2 DC X'C31C504FEF537AF6' -0.4530195153485250E+3 90900018 C3 DC X'424D2FA31CAD8D00' 0.7718608264195518E+2 91800018 C4 DC X'C3136E2A5891D8E9' -0.3108853383729134E+3 92700018 C5 DC X'4219B3ACA4C6E790' 0.2570185308319156E+2 93600018 ONE DC X'4110000000000000' 94500018 AREA DS 7F 7 WORDS NEEDED BY DEXP 95400018 END 96300018 ./ ADD SSI=01013622,NAME=IHCLTNCT,SOURCE=0 TITLE ' TNCT TANGENT-COTANGENT (LONG) ' 00010018 IHCLTNCT CSECT 00020000 * TANGENT-COTANGENT FUNCTION (LONG) 00040000 * 1. DIVIDE MAGNITUDE OF ARG BY PI/4 TO FIND OCTANT AND 00060000 * FRACTION. REDUCED ARGUMENT W IS EITHER THIS 00080000 * FRACTION OR ITS COMPLEMENT. THE MAGNITUDE OF 00100000 * ANSWER IS EITHER TAN(W*PI/4) OR COT(W*PI/4) 00120000 * 2. IF /ARG/ IS EQUAL OR GREATER THAN PI*2**50, ERROR1 00140000 * 3. IF COTAN IS WANTED, AND IF /ARG/ IS EQUAL OR SMALLER 00160000 * THAN 2**(-252), ERROR2 00180000 * 4. IF ARG IS SO CLOSE TO ONE OF SINGULARITIES OF THE 00200000 * FUNCTION THAT THE COMBINED EFFECT OF COMPUTATIONAL 00220000 * ERROR AND MINIMAL INPUT ERROR CAN CAUSE RELATIVE 00240000 * ERROR OF 1/5, ERROR2 IS GIVEN 00260000 SPACE 00280000 EXTRN IBCOM# 00300000 EXTRN IHCERRM 00310016 ENTRY DTAN 00320000 ENTRY DCOTAN 00340000 ENTRY QDTAN FOR MODIFICATION OF ERROR CONTROL 00360000 SPACE 00380000 GR2 EQU 14 SCRATCH 00400018 GRA EQU 1 ARGUMENT POINTER 00420000 USE2 EQU 4 BASE REG FOR ERROR CONDITION 00426016 *** REG 2 AND 3 ARE ALSO USED *** 00432016 GRS EQU 13 SAVE AREA POINTER 00440000 GRR EQU 14 RETURN REGISTER 00460000 GRL EQU 15 LINK REGISTER 00480000 FR0 EQU 0 ANSWER REGISTER 00500000 FR2 EQU 2 SCRATCH REGISTERS 00520000 FR4 EQU 4 00540000 FR6 EQU 6 00560000 SPACE 00580000 USING *,GRL 00600018 DCOTAN BC 15,DCOT 00620018 DC AL1(6) 00640018 DC CL6'DCOTAN' 00660018 DCOT STM GRR,GRA,12(GRS) SAVE REGISTERS 00680018 MVI SWICH,X'97' SET INSTRUCTION AT SWICH TO XI 00700018 BAL GRL,MERGE ADJUST BASE REG AND JOIN AT MERGE 00720018 SPACE 00740018 USING *,GRL 00760018 DTAN BC 15,DTN 00780018 DC AL1(4) 00800018 DC CL4'DTAN' 00820018 DTN STM GRR,GRA,12(GRS) SAVE REGISTERS 00840018 MVI SWICH,X'91' SET INSTRUCTION AT SWICH TO TM 00860018 SPACE 00880018 MERGE LD FR4,ONE COMMON SECTION. PRELOAD FR4 WITH 1.0 00900018 L GR2,0(GRA) 00920018 LD FR0,0(GR2) OBTAIN ABSOLUTE VALUE OF ARGUMENT 00940018 LPER FR0,FR0 IN FR0, AND ADDRESS OF ARG IN GR2 00960018 CE FR0,MAX 00980018 BC 10,ERROR1 IF /ARG/ TOO BIG, GIVE ERROR1 01000018 DD FR0,PIOV4 LET W = /ARG/ DIVIDED BY PI/4 01020018 STE FR0,OCTNT 01040018 MVC TEST(1),OCTNT GIVE CHAR OF QUOTIENT TO TESTING GAUGE 01060018 CER FR0,FR4 01080018 BC 10,NORML IF QUOTIENT HAS INTEGER PART, SKIP 01100018 MVI OCTNT+7,X'00' IF PURE FRACTION, CLEAR LOW PART OCTNT 01120018 TM SWICH,X'02' 01140018 BC 8,JOIN IF TAN ENTRY, OK, SKIP 01160018 CE FR0,MIN IF COTAN ENTRY, SKIP ONLY IF 01180018 BC 2,JOIN THERE IS NO DANGER OF OVERFLOW 01200018 SPACE 01220018 SPACE 01240000 ERROR2 LA GRA,LIST2 PARM LIST FOR ERROR2 SETUP 01260018 MVI MSG+5,X'F9' SET TO IHC269I 01280016 B CONVERT 01300016 SPACE 01340000 NORML LDR FR2,FR0 IF QUOTIENT HAS INTEGER PART, 01360018 AW FR2,CH4E ISOLATE IT IN FR2 (UNNORMALIZED), 01380018 STD FR2,OCTNT SAVE IT (LAST BITS ARE FOR OCTANT) 01400018 AD FR2,CH4E NORMALIZE IT AND SUBTRACT IT FROM 01420018 SDR FR0,FR2 FR0 TO OBTAIN FRACTION PART 01440018 TM OCTNT+7,X'01' 01460018 BC 8,JOIN IF EVEN OCTANT, MODIFIED ARG W IS READY 01480018 SDR FR0,FR4 IF ODD OCTANT, W=1-FRACTION 01500018 JOIN LPDR FR6,FR0 LEAVE W IN FR6, AND + OR -W IN FR0 01520018 SWICH XI OCTNT+7,X'01' IF COTAN ENTRY, REVERSE LAST BIT OF 01540018 LD FR2,B3 OCTANT, THUS REDUCE CASE TO TAN ENTRY 01560018 CE FR6,UNFLO 01580018 BC 4,SKIP LET U=WSQ IF W IS AT LEAST 2**-46 01600018 MDR FR0,FR0 AND COMPUTE TWO POLYNOMIALS 01620018 LDR FR4,FR0 01640018 AD FR4,A2 P(W) =W*(A0+A1*U+A2*U**2+U**3) 01660018 MDR FR4,FR0 01680018 AD FR4,A1 Q(W) = B0+B1*U+B2*U**2+B3*U**3 01700018 MDR FR2,FR0 01720018 AD FR2,B2 IF W IS LESS THAN 2**-46, LET 01740018 MDR FR2,FR0 U = + OR -W, AND SUBSTITUTE AS 01760018 AD FR2,B1 FOLLOWS TO AVOID INTERMEDIATE 01780018 SKIP MDR FR2,FR0 UNDERFLOW OF SQUARING W 01800018 AD FR2,B0 01820018 MDR FR0,FR4 P(W) = W*(A0+U) 01840018 AD FR0,A0 Q(W) = B0+B3*U 01860018 MDR FR0,FR6 01880018 TM OCTNT+7,X'03' 01900018 BC 4,COTN 01920018 DDR FR0,FR2 IF OCTANT IS 0 OR 3 (MOD 4) 01940018 BC 15,SIGN THE ANSWER IS TAN(W*PI/4)=P(W)/Q(W) 01960018 SPACE 01980018 COTN CD FR6,TEST IF OCTANT IS 1 OR 2 (MOD 4), AND IF 02000018 BC 12,ERROR2 W IS TOO SMALL, SINGULARITY TROUBLE 02020018 DDR FR2,FR0 OTHERWISE, THE ANSWER IS 02040018 LDR FR0,FR2 COTAN(W*PI/4)=Q(W)/P(W) 02060018 SPACE 02080018 SIGN TM OCTNT+7,X'02' IF OCTANT IS 2 OR 3 (MOD 4) 02100018 BC 8,*+6 CHANGE SIGN OF ANSWER 02120018 LCER FR0,FR0 02140018 TM 0(GR2),X'80' IF ARGUMENT WAS NEGAT&VE 02160018 BC 8,*+6 CHANGE SIGN OF ANSWER 02180018 LCER FR0,FR0 02200018 EXIT EQU * 02250016 L GRR,12(GRS) RESTORE GRR=GR2 02255018 MVI 12(GRS),X'FF' RETURN 02260000 BCR 15,GRR 02280000 SPACE 02300000 SPACE 02320000 ERROR1 LA GRA,LIST1 PARM LIST FOR ERROR1 SETUP 02321018 MVI MSG+5,X'F8' SET TO IHC268I 02322018 SPACE 02323018 CONVERT MVC DATA(8),0(GR2) STORE DATA IN ERROR 02324018 ST GRA,ERRLIST+8 ADDR OF ERRNUM IN ERRLIST 02325018 MVC STNDFIX(8),4(GRA) SET UP STANDARD FIXUP 02326018 MVC SUFFIX(22),12(GRA) SETUP FOR END OF MSG 02327018 LR 1,GRS SAVE ADDR CALLER'S SAVE AREA 02328016 LR 0,GRL SAVE USING REGISTER 02329016 L GRL,ACOM IBCOM# 02330016 DROP GRL 02331016 USING DTAN,USE2 02332016 SPACE 02333016 LA GRS,OFFSET(GRL) IBCOM SAVE AREA 02334016 ST GRA,4(GRS) LINK SAVE AREAS 02335018 ST GRS,8(GRA) 02336018 STM 2,USE2,12(GRS) STORE REGS IN IBCOM AREA 02337016 LR USE2,0 NEW BASE REG 02338016 LA 3,MSGDATA SETUP FOR DATA CONVERSION 02339016 LA 2,DATA 02340016 EX 0,90(GRL) FCVDO 02341016 BALR 0,1 02342016 DC X'08171000' LL=8 WW=23 DD=16 SS=0 02343016 SPACE 02344016 LA 3,HEXDATA 02345016 EX 0,78(GRL) FCVZ0 02346016 BALR 0,1 02347016 DC X'0810' LL=8 WW=16 02348016 SPACE 02349016 LA GRA,ERRLIST 02350016 L GRL,AERRMON 02351016 LR 0,USE2 SAVE USING REG 02352016 LM 2,USE2,12(GRS) RESTORE REGS USED IN CONVERSION 02353016 BALR GRR,GRL 02354016 DROP USE2 02355016 USING DTAN,GRL 02356016 SPACE 02357016 LR GRL,0 RESTORE BASE REGISTER 02358016 L GRS,4(GRS) RESTORE TO CALLER'S SAVE AREA 02359016 LD FR0,16(GRA) GET STANDARD FIXUP 02360018 LA GRA,ERRLIST+12 POINT TO ARG 02361018 * 02362016 * STANDARD FIXUP FOR ERROR1 IS ONE 02363016 * FOR ERROR2 IS LARGEST NUMBER MACHINE HOLDS 02364016 * 02365016 CLI RETCODE+3,X'00' DID USER FIX DATA 02367016 BZ EXIT NO- EXIT 02368016 B MERGE 02369018 SPACE 02370016 * CONSTANTS 02371016 DS 0D 02372016 ERRLIST DC A(MSGLNG) PARM LIST FOR ERMON 02373016 DC A(RETCODE) 02374016 DS F 02375016 DC X'80' 02376016 DC AL3(DATA) 02377016 STNDFIX DS D AREA FOR STANDARD FIXUP 02378016 OFFSET EQU X'C4' 02379016 DATA DS D 02380016 SPACE 02420000 OCTNT DS D 02440000 ONE DC X'4110000000000000' 1.0 02460018 CH4E DC X'4E00000000000000' UNNORMALIZED ZERO FOR SCALING 02480018 TEST DC X'00000000' WITH EXPN P GIVEN TO TEST 02500018 QDTAN DC X'00000008' VALUE OF 2 WORDS = 2**(4P-53) 02520018 PIOV4 DC X'40C90FDAA22168C2' PI/4 02540018 A2 DC X'C325FD4A87357CAF' - 607.8306953515 02560018 A1 DC X'44AFFA6393159226' + 45050.3889630777 02580018 A0 DC X'C58AFDD0A41992D4' -569309.0400634512 +3F IN ABS 02600018 B3 DC X'422376F171F72282' + 35.4646216610 02620018 B2 DC X'C41926DBBB1F469B' - 6438.8583240077 02640018 B1 DC X'4532644B1E45A133' +206404.6948906228 02660018 B0 DC X'C5B0F82C871A3B68' -724866.7829840012 02680018 MAX DC X'4DC90FDA' PI*2**50 02700018 MIN DC X'02145F31' (4/PI)*2**-252 02720018 UNFLO DC X'35400000' 2**-46 02740018 ACOM DC A(IBCOM#) 02780000 RETCODE DS F 02781016 AERRMON DC V(IHCERRM) 02782016 EJECT 02783016 SPACE 02784016 LIST1 DC F'268' ERROR NUMBER FOR ERROR1 02785016 DC X'4110000000000000' STANDARD FIXUP IS ONE 02786016 DC CL22'GE PI*2**50' END OF MSG 02787016 LIST2 DC F'269' ERROR NUMBER FOR ERROR2 02788016 DC X'7FFFFFFFFFFFFFFF' STANDARD FIXUP IS LARGEST NUMBER 02789016 DC C'APPROACHES SINGULARITY' END OF MSG 02790016 MSGLNG DC A(ENDMSG-MSG) *MSG 02791016 MSG DC C'IHC26*I DTAN-DCOTAN /ARG/=/' *SKELETON 02792016 MSGDATA DS 23C * 02793016 DC C'(HEX=' * 02794016 HEXDATA DS 16C * 02795016 DC C')/ ' * 02796016 SUFFIX DS 22C * 02797016 ENDMSG EQU * * 02798016 END 02800000 ./ ADD SSI=01010805,NAME=IHCNAMEL,SOURCE=0 TITLE 'IHCNAMEL' - OPERATING SYSTEM 360 FORTRAN H 00020000 IHCNAMEL START 0 NAMELIST I/O ROUTINES 00040000 *C098600 A38316 00045021 *A098480-098720 A38316 00050021 *A048860-048920,156300 A44648 00055021 *D093850-093900 A48968 00056021 *A093870 A48968 00057021 *A094500-094600,096500,096700 A48968 00058021 *A091300-092400,093870-093910 60621 00058521 *D091400-092600,093870,094500-094600,096500,096700 60621 00059021 *C091200,092500 60621 00059521 ENTRY FRDNL# 00060000 ENTRY FWRNL# 00080000 EXTRN IBCOM# 00100000 EXTRN ADCON# 00120000 EXTRN FIOCS# 00140000 * 00160000 * STATUS - CHANGE LEVEL 10 1MARCH1973 RELEASE 21.7 00180021 * 00200000 * FUNCTION/OPERATION--IHCNAMEL, A MEMBER OF THE FORTRAN SYSTEM LIBRARY, 00220000 * PERFORMS OBJECT-TIME IMPLEMENTATION OF NAMELIST READS AND WRITES. 00240000 * 00260000 * ENTRY POINTS-- 00280000 * 1. FRDNL#, THE NAMELIST READ ROUTINE. 00300000 * 2. FWRNL#, THE NAMELIST WRITE ROUTINE. 00320000 * 00340000 * INPUT--INPUT CONSISTS OF PARAMETERS PASSED IN THE CALLING SEQUENCES 00360000 * AND THE NAMELIST DICTIONARY GENERATED BY THE COMPILER, AND OF 00380000 * DATA READ FROM USER-DEFINED INPUT SOURCES. 00400000 * 00420000 * OUTPUT--OUTPUT CONSISTS OF DATA RECORDS AND ERROR MESSAGES. 00440000 * 00460000 * EXTERNAL ROUTINES-- 00480000 * 1. IHCFCOMH, TO HANDLE ERROR PROCESSING. 00500000 * 2. IHCFCVTH, TO CONVERT INPUT OR OUTPUT DATA. 00520000 * 3. IHCFIOSH, TO INTERFACE I/O REQUESTS WITH DATA MANAGEMENT. 00540000 * 00560000 * EXITS-- 00580000 * NORMAL--RETURN IS TO THE CALLING ROUTINE VIA REGISTER 14. 00600000 * ERROR--A CALL IS MADE TO IHCFCOMH TO WRITE AN ERROR MESSAGE 00620000 * AND TERMINATE EXECUTION. 00640000 * 00660000 * TABLES/WORK AREAS-- 00680000 * 'NLFORM' - OUTPUT FORMAT CODES FOR WIDTH AND NUMBER OF DECIMALS, 00700000 * CORRESPONDING TO MODE. 00720000 * 'LENGTH' - ITEM LENGTH, CORRESPONDING TO MODE. 00740000 * 'INFORM' - INPUT FORMAT CODES FOR NOP OR ZERO DECIMALS, 00760000 * CORRESPONDING TO MODE. 00780000 * 'SAVENL' - REGISTER STORAGE AREA. 00800000 * 00820000 * ATTRIBUTES--THIS MODULE IS NOT REENTRANT, BUT IS SERIALLY REUSABLE. 00840000 * 00860000 * NOTES-- 00880000 * 1. ALL CALLING SEQUENCES TO IHCNAMEL ARE NON-STANDARD. 00900000 * 2. IHCNAMEL USES ITS OWN INTERNAL REGISTER SAVE AREAS, 00920000 * RATHER THAN STORING REGISTERS IN THE CALLING PROGRAM. 00940000 * 00960000 EJECT 00980000 * REGISTER DEFINITIONS 01000000 R EQU 14 RETURN REGISTER 01020000 L EQU 7 BASE REGISTER 01040016 GRX EQU 2 FIRST ARGUMENT 01060000 GRY EQU 3 SECOND ARGUMENT 01080000 SPILL EQU 4 UTILITY REGISTER 01100000 BASE EQU 5 BASE REGISTER 01120000 CALLER EQU 6 CALLING REGISTER 01140000 BUFLIM EQU 8 END OF RECORD 01160000 BUFPTR EQU 9 LOCATION IN RECORD 01180000 NDICTX EQU 10 DICTIONARY POINTER 01200000 ADDER EQU 11 ARRAY INCREMENT 01220000 LOOP EQU 12 LOOP CONTROL 01240000 SUBDCT EQU 3 AUX. DICTIONARY POINTER 01260000 EVEN EQU 4 EVEN REGISTER 01280000 ODD EQU 5 ODD REGISTER 01300000 CHRCNT EQU 13 CHARACTER COUNT 01320000 NODIM EQU 13 DIMENSION COUNT 01340000 CALLBY EQU 4 INTERNAL CALLS 01360000 WIDTH EQU 6 BUFFER POSITIONS 01380000 IBBS EQU 15 ADDRESS OF IBCOM REG. 01390016 NUMBER EQU 15 BINARY INTEGER 01400016 SPACE 3 01420000 * BRANCHING CONDITIONS 01440000 ALWAYS EQU 15 UNCONDITIONAL 01460000 EQUAL EQU 8 EQUAL 01480000 NOTEQ EQU 7 NOT EQUAL 01500000 HIGH EQU 2 HIGH 01520000 LOW EQU 4 LOW 01540000 HIEQ EQU 10 HIGH OR EQUAL 01560000 LOEQ EQU 12 LOW OR EQUAL 01580000 ZERO EQU 8 ZERO 01600000 PLUS EQU 2 PLUS 01620000 ZPLUS EQU 10 ZERO OR PLUS 01640000 ZMINUS EQU 12 ZERO OR MINUS 01660000 ALL EQU 1 ALL BITS ON 01680000 ANY EQU 4 ANY BITS ON 01700000 NONE EQU 8 NO BITS ON 01720000 SPACE 3 01740000 * MISCELLANEOUS CODES 01760000 FMTINP EQU X'F0' FORMATTED INPUT 01780000 FMTOUT EQU X'FF' FORMATTED OUTPUT 01800000 INIT EQU X'00' INITIALIZATION OPERATION 01820000 READ EQU X'01' READ OPERATION 01840000 RITE EQU X'02' WRITE OPERATION 01860000 NULL EQU X'03' NULL QUALIFIER 01880000 ON EQU X'FF' ON CONDITION 01900000 OFF EQU X'00' OFF CONDITION 01920000 DSRNOF EQU 60 OFFSET IN IBCOM FOR DSRN 01922016 FRTNUSR EQU 124 OFFSET IN IBCOM TO USER'S REG14 01924016 THRTNUSR EQU 184 OFFSET IN IBCOM TO USER'S REG13 01926016 IBCSV EQU X'C4' OFFSET IN IBCOM TO ERR. SAVEAREA 01928016 ENDFILE EQU X'10C' OFFSET IN IBCOM TO ENDFILE 01930016 * AND IO ERROR EXITS 01932016 ER904 EQU X'6C' OFFSET IN IBCOM TO ROUTINE WHICH 01934016 * PUTS OUT MESSAGE 904 01936016 EJECT 01940000 * CALLING SEQUENCE 01960000 * L L,=V(FRDNL#) 01980000 * OR 02000000 * L L,=V(FWRNL#) 02020000 * CNOP 2,4 02040000 * BALR R,L 02060000 * DC XL0.4'PI',XL0.4'UI',AL3(UNIT) 02080000 * DC AL4(NAMELIST) 02100000 * DC AL4(EOFADD) OPTIONAL 02120000 * DC AL4(ERRADD) OPTIONAL 02140000 * WHERE PI = X'0' IF NEITHER EOF NOR ERR, 02160000 * X'1' IF EOF ONLY, 02180000 * X'2' IF ERR ONLY, 02200000 * X'3' IF BOTH EOF AND ERR. 02220000 * UI = X'0' IF UNIT IS AN INTEGER CONSTANT, 02240000 * X'1' IF UNIT IS A VARIABLE NAME, 02260000 * X'4' IF UNIT IS A STANDARD SYSTEMS UNIT. 02280000 SPACE 3 02300000 * ERROR CONDITIONS 02320000 * INVALID INPUT IN VARIABLE NAME POSITION. 02340000 * INPUT VARIABLE NAME NOT IN NAMELIST DICTIONARY. 02360000 * NO DELIMITER FOR INPUT NAME OR SUBSCRIPT. 02380000 * SUBSCRIPT FOLLOWS SCALAR OR EXCEEDS ARRAY LIMITS. 02400000 * FOR OTHERS, SEE FIOCS ROUTINE. 02420000 EJECT 02440000 * 02460000 FRDNL# DS 0F 02480000 USING *,15 02486016 B STARTRD BRANCH AROUND NAME 02492016 DC AL1(6) LENGTH OF NAME 02498016 DC C'FRDNL#' NAME OF ENTRY 02504016 STARTRD DS 0H 02510016 STM 14,13,SAVENL SAVE MAIN REGISTERS 02516016 DROP 15 02522016 USING FRDNL#,L 02528016 LR L,15 SET UP BASE FOR ADDRESSABILITY 02534016 L NDICTX,4(0,R) SET POINTER TO DICTIONARY 02541016 L IBBS,NIBCOM GET IBCOM ADDRESS AND CHECK TO 02548016 CLI FRTNUSR(IBBS),X'FF' INSURE THAT USER IS NOT DOING 02555016 BE MOVEC1 I/O DURING AN I/O ERROR FIXUP. 02562016 L GRX,ER904(0,IBBS) IF HE IS GO TO GIVE ERROR 02569016 BR GRX MESSAGE 904 AND TERMINATE JOB. 02576016 MOVEC1 EQU * 02583016 MVC FRTNUSR(64,IBBS),SAVENL MOVE REGS TO IBCOM SAVE AREA 02590016 LA GRY,8 SET UP MINIMUM PARAMETER LIST 02597016 * LENGTH FOR IBCOM 02604016 L GRX,X'C4'(0,IBBS) GET ADDRESS OF IBCOM ROUTINE 02611016 BALR 13,GRX TO FILL IN EOF AND I/O 02618016 ST R,SAVENL ERROR ADDR AND GO THERE 02625016 BALR 0,1 INITIALIZE FILE 02640000 DC AL1(INIT) 02660000 DC AL1(FMTINP) 02680000 B NEXIT IF ERROR SKIP NAMELIST CALL 02690016 NAMCRD LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 02700000 CLI 1(GRX),X'50' 02720000 BC EQUAL,NAMCOL BRANCH IF COL. 2 = AMPERSAND 02740000 CLI 1(GRX),C'$' 02760000 BC EQUAL,NAMCOL BRANCH IF COL. 2 = DOLLAR SIGN 02780000 READON L 1,NFIOCS 02800000 BALR 0,1 KEEP READING 02820000 DC AL1(READ) 02840000 DC AL1(NULL) 02860000 B NEXIT IF ERROR SKIP NAMELIST CALL 02870016 BC ALWAYS,NAMCRD 02880000 * 02900000 NAMCOL LA CHRCNT,8 8-CHARACTER NAMELIST NAME 02920000 LA GRX,2(0,GRX) 02940000 LM EVEN,ODD,BLANKS 02960000 NAMNAM CLI 0(GRX),C' ' 02980000 BC EQUAL,SETNAM BLANK TERMINATES 03000000 SLDL EVEN,8 03020000 IC ODD,0(0,GRX) INSERT NEW CHARACTER 03040000 LA GRX,1(0,GRX) INCREMENT BUFFER POINTER 03060000 BCT CHRCNT,NAMNAM 03080000 SETNAM STM EVEN,ODD,VNAME STASH NAMELIST NAME 03100000 CLC VNAME(8),0(NDICTX) 03120000 BC NOTEQ,READON BRANCH IF NOT NAMELIST NAME 03140000 LA BUFPTR,1(0,GRX) INITIALIZE RECORD POINTER 03160000 LA NDICTX,8(0,NDICTX) BUMP DICTIONARY POINTER, 03180000 ST NDICTX,DICTX AND SAVE IT FOR SEARCH. 03200000 NAMEIN SR LOOP,LOOP 03220000 SR NUMBER,NUMBER 03240000 MVI NOSWCH,OFF 1869 03250014 * 03260000 GETNAM MVI VSUBSW,OFF SET SUBSCRIPT SWITCH OFF 03280000 MVI ENDSW,OFF SET FOR NAME BRANCH 03300000 LA CHRCNT,8 8-CHARACTER VARIABLE NAME 03320000 LM EVEN,ODD,BLANKS 03340000 VARNAM CLI 0(BUFPTR),C' ' 03360000 BC EQUAL,SKPBLK SKIP BLANKS 03380000 CLI 0(BUFPTR),C',' 03400000 BC EQUAL,SKPBLK IGNORE COMMAS 03420000 CLI 0(BUFPTR),X'50' 03440000 BC EQUAL,ENDCOL BRANCH IF AMPERSAND 03460000 CLI 0(BUFPTR),C'$' 03480000 BC EQUAL,ENDCOL BRANCH IF DOLLAR SIGN 03500000 CLI 0(BUFPTR),C'(' 03520000 BC EQUAL,VARSUB BRANCH IF LEFT PARENTHESIS 03540000 CLI 0(BUFPTR),X'6C' 03560000 BC EQUAL,VARSUB BRANCH IF BCD LEFT PAREN 03580000 CLI 0(BUFPTR),C'=' 03600000 BC EQUAL,SEARCH BRANCH IF EQUAL SIGN 03620000 CLI 0(BUFPTR),X'7B' 03640000 BC EQUAL,SEARCH BRANCH IF BCD EQUAL SIGN 03660000 * 03680000 GETCHR LTR CHRCNT,CHRCNT 03700000 BC ZERO,BADNAM BRANCH IF NAME TOO LONG 03720000 SLDL EVEN,8 03740000 IC ODD,0(0,BUFPTR) INSERT NEW CHARACTER 03760000 BCTR CHRCNT,0 03780000 SKPBLK LA BUFPTR,1(0,BUFPTR) INCREMENT BUFFER POINTER 03800000 CR BUFPTR,BUFLIM 03820000 BC LOW,VARNAM 03840000 CH CHRCNT,EIGHT 03860000 BC EQUAL,ENDCRD NO NAME PRESENT 03880000 BC ALWAYS,NDELIM1 03900016 * 03920000 VARSUB MVI VSUBSW,ON SET SUBSCRIPT SWITCH ON 03940000 SEARCH L NDICTX,DICTX RESET DICTIONARY POINTER 03960000 STM EVEN,ODD,VNAME STASH VARIABLE NAME 03980000 ENDMRK CLC 0(4,NDICTX),ZEROS 04000000 BC EQUAL,NONAME BRANCH IF NAME NOT FOUND 04020000 CLC VNAME(8),0(NDICTX) 04040000 BC EQUAL,NFOUND BRANCH IF FOUND 04060000 BAL CALLER,BUMPDX BUMP DICTIONARY POINTER 04080000 BC ALWAYS,ENDMRK 04100000 * 04120000 NFOUND MVC RDPARS(1),13(NDICTX) USING TYPE FROM DICTIONARY, 04140000 TR RDPARS(1),LENGTH SET ITEM LENGTH. 04160000 MVC RDPARS+2(1),13(NDICTX) 04180000 TR RDPARS+2(1),INFORM 04200000 BAL CALLER,ADDSET PROCESS ADDRESS 04220000 TM VSUBSW,ON 04240000 BC NONE,SCANUM BRANCH IF NO SUBSCRIPT EXISTS 04260000 TM 12(NDICTX),ON 04280000 BC NONE,BADSUB BRANCH IF NOT ARRAY NAME 04300000 * 04320000 SR NODIM,NODIM 04340000 IC NODIM,14(0,NDICTX) GET NUMBER OF DIMENSIONS 04360000 LA SUBDCT,16(0,NDICTX) 04380000 SR ODD,ODD 04400000 IC ODD,15(0,NDICTX) GET LENGTH OR SPAN 04420000 ST ODD,COMPUT 04440000 NEWSUB LA NUMBER,1 ASSUME SUBSCRIPT OF ONE 04460000 SR WIDTH,WIDTH INITIALIZE WIDTH 04480000 LA BUFPTR,1(0,BUFPTR) 04500000 ST BUFPTR,NUMADD SAVE START OF NUMBER 04520000 SCNSUB CR BUFPTR,BUFLIM 04540000 BC HIEQ,NDELIM END OF RECORD 04560000 CLI 0(BUFPTR),C',' 04580000 BC EQUAL,ONESUB BRANCH IF COMMA 04600000 CLI 0(BUFPTR),C')' 04620000 BC EQUAL,ENDSUB BRANCH IF RIGHT PARENTHESIS 04640000 CLI 0(BUFPTR),X'4C' 04660000 BC EQUAL,ENDSUB BRANCH IF BCD RIGHT PAREN 04680000 LA WIDTH,1(0,WIDTH) 04700000 LA BUFPTR,1(0,BUFPTR) 04720000 BC ALWAYS,SCNSUB 04740000 * 04760000 ONESUB BAL CALLBY,GETINT CONVERT SUBSCRIPT ELEMENT 04780000 BCTR NUMBER,0 SUBSCRIPT ELEMENT MINUS ONE, 04800000 MR EVEN,NUMBER TIMES DIMENSION-LENGTH. 04820000 AR GRX,ODD ADD TO ARRAY ADDRESS 04840000 TM 16(NDICTX),X'FF' 04860000 BC NONE,DIMSUB BRANCH IF VARIABLE DIMENSIONS 04880000 CH NODIM,ONE NUM OF DIMENSIONS=1? A44648 04886021 BE BMPDCT YES,DON'T UPDATE PTR IN NAEMLIST DICT A44648 04892021 L LOOP,4(0,SUBDCT) 04900000 L ODD,0(0,LOOP) PICKUP D(N-1) * L 04920000 BMPDCT LA SUBDCT,4(0,SUBDCT) 04940000 BCT NODIM,NEWSUB GET NEXT SUBSCRIPT, 04960000 BC ALWAYS,SCNEND UNLESS DIMENSIONS EXHAUSTED. 04980000 DIMSUB L LOOP,0(0,SUBDCT) 05000000 L ODD,0(0,LOOP) PICKUP D(N-1), 05020000 M EVEN,COMPUT AND COMBINE IT. 05040000 ST ODD,COMPUT 05060000 BC ALWAYS,BMPDCT 05080000 * 05100000 ENDSUB BAL CALLBY,GETINT CONVERT SUBSCRIPT ELEMENT 05120000 BCTR NUMBER,0 SUBSCRIPT ELEMENT MINUS ONE, 05140000 MR EVEN,NUMBER TIMES DIMENSION-LENGTH. 05160000 AR GRX,ODD ADD TO ARRAY ADDRESS 05180000 SCNEND SR EVEN,EVEN 05200000 LR ODD,GRX 05220000 S ODD,NAMADD COMPUTE BYTES SKIPPED 05240000 S ODD,MAXSIZ 05260000 BC ZPLUS,BADSUB BRANCH IF OUTSIDE RANGE 05280000 LCR ODD,ODD 05300000 ST ODD,MAXSIZ SET BYTES REMAINING 05320000 DR EVEN,ADDER 05340000 LR LOOP,ODD GET NUMBER OF ELEMENTS 05360000 SKPEND LA BUFPTR,1(0,BUFPTR) 05380000 CR BUFPTR,BUFLIM 05400000 BC HIEQ,NDELIM END OF RECORD 05420000 CLI 0(BUFPTR),C'=' 05440000 BC EQUAL,SCANUM BRANCH IF EQUAL SIGN 05460000 CLI 0(BUFPTR),X'7B' 05480000 BC NOTEQ,SKPEND BRANCH IF NOT BCD EQUAL 05500000 * 05520000 SCANUM MVI NOSWCH,ON SET SWITCH FOR NEW NUMBER 9921 05530013 LA BUFPTR,1(BUFPTR) INCREMENT BUFFER POINTER 9921 05540013 CR BUFPTR,BUFLIM AT END OF RECORD 05560000 BL NEWNUM NO, BRANCH 9921 05590013 ENDCRD ST GRX,NAMADD 05620000 L 1,NFIOCS 05640000 BALR 0,1 READ ONE RECORD 05660000 DC AL1(READ) 05680000 DC AL1(NULL) 05700000 B NEXIT IF ERROR SKIP NAMELIST CALL 05710016 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 05720000 LA BUFPTR,1(0,GRX) INITIALIZE RECORD POINTER 05740000 L GRX,NAMADD 05760000 * 05780000 SCNCRD TM NOSWCH,ON 05800000 BC ALL,NEWNUM NEW NUMBER EXPECTED 05820000 LTR LOOP,LOOP CONTINUE NUMBER SCAN 05840000 BC ZMINUS,GETNAM UNTIL ARRAY IS EXHAUSTED. 05860000 LTR NUMBER,NUMBER 05880000 BC PLUS,BEGNUM BRANCH IF REPEAT CONSTANT 05900000 NEWNUM LA NUMBER,1 ASSUME NO REPEAT CONSTANT 05920000 BEGNUM SR WIDTH,WIDTH INITIALIZE WIDTH 05940000 NOBLNK CLI 0(BUFPTR),C' ' 05960000 BC NOTEQ,BEGFLD BRANCH IF NON-BLANK 05980000 LA BUFPTR,1(0,BUFPTR) 06000000 CR BUFPTR,BUFLIM 06020000 BC LOW,NOBLNK SKIP LEADING BLANKS 06040000 BC ALWAYS,ENDCRD 06060000 * 06080000 BEGFLD MVI NOSWCH,OFF 06100000 ST BUFPTR,NUMADD SAVE START OF NUMBER 06120000 FLDSIZ CLI 0(BUFPTR),C'=' 06140000 BC EQUAL,GOBACK BRANCH IF EQUAL SIGN 06160000 CLI 0(BUFPTR),X'7B' 06180000 BC EQUAL,GOBACK BRANCH IF BCD EQUAL SIGN 06200000 CLI 0(BUFPTR),C'(' 06220000 BC EQUAL,SUBCHK BRANCH IF LEFT PARENTHESIS 06240000 CLI 0(BUFPTR),X'6C' 06260000 BC EQUAL,SUBCHK BRANCH IF BCD LEFT PAREN 06280000 CLI 0(BUFPTR),C'*' 06300000 BC EQUAL,KCONST BRANCH IF ASTERISK 06320000 CLI 0(BUFPTR),C',' 06340000 BC EQUAL,COMPLX BRANCH IF COMMA 06360000 CLI 0(BUFPTR),X'50' 06380000 BC EQUAL,ENDCHK BRANCH IF AMPERSAND 06400000 CLI 0(BUFPTR),C'$' 06420000 BC EQUAL,ENDCHK BRANCH IF DOLLAR SIGN 06440000 CLI 0(BUFPTR),C'Z' 06460000 BC EQUAL,HEXNUM BRANCH IF CHAR Z 06480000 CLI 0(BUFPTR),C'H' 06500000 BC EQUAL,HOLLER BRANCH IF CHAR H 06520000 CLI 0(BUFPTR),C'''' 06540000 BC EQUAL,NQUOTE BRANCH IF QUOTE 06560000 CLI 0(BUFPTR),X'7C' 06580000 BC EQUAL,NQUOTE BRANCH IF BCD QUOTE 06600000 * 06620000 KEEPON LA WIDTH,1(0,WIDTH) 06640000 LA BUFPTR,1(0,BUFPTR) 06660000 CR BUFPTR,BUFLIM 06680000 BC LOW,FLDSIZ COLLECT FIELD WIDTH 06700000 SCNBCK BCTR BUFPTR,0 BACKUP IN BUFFER 06720000 CLI 0(BUFPTR),C' ' 06740000 BC NOTEQ,CONVRT BRANCH IF NON-BLANK 06760000 BCTR WIDTH,0 06780000 BC ALWAYS,SCNBCK RIGHT-ADJUST NUMBER 06800000 * 06820000 COMPLX TM COMPSW,ON 06840000 BC ALL,CONVRT BRANCH IF NOT FIRST COMMA 06860000 TM 13(NDICTX),X'08' 06880000 BC NONE,NULCOM 06900000 MVI COMPSW,ON SET FIRST COMMA SWITCH 06920000 BC ALWAYS,KEEPON 06940000 NULCOM LTR WIDTH,WIDTH 06960000 BC PLUS,CONVRT BRANCH ON MEANINGFUL COMMA 06980000 LA WIDTH,BLANKS 07000000 ST WIDTH,NUMADD FORCE ZERO INPUT 07020000 LA WIDTH,1 07040000 * 07060000 CONVRT MVI COMPSW,OFF 07080000 L GRY,NUMADD PICKUP BUFFER POSITION 07100000 SR BASE,BASE 07120000 IC BASE,13(0,NDICTX) 07140000 TM HEXSW,ON 07160000 BC NONE,SHIFTB BRANCH IF NOT HEX 07180000 MVI HEXSW,OFF 07200000 LA GRY,1(0,GRY) POSITION PAST Z, 07220000 BCTR WIDTH,0 AND CONVERT DATA. 07240000 MVI RDPARS+2,X'07' 07260000 LA BASE,11 07280000 SHIFTB SLA BASE,3 07300000 STC WIDTH,RDPARS+1 SET WIDTH 07320000 L 1,VADCON 07340000 L 1,0(BASE,1) SELECT CONVERSION 07360000 BALR 0,1 APPROPRIATE TO TYPE. 07380000 RDPARS DC AL4(0) 07400000 ENDLIT L SPILL,MAXSIZ 07420000 BCT NUMBER,REPEAT 07440000 ENDNUM AR GRX,ADDER INCREMENT ARRAY ADDRESS, 07460000 BCTR LOOP,0 AND DECREMENT ITEM COUNT. 07480000 SR SPILL,ADDER 07500000 ST SPILL,MAXSIZ 07520000 LA BUFPTR,1(0,BUFPTR) 07540000 CR BUFPTR,BUFLIM AT END OF RECORD 07560000 BC HIEQ,ENDCRD YES 07580000 BC ALWAYS,SCNCRD NO, SCAN ON. 07600000 * 07620000 REPEAT LTR LOOP,LOOP 07640000 BC ZMINUS,ENDNUM 07660000 SR BASE,BASE 07680000 IC BASE,RDPARS 07700000 BCTR BASE,0 07720000 REPARR BCT LOOP,REPDAT CONTINUE PROCESSING ARRAY, 07740000 BC ALWAYS,ENDNUM UNTIL IT IS EXHAUSTED. 07760000 REPDAT LA GRY,0(ADDER,GRX) GET ADDRESS OF NEXT ARRAY ITEM 07780000 EX BASE,REPMOV 07800000 SR SPILL,ADDER 07820000 LR GRX,GRY INCREMENT ARRAY ADDRESS 07840000 BCT NUMBER,REPARR 07860000 BC ALWAYS,ENDNUM BRANCH WHEN K IS EXHAUSTED 07880000 * 07900000 KCONST BAL CALLBY,GETINT CONVERT K TO AN INTEGER 07920000 LA BUFPTR,1(0,BUFPTR) 07940000 CR BUFPTR,BUFLIM 07960000 BC HIEQ,ENDCRD END OF RECORD 07980000 BC ALWAYS,BEGNUM 08000000 * 08020000 HEXNUM MVI HEXSW,ON SET FOR HEX CONVERT 08040000 BC ALWAYS,KEEPON 08060000 * 08080000 HOLLER LTR WIDTH,WIDTH IF WIDTH IS ZERO, 08100000 BC ZMINUS,GOBACK ASSUME NAME FIELD. 08120000 ST NUMBER,COMPUT 08140000 LR NUMBER,WIDTH SCAN FOR NON-NUMERIC 08160000 L SPILL,NUMADD 08180000 HSCAN CLI 0(SPILL),C' ' 08200000 BC EQUAL,HCONT SKIP BLANKS 08220000 CLI 0(SPILL),C'0' 08240000 BC LOW,GOBACK 08260000 CLI 0(SPILL),C'9' 08280000 BC HIGH,GOBACK 08300000 HCONT LA SPILL,1(0,SPILL) 08320000 BCT NUMBER,HSCAN CHECK ENTIRE COUNT FIELD 08340000 ST GRX,NAMADD 08360000 BAL CALLBY,GETINT CONVERT COUNT TO INTEGER 08380000 LR WIDTH,NUMBER 08400000 BAL CALLBY,LITRAL MOVE IN LITERAL 08420000 L NUMBER,COMPUT 08440000 BC ALWAYS,LITEND 08460000 * 08480000 NQUOTE ST GRX,NAMADD 08500000 MVI QSTOP,OFF TURN OFF STOP SWITCH 08520000 MVC QUOTE(1),0(BUFPTR) 08540000 BEGQ ST BUFPTR,NUMADD SAVE BUFFER POINTER 08560000 SR WIDTH,WIDTH INITIALIZE COUNT 08580000 QSEEK CLC 1(1,BUFPTR),QUOTE 08600000 BC EQUAL,QMATCH BRANCH IF QUOTE 08620000 LA WIDTH,1(0,WIDTH) INCREMENT COUNT 08640000 LA BUFPTR,1(0,BUFPTR) AND BUFFER POINTER. 08660000 BC ALWAYS,QSEEK 08680000 QMATCH CLC 2(1,BUFPTR),QUOTE 08700000 BC NOTEQ,ENDQ BRANCH IF NOT QUOTE PAIR 08720000 LA WIDTH,1(0,WIDTH) INCREMENT COUNT 08740000 BC ALWAYS,ENDQ+4 08760000 ENDQ MVI QSTOP,ON TURN ON STOP SWITCH 08780000 L BUFPTR,NUMADD 08800000 BAL CALLBY,LITRAL MOVE IN LITERAL 08820000 TM QSTOP,ON 08840000 BC NONE,BEGQ PROCESS NEXT PART OF LITERAL 08860000 LA BUFPTR,1(0,BUFPTR) 08880000 * 08900000 LITEND CR BUFPTR,BUFLIM 08920000 BC HIEQ,TSTMAX END OF RECORD 08940000 CLI 0(BUFPTR),C',' 08960000 BC EQUAL,TSTMAX BRANCH IF COMMA 08980000 CLI 0(BUFPTR),C' ' 09000000 BC NOTEQ,BACKUP BRANCH IF NON-BLANK 09020000 LA BUFPTR,1(0,BUFPTR) 09040000 BC ALWAYS,LITEND 09060000 BACKUP BCTR BUFPTR,0 09080000 * 09100000 TSTMAX L SPILL,MAXSIZ GET REMAINING SIZE OF ARRAY 1/14 60621 09120021 LTR SPILL,SPILL ANYTHING REMAINING 2/14 60621 09130021 BC ZERO,GETADD NO - NOTHING TO BLANK 3/14 60621 09140021 SRDA SPILL,32 4/14 60621 09150021 DR SPILL,ADDER GET ANY PORTION OF ELEMENT NOT 5/14 60621 09160021 * FILLED BY LITERAL MOVE 09170021 LTR SPILL,SPILL ANYTHING NOT FILLED 6/14 60621 09180021 BC ZERO,GETADD NO 7/14 60621 09190021 LR BASE,GRX POINT TO START OF REMAINING ARRAY 8/14 60621 09200021 BLNKIT MVI 0(BASE),C' ' FILL REMAINDER OF ELEMENT WITH 9/14 60621 09210021 * BLANKS-DO NOT FILL REMAINDER OF ARRAY 09220021 LA BASE,1(BASE) INCREMENT LOOP CONTROL 10/14 60621 09230021 BCT SPILL,BLNKIT CONTINUE BLANKING REST OF ELEMENT 11/14 60621 09240021 GETADD L GRX,NAMADD PICKUP INITIAL ADDRESS 12/14 60621 09250021 LR ODD,LOOP 09300000 MR EVEN,ADDER 09320000 ST ODD,MAXSIZ RESET REMAINING SIZE 09340000 BC ALWAYS,ENDLIT 09360000 * 09380000 LITRAL TM VSUBSW,ON BRANCH IF NOT SUBSCRIPTED 13/14 60621 09387021 BC NONE,LITRAL1 ARRAY NAME 14/14 60621 09391021 C ADDER,MAXSIZ UNLESS FILLING TERMINAL 21100 09395018 BC HIEQ,LITRAL1 ELEMENT OR MOVING OTHER 21100 09400018 * THAN 1ST PART OF LITERAL, 21100 09405018 ST ADDER,MAXSIZ SET MAXSIZ TO ELEMENT LNGTH21100 09410018 LITRAL1 LTR CHRCNT,WIDTH CHECK COUNT 21100 09415018 LA BUFPTR,1(0,BUFPTR) 09420000 BCR ZMINUS,CALLBY 09440000 C CHRCNT,MAXSIZ CAN ALL CHARACTERS BE MOVED 09480000 BC LOEQ,DOWNIT YES 09500000 L CHRCNT,MAXSIZ NO, MOVE AS MANY AS POSSIBLE. 09520000 DOWNIT BCTR CHRCNT,0 09540000 EX CHRCNT,LITMOV EXECUTE MOVE 09560000 LA CHRCNT,1(0,CHRCNT) 09580000 AR GRX,CHRCNT INCREMENT ITEM ADDRESS 09600000 AR BUFPTR,WIDTH AND BUFFER POINTER. 09620000 S CHRCNT,MAXSIZ 09640000 LCR CHRCNT,CHRCNT 09660000 ST CHRCNT,MAXSIZ RESET MAXIMUM FOR MOVE 09680000 BCR ALWAYS,CALLBY 09700000 * 09720000 SUBCHK LTR WIDTH,WIDTH NON-ZERO WIDTH INDICATES 09740000 BC ZMINUS,KEEPON SUBSCRIPTED NAME. 09760000 GOBACK L BUFPTR,NUMADD 09780000 MVI HEXSW,OFF 09800000 BC ALWAYS,NAMEIN 09820000 * 09840000 ENDCHK EQU * A38316 09848021 CLC 1(3,BUFPTR),END A38316 09856021 BNE KEEPON A38316 09864021 LTR WIDTH,WIDTH A38316 09872021 BC PLUS,SCNBCK NUMBER NEEDS CONVERSION. 09880000 MVI ENDSW,ON SET FOR NUMBER BRANCH 09900000 * 09920000 ENDCOL CLC 1(3,BUFPTR),END 4754 10020017 BC EQUAL,NLOUT BRANCH IF END 10140000 TM ENDSW,ON 10160000 BC NONE,GETCHR RETURN TO PROCESS NAME 10180000 MVI ENDSW,OFF RESET SWITCH, 10200000 BC ALWAYS,KEEPON AND RETURN TO PROCESS NUMBER. 10220000 NLOUT EQU * 10230016 NEXIT L IBBS,NIBCOM GET ADDR OF IBCOM 10240016 SR GRX,GRX 10250016 SR GRY,GRY 10260016 STM GRX,GRY,ENDFILE(IBBS) CLEAR OUT EOF AND IO ERR PTRS 10270016 MVI FRTNUSR(15),X'FF' RESET I/O ENDED SWITCH IN IBCOM 10280016 LM 14,13,SAVENL RESTORE MAIN REGISTERS 10290016 BCR ALWAYS,R RETURN TO MAIN PROGRAM 10360000 * 10380000 * 10480000 GETINT LTR WIDTH,WIDTH 10500000 BCR ZMINUS,CALLBY 10520000 STC WIDTH,KCPARS+1 SET NON-ZERO WIDTH 10540000 STM 2,3,CVREGS 10560000 LA GRX,KSTORE PICKUP ITEM ADDRESS 10580000 L GRY,NUMADD AND BUFFER POSITION. 10600000 L 1,VADCON 10620000 L 1,40(0,1) 10640000 BALR 0,1 USE I-CONVERSION 10660000 KCPARS DC XL2'0400' 10680000 L NUMBER,KSTORE PICKUP THE RESULTING CONSTANT 10700000 LM 2,3,CVREGS 10720000 BCR ALWAYS,CALLBY 10740000 * 10760000 BADNAM SH BUFPTR,EIGHT RESET TO BEGINNING OF NAME 10770016 MVC MSG221M(8),0(BUFPTR) MOVE NAME TO MESSAGE 10780016 LA 1,PRMS221 GIVE MESSAGE 221 10790016 B COMINTFC 10800016 NONAME MVC MSG222M(8),VNAME MOVE NAME INTO MESSAGE 10810016 LA 1,PRMS222 GIVE MESSAGE 222 10820016 B COMINTFC 10830016 NDELIM1 STM EVEN,ODD,VNAME STASH VARIABLE NAME 10840016 NDELIM MVC MSG223M(8),VNAME MOVE NAME INTO MESSAGE 10850016 LA 1,PRMS223 GIVE MESSAGE 223 10860016 B COMINTFC 10870016 BADSUB MVC MSG224M(8),VNAME MOVE NAME INTO MESSAGE 10880016 LA 1,PRMS224 GIVE MESSAGE 224 10890016 COMINTFC L IBBS,NIBCOM GET IBCOM ADDRESS 10900016 L 14,DSRNOF(0,IBBS) GET UNIT NO. FROM IBCOM AREA 10910016 ST 14,DSRNPTR (PUT THERE BY FIOCS) 10920016 L 13,THRTNUSR(0,IBBS) GET USERS REG 13 10930016 MVC 12(16,13),FRTNUSR(IBBS) MOVE USER'S 14 + 15 TO HIS 10940016 ST 13,IBCSV+4(0,IBBS) SAVE AREA. LINK SAVE AREAS 10950016 LA 13,IBCSV(0,IBBS) GET ADDRESS OF SAVE AREA FOR 10960016 L IBBS,VIHCERRM ERROR MONITOR. 10970016 BALR 14,IBBS LINK TO ERROR MONITOR 10980016 B NEXIT EXIT. 10990016 * 11080000 EJECT 11100000 * 11120000 FWRNL# DS 0F 11140000 USING *,15 11146016 B STARTWR BRANCH AROUND NAME 11152016 DC AL1(6) LENGTH OF NAME 11158016 DC C'FWRNL#' NAME 11164016 STARTWR DS 0H 11170016 STM 14,13,SAVENL SAVE MAIN REGISTERS 11176016 DROP 15 11182016 USING FWRNL#,L 11188016 LR L,15 SET BASE FOR ADDRESSABILITY 11194016 L NDICTX,4(0,R) SET POINTER TO DICTIONARY 11201016 L IBBS,NIBCOM GET ADDRESS OF IBCOM AND CHECK 11208016 CLI FRTNUSR(IBBS),X'FF' TO INSURE THAT USER IS NOT TRY- 11215016 BE MOVEC2 ING TO DO I/O FROM A FIXUP ROUTN 11222016 L GRX,ER904(0,IBBS) FOR AN I/O TYPE ERROR. IF HE IS 11229016 BR GRX GIVE MESSAGE 904 , TERMINATE JOB 11236016 MOVEC2 EQU * 11243016 MVC FRTNUSR(64,IBBS),SAVENL MOVE REGS TO IBCOM SAVE AREA 11250016 L GRX,X'C4'(0,IBBS) GO TO IBCOM TO INITIALIZE WRITE 11257016 LA GRY,8 SET UP MINIMUM PARAMETER LIST 11264016 * LENGTH FOR IBCOM 11271016 BALR 13,GRX 11278016 ST R,SAVENL SAVE RETURN REGISTER 11285016 BALR 0,1 INITIALIZE FILE 11300000 DC AL1(INIT) 11320000 DC AL1(FMTOUT) 11340000 B OEXIT IF ERROR EXIT 11350016 MVC 0(2,GRX),AMPER 11360000 LA CHRCNT,7 11380000 LR SUBDCT,NDICTX 11400000 BLNKT1 CLI 0(SUBDCT),C' ' ELIMINATE LEADING BLANKS 11420000 BC NOTEQ,NAMALL FROM NAMELIST NAME. 11440000 LA SUBDCT,1(0,SUBDCT) 11460000 BCT CHRCNT,BLNKT1 11480000 NAMALL EX CHRCNT,EXMOV1 MOVE NAMELIST NAME 11500000 LA GRX,5(0,CHRCNT) 1869 11520014 BAL CALLER,NAMOUT WRITE &NAMELIST NAME 11540000 LA NDICTX,8(0,NDICTX) BUMP DICTIONARY POINTER 11560000 CLC 0(4,NDICTX),ZEROS 11580000 BC EQUAL,VARSET BRANCH IF END MARK 11600000 * 11620000 VARSET MVC WRPARS(1),13(NDICTX) USING TYPE FROM DICTIONARY, 11640000 TR WRPARS(1),LENGTH SET ITEM LENGTH. 11660000 SR BASE,BASE 11680000 IC BASE,13(0,NDICTX) 11700000 SLA BASE,1 11720000 LA SPILL,NLFORM(BASE) AGAIN USING TYPE (*2), 11740000 MVC WRPARS+1(2),0(SPILL) SET STANDARD FORMAT. 11760000 SLA BASE,2 ADJUST TO DOUBLE WORD 11780000 L 1,VADCON 11800000 L 1,4(BASE,1) 11820000 ST 1,NADCON SAVE CONVERSION ADCON 11840000 LA LOOP,1 INITIALIZE FOR SINGLE ITEM 11860000 BAL CALLER,ADDSET PROCESS ADDRESS 11880000 * 11900000 LA CHRCNT,7 11920000 LR SUBDCT,NDICTX 11940000 BLNKT2 CLI 0(SUBDCT),C' ' ELIMINATE LEADING BLANKS 11960000 BC NOTEQ,NAMTST FROM VARIABLE NAME. 11980000 LA SUBDCT,1(0,SUBDCT) 12000000 BCT CHRCNT,BLNKT2 12020000 NAMTST LA SPILL,2(CHRCNT,BUFPTR) 12040000 CR SPILL,BUFLIM IS THERE ROOM FOR NAME= 12060000 BC LOW,NAMSET YES 12080000 STM 2,3,CVREGS 12100000 BAL CALLER,NOROOM NO, DUMP CURRENT RECORD. 12120000 LM 2,3,CVREGS 12140000 NAMSET EX CHRCNT,EXMOV2 MOVE VARIABLE NAME 12160000 LA BUFPTR,1(CHRCNT,BUFPTR) 12180000 MVI 0(BUFPTR),C'=' SET EQUAL SIGN 12200000 LA BUFPTR,1(0,BUFPTR) 12220000 * 12240000 NUMTST SR SPILL,SPILL 12260000 IC SPILL,WRPARS+1 PICKUP PROPOSED WIDTH 12280000 AR SPILL,BUFPTR 12300000 CR SPILL,BUFLIM IS THERE ROOM FOR NUMBER 12320000 BC LOW,NUMSET YES 12340000 ST GRX,NUMADD 12360000 BAL CALLER,NOROOM NO, DUMP CURRENT RECORD. 12380000 L GRX,NUMADD 12400000 NUMSET L 1,NADCON SELECT CONVERSION 12420000 LR GRY,BUFPTR 12440000 BALR 0,1 12460000 WRPARS DC AL4(0) 12480000 SR SPILL,SPILL 12500000 IC SPILL,WRPARS+1 12520000 AR BUFPTR,SPILL UPDATE RECORD POINTER 12540000 LA SPILL,1(0,BUFPTR) 12560000 CR SPILL,BUFLIM 12580000 BH SKPCOM 10509 12600013 MVI 0(BUFPTR),C',' SET COMMA 12620000 LR BUFPTR,SPILL 12640000 SKPCOM AR GRX,ADDER INCREMENT ARRAY ADDRESS 12660000 BCT LOOP,NUMTST AND DECREMENT ITEM COUNT. 12680000 BAL CALLER,BUMPDX BUMP DICTIONARY POINTER 12700000 CLC 0(4,NDICTX),ZEROS 12720000 BC NOTEQ,VARSET NOT END MARK 12740000 BCTR BUFPTR,0 12760000 CLI 0(BUFPTR),C',' 12780000 BC NOTEQ,ENDSET 12800000 MVI 0(BUFPTR),C' ' ERASE COMMA 12820000 * 12840000 ENDSET C BUFPTR,BUFPOS 12860000 BC LOEQ,SKPDMP BRANCH IF BUFFER IS EMPTY 12880000 BAL CALLER,NOROOM WRITE THE CURRENT RECORD 12900000 SKPDMP MVC 0(5,GRX),AMPER 12920000 LA GRX,5 12940000 L 1,NFIOCS 12960000 BALR 0,1 WRITE &END CARD 12980000 DC AL1(RITE) 13000000 DC AL1(NULL) 13020000 OEXIT L IBBS,NIBCOM GET ADDRESS OF IBCOM 13040016 SR GRX,GRX 13060016 SR GRY,GRY 13080016 STM GRX,GRY,ENDFILE(IBBS) CLEAR OUT EOF AND IO ERR PTRS 13100016 MVI FRTNUSR(15),X'FF' RESET I/O ENDED SWITCH IN IBCOM 13120016 LM 14,13,SAVENL RESTORE MAIN REGISTERS 13140016 BCR ALWAYS,R RETURN TO MAIN PROGRAM 13160000 * 13180000 * 13280000 NOROOM LR GRX,BUFPTR 13300000 S GRX,BUFPOS COMPUTE RECORD LENGTH 13320000 NAMOUT L 1,NFIOCS 13340000 BALR 0,1 WRITE ONE RECORD 13360000 DC AL1(RITE) 13380000 DC AL1(NULL) 13400000 B OEXIT IF ERROR EXIT 13410016 ST GRX,BUFPOS SAVE START OF RECORD 13420000 LA BUFLIM,0(GRY,GRX) COMPUTE END OF RECORD 13440000 MVI 0(GRX),C' ' SET FOR SINGLE SPACE 13460000 LA BUFPTR,1(0,GRX) INITIALIZE RECORD POINTER 13480000 BCR ALWAYS,CALLER 13500000 * 13520000 EJECT 13540000 * 13560000 BUMPDX BALR 1,0 13580000 USING *,1 13600000 SR SPILL,SPILL 13620000 TM 12(NDICTX),X'FF' 13640000 BC NONE,BUMPIT BRANCH IF NOT ARRAY 13660000 IC SPILL,14(0,NDICTX) 13680000 SLA SPILL,2 NUMBER OF DIMENSIONS * 4 13700000 BUMPIT LA NDICTX,16(SPILL,NDICTX) 13720000 BCR ALWAYS,CALLER 13740000 * 13760000 SPACE 3 13780000 * 13800000 ADDSET BALR 1,0 13820000 USING *,1 13840000 MVC NAMADD+1(3),9(NDICTX) 13860000 L GRX,NAMADD PICKUP ITEM ADDRESS 13880000 SR ADDER,ADDER 13900000 ST ADDER,MAXSIZ 13920000 MVC MAXSIZ+3(1),13(NDICTX) 13940000 TR MAXSIZ+3(1),LENGTH MAXIMUM = ELEMENT LENGTH 13960000 TM 12(NDICTX),ON 13980000 BCR NONE,CALLER BRANCH IF NOT ARRAY 14000000 TM 16(NDICTX),X'FF' 14020000 BC NONE,VARDIM BRANCH IF VARIABLE DIMENSIONS 14040000 SR EVEN,EVEN 14060000 L ODD,16(0,NDICTX) GET SIZE OF ARRAY 14080000 IC ADDER,15(0,NDICTX) AND ELEMENT LENGTH. 14100000 N ODD,SETOFF 14120000 ST ODD,MAXSIZ MAXIMUM = ARRAY SIZE 14140000 DR EVEN,ADDER DIVIDE SIZE BY ELEMENT LENGTH 14160000 VAROUT LR LOOP,ODD 14180000 BCR ALWAYS,CALLER 14200000 VARDIM LA SUBDCT,16(0,NDICTX) 14220000 L LOOP,0(0,SUBDCT) 14240000 L ODD,0(0,LOOP) PICKUP FIRST DIMENSION 14260000 IC ADDER,14(0,NDICTX) AND NUMBER OF DIMENSIONS. 14280000 BC ALWAYS,TSTDIM 14300000 GETSIZ LA SUBDCT,4(0,SUBDCT) POINT TO NEXT DIMENSION ADDRESS 14320000 L LOOP,0(0,SUBDCT) 14340000 M EVEN,0(0,LOOP) MULTIPLY IN NEXT DIMENSION 14360000 TSTDIM BCT ADDER,GETSIZ 14380000 LR EVEN,ODD 14400000 MH EVEN,MAXSIZ+2 NO. OF ELEMENTS * LENGTH 14420000 ST EVEN,MAXSIZ 14440000 IC ADDER,15(0,NDICTX) GET ITEM LENGTH OR ARRAY SPAN 14460000 BC ALWAYS,VAROUT 14480000 * 14500000 EJECT 14520000 * 14540000 * FORMAT WIDTH AND DECIMALS ACCORDING TO MODE / TYPE 14560000 * 14580000 NLFORM DS 0H 14600000 DC AL1(15) REAL * 4 14620000 DC AL1(8) 14640000 DC AL1(15) REAL * 4 14660000 DC AL1(8) 14680000 DC AL1(1) LOGICAL * 1 14700000 DC XL1'07' 14720000 DC AL1(1) LOGICAL * 4 14740000 DC XL1'07' 14760000 DC AL1(6) INTEGER * 2 14780000 DC XL1'07' 14800000 DC AL1(11) INTEGER * 4 14820000 DC XL1'07' 14840000 DC AL1(23) REAL * 8 14860000 DC AL1(16) 14880000 DC AL1(15) REAL * 4 14900000 DC AL1(8) 14920000 DC AL1(49) COMPLEX * 16 14940000 DC AL1(16) 14960000 DC AL1(33) COMPLEX * 8 14980000 DC AL1(8) 15000000 DC AL1(4) LITERAL 15020000 DC XL1'07' 15040000 * 15060000 EJECT 15080000 * 15100000 * DATA AND STORAGE AREAS 15120000 * 15140000 SAVENL DS 16F REGISTER STORAGE 15160000 NIBCOM DC A(IBCOM#) 15180000 NFIOCS DC A(FIOCS#) 15200000 VADCON DC A(ADCON#) 15220000 BLANKS DC CL8' ' 15240000 VNAME DS 2F 8-CHARACTER NAME 15260000 END DC C'END' 4754 15290017 DICTX DS 1F DICTIONARY POINTER 15320000 BUFPOS DS 1F START OF RECORD 15340000 CVREGS DS 2F TEMPORARY STORAGE 15360000 NADCON DS 1F ADCON STORAGE 15380000 COMPUT DS 1F DIMENSION COMPUTATION 15400000 MAXSIZ DS 1F SIZE OF ELEMENT OR ARRAY 15420000 NAMADD DS F'0' ITEM/ARRAY ADDRESS 15440000 NUMADD DS 1F START OF INPUT DATA 15460000 KSTORE DC AL4(0) REPEAT CONSTANT 15480000 SETOFF DC X'00FFFFFF' 15500000 EIGHT DC H'8' 15520000 LITMOV MVC 0(1,GRX),0(BUFPTR) MOVE IN LITERAL DATA 15540000 MOVREP MVC 0(1,GRX),0(GRY) REPEAT LITERAL FIELD 15560000 REPMOV MVC 0(1,GRY),0(GRX) MOVE IN CONVERTED DATA 15580000 EXMOV1 MVC 2(1,GRX),0(SUBDCT) 15600000 EXMOV2 MVC 0(1,BUFPTR),0(SUBDCT) 15620000 ONE DC H'1' A44648 15630021 ZEROS DC XL4'0' 15640000 AMPER DC X'4050' 15660000 DC C'END' 15680000 LENGTH DC X'0404010402040804100804' 15700000 INFORM DC X'0000070707070000000007' 15720000 NOSWCH DC AL1(0) NUMBER SWITCH 15740000 VSUBSW DC AL1(0) SUBSCRIPTED VARIABLE 15760000 COMPSW DC AL1(0) FIRST COMMA SWITCH 15780000 HEXSW DC AL1(0) HEXADECIMAL INPUT 15800000 QSTOP DC AL1(0) LAST QUOTE SWITCH 15820000 QUOTE DC AL1(0) QUOTE OR COMMERCIAL AT 15840000 ENDSW DC AL1(0) &END SWITCH 15860000 * 15880000 * 15880316 * 15880616 * PARAMETER LISTS FOR ERROR HANDLING AND NECESSARY CONSTANTS 15880916 * 15881216 * 15881516 PRMS221 DC A(MSG221) ADDRESS OF MESSAGE 15881816 DC A(RETCD) ADDRESS OF RETURN CODE FIELD 15882116 DC A(E221) ADDRESS OF ERROR MUMBER 15882416 DC XL1'80' LAST PARAMETER INDICATION 15882716 DC AL3(DSRNPTR) ADDRESS OF UNIT NUMBER(DSRN) 15883016 PRMS222 DC A(MSG222) 15883316 DC A(RETCD) 15883616 DC A(E222) 15883916 DC XL1'80' 15884216 DC AL3(DSRNPTR) 15884516 PRMS223 DC A(MSG223) 15884816 DC A(RETCD) 15885116 DC A(E223) 15885416 DC XL1'80' 15885716 DC AL3(DSRNPTR) 15886016 PRMS224 DC A(MSG224) 15886316 DC A(RETCD) 15886616 DC A(E224) 15886916 DC XL1'80' 15887216 DC AL3(DSRNPTR) 15887516 DSRNPTR DC F'0' 15887816 RETCD DC F'0' 15888116 E221 DC F'221' 15888416 E222 DC F'222' 15888716 E223 DC F'223' 15889016 E224 DC F'224' 15889316 VIHCERRM DC V(IHCERRM) ADDRESS OF ERROR MONITOR 15889616 EJECT 15889916 * 15890216 * 15890516 * TEXTS OF ERROR MESSAGES 15890816 * 15891116 * 15891416 MSG221 DC A(MSG221E-MSG221B) 15891716 MSG221B DC C'IHC221I NAMEL - NAME LARGER THAN EIGHT CHARACTERS. NAMX15892016 E=' 15892316 MSG221M DC C' ' 15892616 DC C'...' 15892916 MSG221E EQU * 15893216 MSG222 DC A(MSG222E-MSG222B) 15893516 MSG222B DC C'IHC222I NAMEL - NAME NOT IN NAMELIST DICTIONARY. NAME=X15893816 ' 15894116 MSG222M DC C' ' 15894416 MSG222E EQU * 15894716 MSG223 DC A(MSG223E-MSG223B) 15895016 MSG223B DC C'IHC223I NAMEL - END OF RECORD ENCOUNTERED BEFORE EQUALX15895316 SIGN. NAME=' 15895616 MSG223M DC C' ' 15895916 MSG223E EQU * 15896216 MSG224 DC A(MSG224E-MSG224B) 15896516 MSG224B DC C'IHC224I NAMEL - SUBSCRIPT FOR NON-DIMENSIONED VARIABLEX15896816 OR SUBSCRIPT OUT OF RANGE. NAME=' 15897116 MSG224M DC C' ' 15897416 MSG224E EQU * 15897716 END 15900000 ./ ADD SSI=03010990,NAME=IHCSASCN,SOURCE=0 TITLE ' ASCN ARC SIN-COS (SHORT) ' 00010018 IHCSASCN CSECT 00020000 * 00023019 * STATUS - CHANGE LEVEL 01, 10 APR 70 RELEASE 19 00026019 * 00029019 *0850 010800-011400 28132 00032019 * 00035019 * ARCSIN-ARCCOSINE FUNCTION (SHORT) 00040000 * 1. IF X BETWEEN 0 AND 1/2, COMPUTE ARCSIN BY POLYNOMIAL 00060000 * 2. IF X BETWEEN 1/2 AND 1, 00080000 * ARSIN(X) = PI/2-2*ARSIN(SQRT((1-X)/2)) 00100000 * 3. IF X NEGATIVE, ARSIN(X) = -ARSIN(/X/) 00120000 * 4. ARCOS(X) = PI/2-ARSIN(X) 00140000 EXTRN SQRT 00160000 EXTRN IBCOM# 00180000 EXTRN IHCERRM 00190016 ENTRY ARSIN 00200000 ENTRY ARCOS 00220000 SPACE 00240000 GR2 EQU 2 SCRATCH 00260000 GRA EQU 1 ARGUMENT POINTER 00280000 GRS EQU 13 SAVE AREA POINTER 00320000 GRT EQU 3 PREVIOUS SAVE AREA POINTER 00330016 GRB EQU 4 MAIN BASE REG 00340016 GRR EQU 14 RETURN REGISTER 00360000 GRL EQU 15 LINK REGISTER 00380000 FR0 EQU 0 ANSWER REGISTER 00400000 FR2 EQU 2 SCRATCH REGISTER 00420000 FR4 EQU 4 00440000 FR6 EQU 6 00450018 ISN EQU X'006' IDENTIFIER NUMBER FOR SQRT CALL 00460000 SPACE 00480000 USING *,GRL 00500018 ARCOS BC 15,SACOS 00520018 DC AL1(5) 00540018 DC CL5'ARCOS' 00560018 SACOS STM GRR,GRB,12(GRS) SAVE REGISTERS 00580018 MVI SWICH1+1,X'00' SET SWICH1 TO 'BC 0' 00600018 BAL GRL,JOIN ADJUST BASE REGISTER AND SKIP TO JOIN 00620018 SPACE 00640018 USING *,GRL 00660018 ARSIN BC 15,SASIN 00680018 DC AL1(5) 00700018 DC CL5'ARSIN' 00720018 SASIN STM GRR,GRB,12(GRS) SAVE REGISTERS 00740018 MVI SWICH1+1,X'F0' SET SWICH1 TO 'BC 15' 00760018 SPACE 00800000 JOIN EQU * BOTH ENTRIES MERGE HERE 00830016 LR GRB,GRL SWITCH BASE REGISTER TO GRB 00860000 USING ARSIN,GRB 00880000 DROP GRL 00900000 L GR2,0(GRA) 00905016 BEGIN EQU * 00910016 LE FR6,0(GR2) OBTAIN ARG 00915018 SPACE 00920000 LPER FR0,FR6 /X/ TO FR0 00940018 MVI SWICH2+1,X'10' 00960018 CE FR0,HALF IF /X/ SMALLER THAN 1/2, SET SWICH2 00980018 BC 12,MINMAX TO 'BC 1' AND SKIP TO MINMAX SECTION 01000018 SPACE 01020018 MVI SWICH2+1,X'80' IF /X/ GREATER THAN 1/2, SET SWICH2 01040018 LNER FR0,FR0 TO 'BC 8' AND COMPUTE 1-/X/ 01060018 * THIS CUTS DOWN ROUND-OFF ERROR 28132 01090019 * (SQRT LEAVES FR6 UNTOUCHED) 28132 01120019 LA GRA,ABUFF 01160018 AE FR0,ONE 01180018 BC 8,EXPRES IF /X/=1, SKIP TO AVOID UNDFLO 28132 01183019 LR GRT,GRS SWITCH SAVE AREA POINTERS 28132 01186019 LA GRS,AREA 28132 01189019 ST GRS,8(GRT) 28132 01192019 ST GRT,AREA+4 28132 01195019 BC 4,ERROR IF /X/ GREATER THAN 1, ERROR 01200018 HER FR6,FR0 LET Z = SQRT((1-/X/)/2) 01220018 AER FR0,FR0 KEEP Z**2 IN FR6 AND COMPUTE 01240018 STE FR0,BUFF 2*Z WHICH IS SQRT(2*(1-/X/)). 01260018 L GRL,ASQRT 01280018 BALR GRR,GRL GO TO SQRT 01300018 BC 0,ISN 01320018 LR GRS,GRT RESTORE SAVE AREA POINTER 01340018 BC 15,MERGE 01360018 SPACE 01380018 MINMAX CE FR0,LOLIM IF /X/ IS SMALLER THAN 16**-3, GIVE 01400018 BC 12,EXPRES /X/ AS ARCSIN(/X/) TO AVOID UNDERFLOW 01420018 MER FR6,FR6 FOR /X/ LE 1/2, GET X**2 IN FR6 01440018 MERGE LE FR4,C2 COMMON CIRCUIT 01460018 AER FR4,FR6 COMPUTE ARCSIN(/X/) OR 01480018 LE FR2,D2 2*ARCSIN(Z) AS THE CASE MAY BE 01500018 DER FR2,FR4 FR0=/X/ OR 2*Z, FR6=X**2 OR Z**2 01520018 AE FR2,C1 01540018 AER FR2,FR6 ARCSIN(W) = W+F*W**3 WHERE 01560018 ME FR6,D1 01580018 DER FR6,FR2 F = D1/(WSQ+C1+D2/(WSQ+C2)) 01600018 LD FR2,PIOV2 01620018 LER FR2,FR0 MANEUVER TO GIVE PARTIAL ROUNDING 01640018 MER FR0,FR6 01660018 ADR FR0,FR2 01680018 SPACE 01700018 EXPRES TM SWICH1+1,X'80' IF ARCSIN FOR BIG /X/ OR 01720018 SWICH2 BC 1,SIGN ARCCOS FOR SMALL /X/, SUBTRACT 01740018 LNER FR0,FR0 FR0 FROM PI/2 IN DOUBLE PRECISION 01760018 AD FR0,PIOV2 01780018 SPACE 01840000 SIGN TM 0(GR2),X'80' TEST SIGN OF THE ARGUMENT 01860000 BC 8,FIN IF NEGATIVE AND ARSIN, CHANGE SIGN 01880000 LNER FR0,FR0 IF NEG AND ARCOS, SUBTRACT FROM PI 01900000 SWICH1 BC 15,FIN ='BC 15,FIN' FOR ARSIN, 'BC 0,FIN' 01920000 AE FR0,PI FOR ARCOS 01940000 SPACE 01960000 FIN LM GRR,GRB,12(GRS) RESTORE REGISTERS 01980016 MVI 12(GRS),X'FF' AND RETURN 02000000 BCR 15,GRR 02020000 SPACE 02040000 ERROR STE FR6,DATA PLACE ARG IN ERROR INTO DATA 02045018 LM GRR,GRL,AERRMON ERMON ADDR IN 14, IBCOM IN 15 02050016 LA 2,DATA PREPARE FOR CONVERSION 02055016 LA 3,MSGDATA AREA IN MESSAGE FOR DATA 02060016 EX 0,86(0,GRL) FCVEO 02065016 BALR 0,1 02070016 DC X'040E0700' LL=4 WW=14 DD=7 SS=0 02075016 LA 1,ERRLIST 02100016 LR GRL,GRR ADDR OF ERMON IN REG 15 02105016 BALR 14,15 02110016 L GRS,4(GRS) RESTORE SAVE AREA POINTER 02115018 CLI RETCODE+3,X'00' DID USER FIX DATA 02120016 BNZ BEGIN YES 02125016 SER FR0,FR0 SET RESULT TO ZERO IF NO FIX 02130016 B FIN NO-EXIT 02135016 SPACE 02140000 AERRMON DC V(IHCERRM) 02150016 ACOM DC A(IBCOM#) 02160000 ASQRT DC A(SQRT) 02180000 ERRLIST DC A(MSGLNG) 02185016 DC A(RETCODE) 02190016 DC A(ERRNUM) 02195016 DC X'80' 02196018 DC AL3(DATA) 02197018 ABUFF DC X'80' 02200000 DC AL3(BUFF) 02220000 AREA DS 18F SAVE AREA 02240016 BUFF DS F 02260000 DS 0D 02270018 PIOV2 DC X'411921FB5FFFFFFF' PI/2 + 0.73*2**-24 02280018 D1 DC X'C08143C7' -0.5049404 02290018 C1 DC X'C13B446A' -3.7042025 02300018 D2 DC X'C11406BF' -1.2516474 02310018 C2 DC X'C11DB034' -1.8555182 02320018 ONE DC X'41100000' 1.0 02330018 PI DC X'413243F7' PI 02340018 HALF DC X'40800000' 0.5 02350018 LOLIM DC X'3E100000' 16**-3 02360018 DATA DS F 02410018 RETCODE DS F 02464016 ERRNUM DC F'257' 02466016 MSGLNG DC A(ENDMSG-MSG) 02468016 MSG DC C'IHC257I ARSIN-ARCOS /ARG/=/' 02470016 MSGDATA DS 14C 02472016 DC C'/ GT 1' 02474016 ENDMSG EQU * 02476016 END 02480000 ./ ADD SSI=02053630,NAME=IHCSATAN,SOURCE=0 SATN TITLE 'ARCTANGENT FUNCTION (SHORT)' 01000018 IHCSATAN CSECT 02000018 * ARCTANGENT FUNCTION (SHORT) 03000018 * 1. REDUCE THE CASE TO THE 1ST OCTANT BY USING 04000018 * ATAN(-X)=-ATAN(X), ATAN(1/X)=PI/2-ATAN(X). 05000018 * 2. REDUCE FURTHER TO THE CASE /X/ LESS THAN TAN(PI/12) 06000018 * BY ATAN(X)=PI/6+ATAN((X*SQRT3-1)/(X+SQRT3). 07000018 * 3. FOR THE BASIC RANGE (X LESS THAN TAN(PI/12)), USE 08000018 * A FRACTIONAL APPROXIMATION. 09000018 SPACE 10000018 ENTRY ATAN 11000018 SPACE 12000018 GRA EQU 1 ARGUMENT POINTER 13000018 GRS EQU 13 SAVE AREA POINTER 14000018 GRR EQU 14 RETURN REGISTER 15000018 GRL EQU 15 LINK REGISTER 16000018 GR0 EQU 0 SCRATCH REGISTERS 17000018 GR1 EQU 1 18000018 FR0 EQU 0 ANSWER REGISTER 19000018 FR2 EQU 2 SCRATCH REGISTERS 20000018 FR4 EQU 4 21000018 FR6 EQU 6 22000018 SPACE 23000018 USING *,GRL 24000018 ATAN BC 15,SATAN 25000018 DC AL1(4) 26000018 DC CL4'ATAN' 27000018 SPACE 28000018 SATAN STM GRR,GRL,12(GRS) SAVE REGISTERS 29000018 L GR1,0(GRA) 30000018 LE FR0,0(GR1) OBTAIN ARGUMENT 31000018 L GR0,0(GR1) SAVE ARG FOR SIGN CONTROL 32000018 LPER FR0,FR0 AND SET SIGN POSITIVE 33000018 LE FR4,ONE 34000018 SR GR1,GR1 GR1 TO DENOTE THE SECTION TO WHICH 35000018 CER FR0,FR4 ANSWER BELONGS. BREAK POINTS ARE 36000018 BC 12,REDUC TAN(PI/12), TAN(PI/4), TAN(5PI/12) 37000018 LER FR2,FR4 IF ARG GREATER THAN 1, TAKE INVERSE 38000018 DER FR2,FR0 AND CRANK GR1 BY 8 39000018 LER FR0,FR2 40000018 LA GR1,8 41000018 SPACE 42000018 REDUC CE FR0,SMALL IF ARG IS LESS THAN 16**-3, ANS=ARG. 43000018 BC 12,READY THIS AVOIDS UNDERFLOW EXCEPTION 44000018 CE FR0,TAN15 IF ARG GREATER THAN TAN(PI/12), REDUCE 45000018 BC 12,OK THE ARG BY USING 46000018 LER FR2,FR0 47000018 ME FR0,RT3M1 ATAN(X) = PI/6+ATAN(Y), 48000018 SER FR0,FR4 WHERE Y = (X*SQRT3-1)/(X+SQRT3) 49000018 AER FR0,FR2 50000018 AE FR2,RT3 COMPUTE X*SQRT3-1 AS X(SQRT3-1)-1+X 51000018 DER FR0,FR2 TO PROTECT SIGNIFICANT DIGITS 52000018 LA GR1,4(GR1) CRANK GR1 BY 4 53000018 SPACE 54000018 OK LER FR4,FR0 NOW MAGNITUDE OF REDUCED ARG IS 55000018 MER FR0,FR0 LESS THAN TAN(PI/12)=0.26795 56000018 LER FR2,FR0 57000018 ME FR0,C COMPUTE ANGLE BY 58000018 AE FR2,A ATAN(X)/X = D+C*XSQ+B/(XSQ+A) 59000018 LE FR6,B 60000018 DER FR6,FR2 61000018 AER FR0,FR6 62000018 AE FR0,D 63000018 MER FR0,FR4 64000018 SPACE 65000018 READY AE FR0,ZERO(GR1) DEPENDING ON THE SECTION TO WHICH 66000018 LPER FR0,FR0 THE ANSWER BELONGS, ADD OR SUBTRACT 67000018 LTR GR0,GR0 REDUCED ANSWER FROM A BASE ANGLE 68000018 BC 10,*+6 SIGN OF ANS SHOULD AGREE WITH SIGN 69000018 LNER FR0,FR0 OF ARG 70000018 SPACE 71000018 EXIT MVI 12(GRS),X'FF' 72000018 BCR 15,GRR RETURN 73000018 SPACE 74000018 DS 0F 75000018 A DC X'41168A5E' 1.4087812 76000018 B DC X'408F239C' 0.55913709 77000018 C DC X'BFD35F49' -0.051604543 78000018 D DC X'409A6524' 0.60310579 79000018 ONE DC X'41100000' 80000018 RT3 DC X'411BB67B' SQRT3 81000018 RT3M1 DC X'40BB67AF' SQRT3-1 82000018 SMALL DC X'3E100000' 83000018 TAN15 DC X'40449851' TAN 15 DEGREES 84000018 ZERO DC F'0' 85000018 DC X'40860A92' PI/6 86000018 DC X'C11921FB' -PI/2 87000018 DC X'C110C152' -PI/3 88000018 END 89000018 ./ ADD SSI=03011000,NAME=IHCSATN2,SOURCE=0 SAT2 TITLE 'ARCTANGENT FUNCTION (SHORT, 2 ENTRY POINTS)' 00010018 IHCSATN2 CSECT 00020000 *HJNX 013600,0126-0130,0210-0234 00030017 * 00040000 * ARCTANGENT FUNCTION (SHORT, 2 ENTRY POINTS) 00060000 * 1. REDUCE THE CASE TO THE 1ST OCTANT BY USING 00080000 * ATAN(-X)=-ATAN(X), ATAN(1/X)=PI/2-ATAN(X) 00100000 * 2. REDUCE FURTHER TO THE CASE /X/ LESS THAN TAN(PI/12) 00120000 * BY ATAN(X)=PI/6+ATAN((X*SQRT3-1)/(X+SQRT3)). 00140000 * 3. FOR THE BASIC RANGE (X LESS THAN TAN(PI/12)), USE 00160000 * A CONTINUED FRACTION APPROXIMATION 00180000 * 4. ATAN2 ENTRY REQUIRES A PAIR OF ARGUMENTS Y AND X 00200000 * AND COMPUTES ATAN(Y/X). ANSWER IS IN (-PI,PI) 00220000 SPACE 00240000 EXTRN IBCOM# 00260000 EXTRN IHCERRM 00270016 ENTRY ATAN 00280000 ENTRY ATAN2 00300000 SPACE 00320000 GRA EQU 1 ARGUMENT POINTER 00330018 GRS EQU 13 SAVE AREA POINTER 00340018 GRR EQU 14 RETURN REGISTER 00350018 GRL EQU 15 LINK REGISTER 00360018 GR0 EQU 0 SCRATCH REGISTERS 00370018 GR1 EQU 1 00380018 GR2 EQU 14 00390018 FR0 EQU 0 ANSWER REGISTER 00400018 FR2 EQU 2 SCRATCH REGISTERS 00410018 FR4 EQU 4 00420018 FR6 EQU 6 00430018 SPACE 00440018 USING *,GRL 00450018 ATAN2 BC 15,SATN2 ATAN2 ENTRY 00460018 DC AL1(5) 00470018 DC CL5'ATAN2' 00480018 SPACE 00490018 SATN2 STM GRR,GR0,12(GRS) SAVE REGISTERS 00500018 LR GR0,GRA SET GR0 NON-ZERO, SAVE ARG POINTER 00510018 BAL GRL,MERGE ADJUST BASE REGISTER AND MERGE 00520018 SPACE 00530018 USING *,GRL 00540018 ATAN BC 15,SATN ATAN ENTRY 00550018 DC AL1(4) 00560018 DC CL5'ATAN' 00570018 SPACE 00580018 SATN STM GRR,GR0,12(GRS) SAVE REGISTERS 00590018 SR GR0,GR0 SET GR0 ZERO 00600018 SPACE 00610018 MERGE L GR2,0(GRA) BOTH ENTRIES JOIN HERE 00620018 LE FR0,0(GR2) OBTAIN 1ST (OR ONLY) ARGUMENT X1 00630018 STE FR0,SIGN SAVE ITS SIGN 00640018 LPER FR0,FR0 FORCE SIGN POSITIVE 00650018 LTR GR0,GR0 00660018 BC 8,ATAN1 IF ATAN ENTRY, SKIP TO MAIN CIRCUIT 00670018 SPACE 00680018 L GR2,4(GRA) 00690018 LE FR6,0(GR2) OB