./ ADD SSI=02000674,NAME=IEKAA00,SOURCE=0 IEKAA00 CSECT 00080014 IEKA TITLE 'IEKAA00 - OS/360 FORTRAN H COMPILER - FORTRAN SYSTEM DI100160014 RECTOR,V.5.1' 00240014 * 00320014 * 004000 0000A 00330015 * 120000 0000A 00340015 * 135200-136000 0000A 00350015 * 144000 0000A 00360015 * 214400 0000A 00370015 * 233600 0000A 00380015 * 251200 0000A 00390015 * 360800 0000A 00400015 * 604000 0000A 00410015 * 754400 0000A 00420015 * 804800 0000A 00430015 * 828000 0000A 00440015 * 899200 0000A 00450015 *2420604000,606400 3261 00460015 *0124369200,369600,403200,404800,901200 000B 00470016 *1350783400-783800,862600-862800 16721 00475017 *2096390350,805620-805680,808800,810000 31113 00495020 *2192119450,570580-570600 33451 00505020 * 708320-708392 LL40179 00507021 * 632520,645000,751774 LL42638 00509021 * 401700-402000,863200-863300,872100,901600,905600 47976 JL2108.02 00510021 * 663200,679700-680000,680600-681100 LL45090 00511021 * 690400,692800,697800-698800,705900 LL45090 00513021 * 707280-707840,870900 LL47029 00514021 * A750420-750440 LL66687 00514421 * 00515020 *FUNCTION/OPERATION--THIS MODULE INITIALIZES TEXT AND DICTIONARY, 00560019 * ALLOCATES TEXT AREA TO ALL PHASES, CALLS EACH PHASE IN TURN, AND 00640019 * RECEIVES CONTROL IN CASE OF DISASTEROUS ERROR. 00720019 * 00800014 *ENTRY POINTS--SIX ENTRY POINTS AS FOLLOWS- 00880014 * 00960014 * IEKAA00--ENTRY POINT FOR FORTRAN H COMPILER. INITIALIZES 01040019 * POINTER TABLE, TEXT, DICTIONARY,ADCON TABLE. 01120019 * CALLS PHASES AS REQUIRED. 01200019 * ADDR OF ARGUMENT LIST IN REGISTER 'ARG' 01280014 * 01360014 * IEKAGC--ALLOCATES TEXT AND DICTIONARY AREA FOR THE COMPILER 01380014 * TAKES CONTROL FROM THE COMPILER IF NO MORE CORE IS AVAILABLE 01400014 * ARGUMENTS ARE- 01420014 * 0 - P10 TEXT 01440014 * 1 - P10 SPECIAL TEXT 01460014 * 2 - DICTIONARY 01480014 * 3 - P15 DATA TEXT 01500014 * 4 - P15/20 TEXT 01520014 * 5 - FREE AREAS 01540014 * 01600014 * 01680014 * ENDFILE--RECEIVES CONTROL WHEN END-OF-DATA-SET DETECTED ON 01760014 * INPUT. RETURNS CONTROL TO OS/360. 01840014 * 01920014 * IBCOMRTN--RECEIVES CONTROL IF IEKFCOMH DETECTS ERROR. 02000014 * RETURNS CONTROL TO OS/360. 02080014 * 02160014 * SYSDIR--RECEIVES CONTROL WHEN PHASE 10 HAS FINISHED ITS 02240014 * NORMAL PROCESSING (ARGUMENT = 1). 02320014 * RECEIVES CONTROL WHEN ANY PHASE DETECTS A 02400014 * CATASTROPHIC CONDITION (TABLE OVERFLOW, COMPILER ERROR, ETC.), 02480014 * (ARGUMENT .GT. 1). 02560014 * RECEIVES CONTROL FROM IEKFCOMH IF A PROGRAM INTERRUPT 02640014 * (NON-MATH) OCCURS (ARGUMENT = 0) 02720014 * 02800014 *EXIT -- (FINAL) TO CALLER WITH CONDITION CODE IN REG 15. THE CODE 02880014 * DEPENDS UPON HOW A COMPILATION TERMINATES- 02960014 * 1.* 0 * SOURCE MODULE COMPILED WITHOUT ERROR. 03040014 * 2.* 4 * SOURCE MODULE CONTAINED MINOR ERRORS, SHOULD EXECUTE 03120014 * PROPERLY. 03200014 * 3.* 8 * SOURCE MODULE CONTAINED SERIOUS ERRORS, PROBABLY WILL 03280014 * NOT EXECUTE PROPERLY. 03360014 * 4.* 16 * COMPILATION WAS DELETED FOR ONE OF THE FOLLOWING REASONS- 03440014 * A. INTERNAL TEXT TABLE FILLED. 03520014 * B. PERMANENT I/O ERROR OCCURRED (NO MORE COMPILATIONS ATTEMPTED) 03600014 * C. CATASTROPHIC HAPPENING WITHIN COMPILER (TABLE OVERFLOW, 03680014 * COMPILER ERROR, IMPOSSIBLE SITUATION) 03760014 * 03840014 *INPUT--PARAMETERS FROM EXEC CARD ARE PASSED BY OS/360. GETCOR AND 03920014 * SYSDIR DETERMINE ACTION FROM PARAMETERS PASSED BY CALLER. OTHER 04000014 * ENTRIES ARE SINGLE PURPOSE AND DO NOT REQUIRE PARAMETERS. 04080014 * 04160014 * 04240014 *OUTPUT--OUTPUT IS EITHER A MESSAGE OR SET OF POINTERS. PARAMETERS, 04320014 * PAGE HEADING, AND ERROR MESSAGES ARE PASSED TO IEKFIOCS TO PRINT. 04400014 * CORE ALLOCATION RESULTS IN PAIRS OF POINTERS BEING PASSED TO 04480014 * CALLER VIA COMMONS. 04560014 * 04640014 *EXTERNAL ROUTINES-- 04720014 * IEKFIOCS--LINES OF PRINT ARE INSERTED INTO BUFFERS OBTAINED 04800014 * FROM FIOCS. 04880014 * GETCD--CALLED TO READ TO 'END' CARD IF COMPILATION IS 04960014 * DELETED IN PHASE 10. 05040014 * IEKFCOMH--CALLED TO SET PROGRAM INTERRUPT MASK. INTERCEPTS 05120014 * INTERRUPTS AND ERROR CONDITIONS AND PASSES CONTROL TO 05200014 * IEKAA00 VIA SYSDIR OR IBCOMRTN ENTRY POINT. 05280014 * 05360014 *TABLES/WORK AREAS-- 05440014 * IEKAA01--(SEPARATE CSECT)- 05520014 * CONTAINS DEFAULT AND PROCESSED PARAMETERS, PAGE HEADING, SIZE OF 05600014 * TEXT-DICTIONARY, DDNAMES FOR IEKFIOCS. 05680014 * 05760014 * OPTIONS-- 05840014 * CONTAINS KEYWORD PARAMETERS TO BE RECOGNIZED BY COMPILER. EACH 05920014 * ENTRY CONSISTS OF- 06000014 * 1.* ONE BYTE COUNT. 06080014 * 2.* N-BYTE KEYWORD. 06160014 * 3.* ONE BYTE MASK (EXCEPT OPTIONS FOLLOWED BY NUMERALS). 06240014 * 06320014 * TEXT-BLOCK CHAIN-POINTERS-- (BLKCHN (5),FREQUE (1)) 06400014 * 06720014 *ATTRIBUTES--THIS MODULE IS NOT REENTRANT, IT IS SERIALLY REUSEABLE. 06800014 * 06880014 EJECT 06960014 * 07040014 * OS/360 STANDARD REGISTERS 07120014 ARG EQU 1 07200014 SAVE EQU 13 07280014 RETN EQU 14 07360014 LINK EQU 15 07440014 SPACE 3 07520014 * IEKFIOCS REGISTERS 07600014 R EQU 0 07680014 L EQU 1 07760014 GRX EQU 2 07840014 GRY EQU 3 07920014 SPACE 3 08000014 * IEKAA00 REGISTERS 08080014 * BASE REGISTERS USED 08160014 NPTR EQU 10 BASE FOR /BLANK/ 08240014 CP10A EQU 3 BASE FOR COMMON /P10A/ 08320019 AA02 EQU 11 08400019 BASE EQU 12 BASE FOR IEKAA00 08480014 * WORKING REGISTERS 08560014 COUNT EQU 9 COUNT OF CHARS IN PARM FIELD 08640014 DICT EQU 3 DICTIONARY PTR 08720014 END EQU 8 END OF CURRENT PARM ( + 1 ) 08800014 FIRST EQU 4 FIRST BYTE OF BLOCK 08880014 INDEX EQU 1 USED AS INDEX REGISTER 08960014 LAST EQU 5 LAST BYTE OF BLOCK 09040014 LGTH EQU LAST LENGTH OF BLOCK 09120014 QUE EQU 8 PTS TO BLOCK CHAIN 09200014 RA EQU 6 FIRST OF EVEN/ODD PR 09280014 RB EQU RA+1 SECOND OF EVEN/ODD PR 09360014 RE EQU 10 USED IN EXECUTE INSTRUCTIONS 09440014 RN EQU 3 NUMBER/COUNTER 09520014 SCAN EQU 5 BEGINNING OF CURRENT PARM 09600014 SWCH EQU 2 09680014 TABLE EQU 4 TABLE TO COMPARE PARMS TO 09760014 ZERO EQU 0 09840014 * SYMBOLICS FOR ABSOLUTE REGISTERS 09920014 R0 EQU 0 10000014 R1 EQU 1 10080014 R2 EQU 2 10160014 R3 EQU 3 10240014 R4 EQU 4 10320014 R5 EQU 5 10400014 R6 EQU 6 10480014 R7 EQU 7 10560014 R8 EQU 8 10640014 R9 EQU 9 10720014 R10 EQU 10 10800014 R11 EQU 11 10880014 R12 EQU 12 10960014 R13 EQU 13 11040014 R14 EQU 14 11120014 R15 EQU 15 11200014 SPACE 3 11280014 * CHARACTER DEFINITIONS 11360014 PERIOD EQU C'.' USED IN PAGE HEADING 11440014 EXIT EQU X'FF' FOR RETURN TO CALLER 11600014 ANY EQU X'FF' USED TO TEST BITS 11680014 ALL EQU ANY 11760014 NONE EQU X'00' 11840014 IBARITH EQU 64 11940015 DECK EQU X'08' 11945020 LOAD EQU X'10' 11950019 DUMP EQU X'04' 11960019 NOEDIT EQU X'BF' 11970019 EDIT EQU X'40' 11980019 MAP EQU X'20' 11990019 XREF EQU X'01' 12000019 LGTH1 EQU 31 12010019 * INSERT CHARS FOR 12080014 * COMPILATION DELETED MSG. 12160014 MSG1 EQU C'1' PHASE 10 TEXT OVERFLOW 12240014 MSG2 EQU C'2' PROGRAM INTERRUPT 12320014 MSG3 EQU C'3' PHASE 15 TEXT OVERFLOW 12400014 MSG4 EQU C'4' PHASE 20 TEXT OVERFLOW 12480014 MSG5 EQU C'5' DELETE COMPILATION IMMEDIATELY 12560014 MSG6 EQU C'6' IBCOM DETECTED ERROR 12640014 MSG7 EQU C'7' END-OF-DATA-SET, NO 'END' CARD 12720014 EJECT 12800014 * MAIN ENTRY POINT TO IEKAA00 12880014 BC 15,12(15) 12900014 DC C' IEKAA00' 12920014 STM RETN,RETN-2,12(SAVE) SAVE CALLER'S REGISTERS 12960014 LR BASE,LINK BASE REGISTER 13040014 USING IEKAA00,BASE 13120014 LA RA,IEKSAVE 13200014 ST RA,8(SAVE) OUR SAVE AREA TO CALLER 13280014 ST SAVE,IEKSAVE+4 CALLER'S SAVE AREA FOR US 13360014 LR SAVE,RA SAVE AREA FOR THOSE WE CALL 13440014 ST ARG,PARMLIST SAVE POINTER TO PARAMETERS 13480015 ST BASE,HISPM SAVE PREVIOUS PROGRAM MASK 13520015 SPIE ARITH,(1,2,3,4,5,6,7,9,11,12,13,15) 13560015 ST ARG,HLDSPIE SAVE PREVIOUSLY ACTIVE SPIE 13600015 * 13680014 L ARG,PARMLIST 14680019 L LINK,ADAINT CALL IEKAINIT FOR PARAM 15680019 BALR RETN,LINK PROC. AND GETTING CORE 16680019 XC ERRCODE(2),ERRCODE 17180019 L AA02,ADAA02 17680019 USING IEKAA02,AA02 18680019 B AGAIN 19680019 EJECT 26320014 SPACE 3 26480014 SPACE 3 26640014 * SMALL SUBROUTINE TO ZERO 512+ 26720014 * BYTES IN 256 BYTE BLOCKS 26800014 * BYTES/256 = BLOCKS 26880014 ZEROBLK SR RA,RA 26960014 D RA,F256 27040014 EX RA,ZEROLOOP ZERO OUT FIRST 256 BYTES 27120014 LA FIRST,0(RA,FIRST) BUMP ADDR TO NEXT EVEN BLOCK 27200014 ZEROLOOP XC 0(256,FIRST),0(FIRST) ZERO OUT BLOCK 27280014 LA FIRST,256(FIRST) BUMP ADDR TO NEXT BLOCK 27360014 BCT RB,ZEROLOOP 27440014 BR RETN 27520014 * 27600014 SPACE 3 27680014 AGAIN EQU * INITIALIZE FOR COMPILATION 38960014 MVI BEG,X'00' TURN SWITCH OFF 39000014 XC CORECHN(20),CORECHN 39010019 XC CORETOT(12),CORETOT 39020019 MVI IND,X'00' 39030019 MVI ABENDCNT+1,X'01' START NEW ABEND COUNT 39035020 TIME , ASK FOR TIME AND DATE 39040014 ST ARG,PACKED DATE IN R1 39200014 UNPK YEAR+1(5),PACKED+1(3) UNPK INTO PAGEHEAD 39280014 MVC YEAR(2),YEAR+1 MOVE YY OVER 39360014 MVI YEAR+2,PERIOD INSERT '.' FOR YY.DDD 39440014 * SET UP TIME OF DAY 39520014 SRL ZERO,4 39600014 ST ZERO,PACKED TIME IN R0 39680014 UNPK HOUR+2(6),PACKED(4) UNPK INTO PAGEHEAD 39760014 OI HOUR+7,X'F0' GET RID OF SIGN 39840014 MVC HOUR(2),HOUR+2 MOVE HH 39920014 MVC HOUR+3(2),HOUR+4 MOVE MM 40000014 MVI HOUR+2,PERIOD INSERT '.' HH.MM.SS 40080014 MVI HOUR+5,PERIOD 40160014 L R15,ADAA01 40170021 USING DUMIEK,R15 40180021 MVC PAGEHEAD+1(28),HEADER MOVE LEVEL AND DATE INTO HEADING 40190021 DROP 15 40200021 * NPTR, NDICT, NTEXT ARE ZEROED 40240014 L NPTR,ADNPTR ADDRESS OF NPTR TABLE 40320014 L R1,60(NPTR) SAVE LGTH OF SYSUT2 BLKSIZE 40360016 XC 0(256,NPTR),0(NPTR) ZERO NPTR TABLE 40410018 XC 256(32,NPTR),256(NPTR) 40460018 ST R1,60(NPTR) 40520016 MVI 175(NPTR),X'01' 40530019 CLI ERRSW,X'0F' 40540019 BNE READCARD 40550019 MVI 279(NPTR),X'05' 40560019 MVI 175(NPTR),X'02' 40570019 L LINK,ADERR 40580019 XC 4(4,LINK),4(LINK) 40590019 MVC 0(4,LINK),ERMSNO 40600019 READCARD L LINK,ADFIOCS 40610019 LA ARG,READPARM PARMLIST FOR READING 40640014 BALR RETN,LINK READ A RECORD 40720014 L ARG,0(ARG) ADDRESS OF RECORD 40800014 ST ARG,100(NPTR) NPTR (2,13) 40880014 * ADCON IS ZEROED 41280014 L FIRST,ADADCON ADDR OF /ADCON/ 41360014 L RB,0(FIRST) FIRST WORD CONTAINS LGTH 41440014 SLA RB,2 TO GET BYTES 41520014 LA FIRST,4(FIRST) DON'T ZERO OUT LGTH 41600014 BAL RETN,ZEROBLK ZERO /ADCON/, AT LEAST 512 BYTES 41680014 LA ARG,HEADPARM PARM LIST FOR HEADING 41760014 L LINK,ADFIOCS ADDRESS OF FIOCS 41840014 BALR RETN,LINK GET BUFFER 41920014 L GRX,0(1) ADDRESS OF BUFFER 42000014 MVC 0(PGHDLGTH,GRX),PAGEHEAD 42080014 LA ARG,HEADPARM PARM LIST 42160014 L LINK,ADFIOCS ADDRESS OF FIOCS 42240014 BALR RETN,LINK GET BUFFER 42320014 L GRX,0(1) ADDRESS OF BUFFER 42400014 MVC 0(OPTLGTH,GRX),OPTLINE 42480014 LA ARG,HEADPARM 2ND LINE 42490019 L LINK,ADFIOCS ADDRESS OF FIOCS 42500019 BALR RETN,LINK GET BUFFER 42510019 L GRX,0(1) ADDRESS OF PUFFER 42520019 MVC 0(OPTLGTH,GRX),OPTLINE1 42530019 * INITIALIZE POINTER TABLE 42560014 * AND DICTIONARY 42640014 LA LINK,IEKAGC GET FIRST BLK FOR DICT 42660014 LA ARG,DICTARG ARGUMENT FOR DICT 42680014 BALR RETN,LINK 42700014 * LAST ENTRY IN ERROR TABLE 42720014 * (ERCOM IS CSECT) 42800014 L DICT,228(NPTR) NPTR(2,29) FIRST ENTRY 42880014 MVI 91(NPTR),ERLGTH NPTR (1,12), 42960014 * SIX-CHAR SYMBOL CHAIN 43040014 LA RA,8*36(DICT) 43120014 ST RA,44(NPTR) NPTR (2,6) = 9 ADDR 43200014 ST DICT,192(NPTR) NPTR(1,25)FIRST OF DICT 43280014 * FOUR-BYTE CONSTANT CHAIN 43360014 LA RA,2*36(DICT) 43440014 ST RA,108(NPTR) NPTR (2,14) = 3 ADDR 43520014 * EIGHT-BYTE CONSTANT CHAIN 43600014 LA RA,5*36(DICT) 43680014 ST RA,116(NPTR) NPTR (2,15) = 6 ADDR 43760014 * NEXT ENTRY IN ERROR TABLE 43840014 * 44000014 * NEXT DICTIONARY ENTRY 44080014 LA RA,11*36(DICT) 44160014 ST RA,228(NPTR) NPTR (2,29) = 12 ADDR 44240014 * 44320014 * ONE-BYTE CONSTANT OF 1 44400014 LA RA,3*36(DICT) 44480014 ST RA,0(DICT) CHN (1) = 4 ADDR 44560014 MVI 13(DICT),3 MDD (1) = 3 44640014 MVI 15(DICT),5 TYP (1) = 5 44720014 MVI 35(DICT),1 NAM4(1) = 1 44800014 * TWO-BYTE CONSTANT OF 1 44880014 MVI 36+13(DICT),4 MDD (2) = 4 44960014 MVI 36+15(DICT),5 TYP (2) = 5 45040014 MVI 36+35(DICT),1 NAM4(2) = 1 45120014 * FOUR-BYTE CONSTANT OF 1 45200014 LA RA,6*36(DICT) 45280014 ST RA,2*36(DICT) CHN (3) = 7 ADDR 45360014 LA RA,9*36(DICT) 45440014 ST RA,2*36+8(DICT) ADC (3) = 10 ADDR 45520014 MVI 2*36+13(DICT),5 MDD (3) = 5 45600014 MVI 2*36+15(DICT),5 TYP (3) = 5 45680014 MVI 2*36+35(DICT),1 NAM4(3) = 1 45760014 * ONE-BYTE LOGICAL FALSE 45840014 MVI 3*36+13(DICT),3 MDD (4) = 3 45920014 MVI 3*36+15(DICT),5 TYP (4) = 5 46000014 * FLOATING PT. UNNORMALIZED ZERO 46080014 LA RA,6*36(DICT) 46160014 ST RA,4*36+8(DICT) ADC (5) = 7 ADDR 46240014 MVI 4*36+13(DICT),7 MDD (5) = 7 46320014 MVI 4*36+15(DICT),5 TYP (5) = 5 46400014 MVI 4*36+32(DICT),X'47' NAM4(5) = Z47000000 46480014 * DBL. FLOATING PT. UNNORM. ZERO 46560014 LA RA,7*36(DICT) 46640014 ST RA,5*36+8(DICT) ADC (6) = 8 ADDR 46720014 MVI 5*36+13(DICT),6 MDD (6) = 6 46800014 MVI 5*36+15(DICT),5 TYP (6) = 5 46880014 MVI 5*36+28(DICT),X'4E' NAM3(6) = Z4E000000 46960014 * FLOATING POINT ONE 47040014 LA RA,4*36(DICT) 47120014 ST RA,6*36(DICT) CHN (7) = 5 ADDR 47200014 LA RA,2*36(DICT) 47280014 ST RA,6*36+8(DICT) ADC (7) = 3 ADDR 47360014 MVI 6*36+13(DICT),7 MDD (7) = 7 47440014 MVI 6*36+15(DICT),5 TYP (7) = 5 47520014 MVI 6*36+32(DICT),X'41' 47600014 MVI 6*36+33(DICT),X'10' NAM4(7) = Z41100000 47680014 * DBL. FLOATING PT. ONE 47760014 LA RA,5*36(DICT) 47840014 ST RA,7*36(DICT) CHN (8) = 6 ADDR 47920014 MVI 7*36+13(DICT),6 MDD (8) = 6 48000014 MVI 7*36+15(DICT),5 TYP (8) = 5 48080014 MVC 7*36+28(2,DICT),6*36+32(DICT) NAM3 (8) = Z41100000 48160014 * OBJECT TIME ERROR ROUTINE NAME 48240014 MVI 8*36+15(DICT),4 TYP (9) = 4 48320014 MVC 8*36+30(6,DICT),=C'IBERH#' NAM3 (9) & NAM4 (9) 48400014 * FOUR-BYTE CONSTANT OF ZERO 48480014 LA RA,2*36(DICT) 48560014 ST RA,9*36(DICT) CHN(10) = 3 ADDR 48640014 MVI 9*36+13(DICT),5 MDD (10) = 5 48720014 MVI 9*36+15(DICT),5 TYP (10) = 5 48800014 * 48880014 * DICT ENTRY (11) = 0 48960014 * 49040014 * AND SV1 (USED BY OPTIMIZER) 49120014 * SV2 (USED BY OPTIMIZER) 49200014 * 49280014 * SET OPTIONS FOR COMPILATION 49360014 * FIRST COMPILATION, IF MAIN 49440014 * PROGRAM, RECEIVES NAME FROM 49520014 * EXEC CARD (IF GIVEN). 49600014 LM R3,R9,PROCPARM LOAD OPTIONS 49680014 TM FC,ALL FIRST TRIP THRU SETS 49760014 BO NOTFIRST 49840014 LM R3,R4,TEMPNAME FIRST COMPILATION 49920014 OI FC,ALL SET SWITCH 50000014 NOTFIRST EQU * 50080014 STM R3,R4,72(NPTR) NAME NPTR(1,10) AND (2,10) 50160014 ST R5,188(NPTR) OPT NPTR(2,24) 50240014 ST R6,84(NPTR) TRACE NPTR(2,11) 50320014 ST R8,40(NPTR) LINECNT NPTR(1,6) 50400014 ST R9,16(NPTR) BITSW NPTR(1,3) 50480014 * 50560014 * 50640014 EJECT 50800014 * 50880014 * CALL PHASE 10 50960014 MVI 83(NPTR),1 PHASE SW, NPTR (1,11) 51040014 TM 86(NPTR),128 CK THE TIMING SWITCH 51120014 BZ *+10 51200014 L LINK,ATST 51280014 BALR RETN,LINK START THE TIMING ROUTINE 51360014 L LINK,ADDRPH10 51440014 BALR RETN,LINK 51520014 RTNPH10 EQU * RETURN PT AFTER PHASE 10 51600014 TM 18(NPTR),1 IS XREF REQUESTED 51680014 BZ TRACEP10 NO 51760014 L LINK,ADDRXRS 51840014 BALR RETN,LINK 51920014 SR LINK,LINK 52000014 L RETN,ADADCON CLEAR FIRST WORD OF ADCON 52080014 ST LINK,4(RETN) 52160014 ST LINK,144(NPTR) NPTR(2,20) 52240014 * 52320014 TRACEP10 TM 86(NPTR),128 CK THE TIMING SWITCH 52400014 BZ *+8 52480014 BAL LAST,TOF TURN THE TIMER OFF 52560014 * TEXT, DICT, NPTR 52640014 TM 87(NPTR),64 TRACE AFTER THE PHAZE 52720014 BZ NTP10 52800014 LA ARG,DEC29 52880014 L LINK,ADDRTABS 52960014 BALR RETN,LINK 53040014 * 53120014 NTP10 EQU * 53280014 EJECT 53360014 * 53440014 * CALL STALL 53520014 MVI 83(NPTR),2 PHASE SW, NPTR (1,11) 53600014 L LINK,ADDRSTAL 53680014 BALR RETN,LINK 53760014 TM 18(NPTR),1 IS XREF REQUESTED 53840014 BZ TIMESTAL 53920014 L LINK,ADDRXREF 54000014 BALR RETN,LINK 54080014 TIMESTAL TM 86(NPTR),128 CHECK TIMING SWITCH 54160014 BZ *+8 54240014 BAL LAST,TOF TURN THE TIMER OFF 54320014 TRSTALL TM 87(NPTR),64 TRACE AFTER THE PHAZE 54400014 BZ NTP12 54480014 * DICT, NPTR 54560014 LA ARG,DEC24 54640014 L LINK,ADDRTABS 54720014 BALR RETN,LINK 54800014 * 54880014 NTP12 EQU * 54960014 SR ZERO,ZERO 55040014 ST ZERO,68(NPTR) NPTR(2,9) PHAZ15 MUST 55120014 ST ZERO,64(NPTR) NPTR(1,9) REQUEST 55200014 TM 235(NPTR),ANY TEST BLOCK DATA SWITCH 55280014 BM RTNPH15 SKIP PHAZ15 IF BLOCK DATA 55360014 * 55440014 * CALL PHAZ15 55520014 MVI 83(NPTR),4 PHASE SW, NPTR (1,11) 55600014 L LINK,ADDRPH15 55680014 BALR RETN,LINK 55760014 TM 86(NPTR),128 CK THE TIMING SWITCH 55840014 BZ *+8 55920014 BAL LAST,TOF TURN THE TIMER OFF 56000014 TM 87(NPTR),64 TRACE AFTER THE PHAZE 56080014 BZ NTP15 56160014 * TEXT 56240014 LA ARG,DEC2 56320014 L LINK,ADDRTABS 56400014 BALR RETN,LINK 56480014 NTP15 EQU * 56560014 RTNPH15 EQU * RETURN PT AFTER PHAZ15 56640014 BAL RETN,FINDCORE 56660019 ST RA,CORETOT 56680019 BAL RETN,FINDFREQ FIND END OF FREQUE 56720014 L RA,BLKCHN P10 NORMAL TEXT 56800014 ST RA,0(QUE) NOW IN FREQUE 56880014 XC BLKCHN(4),BLKCHN ZERO CHAIN 56960014 * 57040014 TM 19(NPTR),LOAD LOAD OPTION NPTR(1,3) 57048014 BNZ CALCORAL YES 57056014 TM 19(NPTR),DECK 57058020 BNZ CALCORAL 57060020 TM 279(NPTR),ANY ANY ERRORS NPTR(2,35) 57064014 BZ CALCORAL NO 57072014 L DICT,192(NPTR) BEG OF DICT NPTR (1,25) 57080014 LA DICT,8*36(DICT) IBERH ENTRY 57088014 TM 4(DICT),64 IS IT REFERENCED 57096014 BNZ CALLP30 YES 57104014 CALCORAL EQU * 57112014 * CALL CORAL 57120014 MVI 83(NPTR),8 PHASE SW, NPTR (1,11) 57200014 L LINK,ADDRCORA 57280014 BALR RETN,LINK 57360014 TM 86(NPTR),128 CK THE TIMING SWITCH 57440014 BZ *+8 57520014 BAL LAST,TOF TURN THE TIMER OFF 57600014 TM 87(NPTR),64 TRACE AFTER THE PHAZE 57680014 BZ NTP17 57760014 * DICT, NPTR 57840014 LA ARG,DEC24 57920014 L LINK,ADDRTABS 58000014 BALR RETN,LINK 58080014 * 58160014 NTP17 EQU * 58240014 BAL RETN,FINDCORE 58260019 ST RA,CORETOT+4 58280019 BAL RETN,FINDFREQ 58320014 L RA,BLKCHN+4 P10 SPECIAL TEXT 58400014 ST RA,0(QUE) NOW IN FREQUE 58480014 XC BLKCHN+4(4),BLKCHN+4 ZERO CHAIN 58560014 NTP17A EQU * 58960014 * 59040014 EJECT 59120014 TM 235(NPTR),ANY TEST BLOCK DATA 60320014 BZ CP20 NOT BLOCK DATA 3261 60330015 TM PROCBITS+1,EDIT IS EDIT OPTION ON? 3261 60350015 BZ TSTMAP 3261 60360015 L LINK,ADQUA PRINT OUT AND REWIND 3261 60370015 BALR RETN,LINK 3261 60380015 TSTMAP TM PROCBITS+1,MAP 3261 60390015 BZ CALLP30 3261 60400015 L LINK,ADMAP 3261 60410015 BALR RETN,LINK 3261 60420015 B CALLP30 SKIP 20 AND 25 3261 60430015 * 60480014 * CALL PHASE 20 60560014 CP20 MVI 83(NPTR),16 PHASE SW,NPTR(1,11) 3261 60640015 L LINK,ADDRPH20 60720014 BALR RETN,LINK 60800014 TM 86(NPTR),128 CK THE TIMING SWITCH 60880014 BZ *+8 60960014 BAL LAST,TOF TURN THE TIMER OFF 61040014 TM 87(NPTR),64 TRACE AFTER THE PHAZE 61120014 BZ NTP20 61200014 * TEXT, NPTR,DICT 61280014 LA ARG,DEC26 61360014 L LINK,ADDRTABS 61440014 BALR RETN,LINK 61520014 NTP20 EQU * 61600014 * 61680014 * 61760014 INIT25 EQU * 61840014 * CALL PHASE 25 61920014 MVI 83(NPTR),32 PHASE SW, NPTR (1,11) 62000014 L LINK,ADDRPH25 62080014 BALR RETN,LINK 62160014 TM 86(NPTR),128 CK THE TIMING SWITCH 62240014 BZ NOTIME 62320014 L LINK,APHASS 62400014 BALR RETN,LINK 62480014 L LINK,ATOUT CALL TOUT FOR TIMING OUTPUT 62560014 BALR RETN,LINK 62640014 NOTIME EQU * 62720014 CALLP30 TM 279(NPTR),ANY TEST ERROR SW NPTR(2,35) 62727014 BZ GOON NO ERRORS 62734014 L R15,ADNPTR 62735018 L R15,172(R15) NUMBER OF ERRORS 62736018 BCTR R15,0 62737018 L R14,NUMERR NUMBER OF ERRORS SO FAR 62738018 AR R14,R15 62739018 ST R14,NUMERR TOTAL 62740018 MVI 83(NPTR),64 PHASE SW NPTR(1,11) 62741014 L LINK,ADDRPH30 62748014 BALR RETN,LINK 62755014 L AA02,ADAA02 62758019 L SWCH,276(NPTR) ERROL LEVEL 62762014 CH SWCH,ERRCODE 62769014 BL GOON SAVE HIGHEST ERROR LEVEL 62776014 STH SWCH,ERRCODE 62783014 GOON EQU * 62790014 L SWCH,276(NPTR) TEST FOR FORMAT ERRORS 62800014 CH SWCH,ERRCODE 62880014 BNH ENDCOMP 62960014 STH SWCH,ERRCODE 63040014 ENDCOMP EQU * 63120014 LA ARG,STATPARM 63122018 L LINK,ADFIOCS TEMPNAME 63124018 BALR RETN,LINK 63126018 L GRX,0(1) 63128018 * FIRST OPTIONS LINE 63129019 MVC 0(OPLGTH,GRX),OPTMSG 63130018 MVC OPLGTH(90,GRX),OPTLINE+LGTH1-1 63132019 LA ARG,HEADPARM 63134018 L LINK,ADFIOCS 63136018 BALR RETN,LINK 63138018 L GRX,0(1) 63140018 * SECOND OPTIONS LINE 63142019 MVC 0(OPLGTH,GRX),OPTMSG 63144018 MVC OPLGTH(90,GRX),OPTLINE1+LGTH1-1 63146019 LA ARG,STATPARM 63148018 L LINK,ADFIOCS 63150018 BALR RETN,LINK 63152018 L GRX,0(1) 63154018 L RA,280(NPTR) NO OF SOURCE STATEMENTS 63156018 CVD RA,PACKED 63158018 UNPK STATMSG+37(8),PACKED(8) 63160018 OI STATMSG+44,X'F0' GET RID OF SIGN 63162018 LA SCAN,STATMSG+37 63164018 BAL RETN,BLANK 63166018 L RA,160(NPTR) SIZE IN BYTES 63168018 LTR RA,RA 63168619 BZ ZEROSIZE 63169219 CVD RA,PACKED 63170018 UNPK STATMSG+62(8),PACKED(8) 63172018 OI STATMSG+69,X'F0' GET RID OF SIGN 63174018 LA SCAN,STATMSG+62 63176018 BAL RETN,BLANK 63178018 MOVEMSG MVC 0(SLGTH,GRX),STATMSG 63180019 LH R1,ONLYONE KEEP TOTAL NO. OF COM ILATIONS 63183018 LA R1,1(R1) 63186018 STH R1,ONLYONE 63189018 LA ARG,STATPARM 63192018 L LINK,ADFIOCS 63195018 BALR RETN,LINK 63198018 L GRX,0(1) 63201018 MVC 0(14,GRX),LASTMSG1 ERROR MESSAGE FOR EACH 63204018 MVC 18(22,GRX),LASTMSG4 COMPILATION 63207018 L R1,ADNPTR 63210018 L R1,172(R1) 63213018 BCTR R1,0 63216018 LTR R1,R1 63219018 BZ NOERRS 63222018 CVD R1,PACKED 63225018 UNPK 14(4,GRX),PACKED+6(2) 63228018 OI 17(GRX),X'F0' 63231018 LA SCAN,14(GRX) 63234018 BAL RETN,BLANK 63237018 MVC 40(26,GRX),LASTMSG3 HIGHEST SEVERITY LEVEL 63240018 L R1,276(NPTR) LOAD PRESENT ERROR LEVEL 63243018 CVD R1,PACKED 63246018 UNPK 67(2,GRX),PACKED+6(2) 63247019 LA SCAN,67(GRX) BLANK OUT LEADING ZEROS 63249019 BAL RETN,BLANK 63250019 OI 68(GRX),X'F0' GET RID OF SIGN 63252021 B ENDIT 63255018 NOERRS MVC 14(3,GRX),NO 63258018 ENDIT LA ARG,ENDPARM PARAMETER LIST 63261018 L LINK,ADFIOCS ADDRESS OF FIOCS 63280014 BALR RETN,LINK GET BUFFER 63360014 L GRX,0(1) ADDRESS OF BUFFER 63440014 MVC 0(LGTH2,GRX),ENDMSG MOVE MSG INTO BUFFER 63520014 TM IND,X'01' 63522019 BO ALLUSED 63524019 BAL RETN,FINDCORE 63526019 ST RA,CORETOT+8 63528019 C RA,CORETOT+4 63530019 BNL COMP2 63532019 L RA,CORETOT+4 63534019 COMP2 C RA,CORETOT 63536019 BNL FINAL 63538019 L RA,CORETOT 63540019 FINAL L LINK,AMTCORE 63542019 SR LINK,RA 63544019 BNP ALLUSED 63546019 SR RETN,RETN WAS NOT USED. 63550019 D RETN,KAY 63560019 CH LINK,H10 LESS THAN 10? 63570019 BL ALLUSED 63580019 CVD LINK,PACKED PRINT OUT MESSAGE 63590019 UNPK 59(16,GRX),PACKED(8) 63600019 OI 74(GRX),X'F0' GET RID OF SIGN 63610019 LA SCAN,59(GRX) 63620019 BAL RETN,BLANK BLANK OUT LEADING ZEROS 63630019 MVC 75(24,GRX),UNUSED 63640019 ALLUSED BAL RETN,FINDFREQ 63650019 L RA,BLKCHN+16 P15+20 TEXT 63680014 ST RA,0(QUE) PUT IN FREE QUE 63760014 XC BLKCHN+16(4),BLKCHN+16 ZERO CHAIN 63840014 BAL RETN,FINDFREQ 63920014 L RA,BLKCHN+8 DICTIONARY 64000014 ST RA,0(QUE) PUT INTO FREE QUE 64080014 XC BLKCHN+8(4),BLKCHN+8 ZERO CHAIN 64160014 BAL RETN,FINDFREQ 64250014 L RB,BLKCHN+12 64260014 ST RB,0(QUE) 64270014 XC BLKCHN+12(4),BLKCHN+12 64280014 B AGAIN PROCESS NEXT ROUTINE 64300014 * 64305019 ZEROSIZE MVC STATMSG+61(9),EBCZERO PROGRAM OF SIZE ZERO 64310019 B MOVEMSG 64315019 * 64320014 * CALLING SEQUENCES TO THE TIMING ROUTINE 64400014 * 64480014 BLANK CLI 0(SCAN),X'F0' BLANK OUT LEADING ZEROS 64490018 BCR 6,RETN IF GREATER THAN ZERO, RETURN 64500021 MVI 0(SCAN),X'40' MOVE IN A BLANK 64510018 LA SCAN,1(SCAN) PICK UP NEXT NUMBER 64520018 B BLANK 64530018 TOF L LINK,ATSP 64560014 BALR RETN,LINK 64640014 BR LAST 64720014 ATST DC V(PHASB) START TIMER 64800014 ATOUT DC V(TOUT) PRINT THE TIMES 64880014 ATSP DC V(PHAZSS) STOP CURRENT TIMER -- START NEXT 64960014 APHASS DC V(PHASS) 65040014 ADQUA DC V(IEKQAA) 3261 65060015 ADMAP DC V(IEKGMP) 3261 65080015 KAY DC F'1024' 65100019 ONLYONE DC H'0' 65110018 ENDMSG DC C'0****** END OF COMPILATION ******' 65140016 LGTH2 EQU *-ENDMSG 65200014 LASTMSG1 DC C'0*STATISTICS* ' 65206018 LASTMSG2 DC C' DIAGNOSTICS THIS STEP' 65212018 LASTMSG3 DC C', HIGHEST SEVERITY CODE IS ' 65218018 LASTMSG4 DC C' DIAGNOSTICS GENERATED ' 65224018 NO DC C' NO' 65230018 NORMAL DC X'00' 65236018 STATMSG DC C'0*STATISTICS* SOURCE STATEMENTS = ,PROGRAM*65242018 SIZE = ' 65248018 SLGTH EQU *-STATMSG 65254018 OPTMSG DC C'0*OPTIONS IN EFFECT* ' 65260018 OPLGTH EQU *-OPTMSG 65266018 EBCZERO DC C' 0' 65273019 * 65280014 EJECT 65360014 * 65440014 ENTRY IEKAGC GETCOR 65520014 IEKAGC STM RETN,RETN-2,12(SAVE) SAVE CALLER'S REGISTERS 65600014 * GETCOR HAS NO SAVE AREA 65680014 USING IEKAGC,LINK 65760014 DROP BASE 65840014 L BASE,ADIEKAA0 65920014 DROP LINK 66000014 USING IEKAA00,BASE 66080014 L AA02,ADAA02 66120019 * 66160014 L ARG,0(ARG) 66240014 L R3,0(ARG) 66320021 * 66400014 L NPTR,ADNPTR ADDRESS OF NPTR TABLE 66480014 SR RA,RA 66560014 C RA,FREQUE MORE FREQUE 66640014 BC 8,NEEDMORE 66720014 SR RB,RB 66770019 FINDCHN BAL RETN,FINDFREQ 66820019 L RA,AMTTXT 66880014 C RA,4(QUE) MORE THAN 2K 66960014 BC 8,AOK NO NEED TO CARVE IT 67040014 BC 2,TESTMORE 67120019 L RB,4(QUE) LENGTH OF BLOCK 67200014 SR RB,RA 67280014 ST RB,4(QUE) NEW LENGTH 67360014 AR QUE,RB BEGINNING OF NEW BLOCK 67440014 ST RA,4(QUE) 67520014 SR FIRST,FIRST 67600014 ST FIRST,0(QUE) ZERO END OF CHAIN 67680014 B STORBLK 67760014 AOK XC 0(4,RB),0(RB) ZERO CHAIN FIELD 67840014 STORBLK LR FIRST,QUE ADDRESS OF CURRENT BLOCK 67920014 STORE SLA R3,2 FOR INDEX 67970021 L RB,CORECHN(R3) 68000021 A RB,AMTTXT 68040019 ST RB,CORECHN(R3) 68060021 LA QUE,BLKCHN(R3) FIND CHAIN 68110021 BAL RETN,FINDEND 68160014 ST FIRST,0(QUE) CHAIN IN NEW BLOCK 68240014 LR LAST,FIRST 68320014 LA FIRST,8(FIRST) BUMP PAST CHAIN + LENGTH 68400014 LR QUE,FIRST ADDRESS OF FIRST 68480014 L RB,AMTTXT 68560014 AR LAST,RB LAST BYTE IN BLOCK 68640014 BCTR LAST,0 LAST BYTE IN BLOCK 68720014 SH RB,H8 DON'T ZERO CHAIN FIELD 68800014 BAL RETN,ZEROBLK ZERO 68880014 LR FIRST,QUE RESTORE ADDRESS OF FIRST 68960014 CH R3,H4 69040021 BC 8,SPEC P10 SPECIAL TEXT 69120014 BC 4,ALLTEXT P10 NORMAL TEXT 69200014 CH R3,H8 69280021 BC 2,ALLTEXT P15,P20,DATA TEXT 69360014 DICTXT ST FIRST,228(NPTR) NPTR(2,9) FIRST SPACE TO UE 69440014 ST LAST,236(NPTR) NPTR(2,30) END OF DICT 69520014 B EXITCOR 69600014 SPEC L CP10A,ADP10A 69680014 ST FIRST,X'A80'+8(CP10A) SLIMS(1,NTAB) 69780021 ST LAST,X'A84'+8(CP10A) SLIMS(2,NTAB) 69880021 B EXITCOR 70000014 ALLTEXT ST FIRST,64(NPTR) NPTR(1,9) NEXT TEXT LOC 70080014 ST LAST,68(NPTR) NPTR(2,9) LAST TEXT LOC 70160014 EXITCOR EQU * 70240014 LM RETN,RETN-2,12(SAVE) 70320014 MVI 12(SAVE),ALL 70400014 BR RETN 70480014 NEEDMORE EQU * 70540019 CH R3,H4 70590021 BE ENDTXT 70640014 MVI QUITCODE,MSG1 P10,SPEC,DATA,DICT 70720014 CLI 83(NPTR),1 COMP DELETED IN PHASE 10? 70728021 BNE QUIT IF NOT, QUIT 70736021 TM 18(NPTR),X'01' WAS XREF REQUESTED? 70744021 BZ QUIT IF NOT QUIT 70752021 LA ARG,WINDXREF GO TO FIOCS TO REWIND XREF 70760021 LA SAVE,IEKSAVE OUR SAVE AREA IN 13 70768021 L LINK,ADFIOCS 70776021 BALR RETN,LINK 70784021 B QUIT NO MORE CORE 70800014 TESTMORE LA ZERO,FREQUE 70810019 CR ZERO,RB WAS THERE ONLY ONE ELEMENT IN 70820019 BE NEEDMORE THE CHAIN 70830019 SR ZERO,ZERO 70832021 ST ZERO,0(RB) REMOVE BLOCKS LESS 70834021 * THAN 4K FROM CHAIN 70836021 ST QUE,ADDRESS 70838021 MVC LENGTH(4),4(QUE) 70838421 FREEMAIN V,A=ANSWER,SP=1 FREE BLOCKS 70838821 B FINDCHN BRANCH TO FIND END OF CHAIN 70839221 EJECT 70880014 ENDTXT L FIRST,BLKCHN P10 NORMAL TEXT 70960014 LTR FIRST,FIRST FOR P20 WILL BE 0 71040014 BNZ OVERRITE 71120014 MVI QUITCODE,MSG4 P20 TEXT, P15 TEXT 71200014 B QUIT NO MORE CORE 71280014 OVERRITE L RB,56(NPTR) NPTR(1,8) NEXT TEXT ITEM 71360014 LA RB,0(RB) CLEAR HIGH ORDER BYTE 71440014 SR RB,FIRST 71520014 BC 4,CHAININ NOT IN THIS BLOCK 71560014 C RB,AMTTXT 71600014 BC 2,CHAININ NOT IN THIS BLOCK 71680014 MVI QUITCODE,MSG3 P15 TEXT, P20 TEXT 71760014 B QUIT NO MORE CORE 71840014 CHAININ L RB,0(FIRST) 71920014 MVI IND,X'01' 71960019 ST RB,BLKCHN DELETE FROM CHAIN 72000014 XC 0(4,FIRST),0(FIRST) ZERO CHAIN FIELD 72080014 B STORE 72160014 EJECT 72240014 * INTERNAL SUBROUTINES FOR TEXT 72320014 * ALLOCATION 72400014 * FINDS END OF CHAIN OF BLOCKS 72480014 FINDFREQ LA QUE,FREQUE 72560014 FINDEND L RA,0(QUE) LOAD CONTENTS 72640014 LTR RA,RA TEST 72720014 BCR 8,RETN BRANCH WITH END OF CHAIN 72800014 LR RB,QUE SAVE NEXT TO LAST BLOCK 72880014 L QUE,0(QUE) CHAIN TO NEXT BLOCK 72960014 B FINDEND 73040014 * 73120014 * 73200014 FINDCORE L RA,CORECHN 73210019 LA RB,CORECHN 73220019 LA QUE,4(0) 73230019 FINDLOOP LA RB,4(RB) 73240019 A RA,0(RB) 73250019 BCT QUE,FINDLOOP 73260019 BR RETN 73270019 EJECT 73280014 * 73360014 ENTRY IEKIORTN 73440014 * ENTRY FROM IBCOM ON I/O ERROR 73520014 CNOP 0,4 73600014 IEKIORTN BALR LINK,0 73680014 USING *,LINK 73760014 L AA02,ADAA02 73800019 L BASE,ADIEKAA0 73840014 DROP LINK 73920014 MVI QUITCODE,MSG6 ERROR MSG.6, IBCOM FOUND ERROR 74000014 B QUIT DELETE COMPILATION 74080014 * 74160014 * 74240014 * 74320014 * ENTRY FROM IBCOM ON END-D-S 74400014 ENTRY ENDFILE 74480014 USING *,RETN END-EXIT DEFINED IN GETCD 74560014 ENDFILE L BASE,ADIEKAA0 74640014 DROP RETN 74720014 L AA02,ADAA02 74760019 MVI QUITCODE,MSG7 ERROR MSG.7, END-FILE 74800014 L NPTR,ADNPTR ADDRESS OF NPTR TABLE 74880014 TM 11(NPTR),ANY HAS GETCD READ ANYTHING ? 74960014 BC 5,QUIT IF YES, DELETE. 75040014 TM 103(NPTR),ANY SEE IF FSD HAS READ 75042021 BC 5,QUIT IF YES,DELETE 75044021 MVI NORMAL,X'01' 75045018 OUT LA R5,BLKCHN+20 75050016 LA R4,4 75060016 LA RA,BLKCHN 75070016 BEGCHN L RB,0(RA) 75080016 LTR RB,RB 75090016 BZ NXTBLK 75100016 CHAIN ST RB,ADDRESS 75110016 MVC LENGTH(4),4(RB) 75120016 L RB,0(RB) 75130016 FREEMAIN V,A=ANSWER,SP=1 75140016 LTR RB,RB 75150016 BNZ CHAIN 75160016 NXTBLK BXLE RA,R4,BEGCHN 75170016 TM NORMAL,X'01' 75170318 BZ CLOSE 75170618 LH R1,ONLYONE 75170918 CH R1,H1 75171218 BNH CLOSE 75171518 LA ARG,STATPARM WRITE OUT NUMBER OF DIAG 75171818 L LINK,ADFIOCS FOR EACH STEP 75172118 BALR RETN,LINK 75172418 L GRX,0(1) 75172718 MVC 0(14,GRX),LASTMSG1 75173018 MVC 18(22,GRX),LASTMSG2 75173318 L R1,NUMERR 75173618 LTR R1,R1 75173918 BZ NOERR 75174218 CVD R1,PACKED 75174518 UNPK 14(4,GRX),PACKED+6(2) 75174818 OI 17(GRX),X'F0' GET RID OF SIGN 75175118 LA SCAN,14(GRX) 75175418 BAL RETN,BLANK 75175718 MVC 40(27,GRX),LASTMSG3 75176018 LH R1,ERRCODE HIGHEST SEVERITY 75176318 CVD R1,PACKED 75176618 UNPK 67(2,GRX),PACKED+6(2) 75176719 LA SCAN,67(GRX) BLANK OUT LEADING ZEROS 75176919 BAL RETN,BLANK 75177019 OI 68(GRX),X'F0' GET RID OF SIGN 75177421 B CLOSE 75177518 NOERR MVC 14(3,GRX),NO 75177818 CLOSE LA ARG,CLOSPARM 75187818 L LINK,ADFIOCS ADDRESS OF FIOCS 75200014 BALR RETN,LINK 75280014 OUTQUICK LA SAVE,IEKSAVE SAVE AREA FOR FREEMAIN 75360014 L GRX,HLDSPIE 75390015 SPIE MF=(E,(GRX)) SET PREVIOUS SPIE ACTIVE 75420015 L RETN,HISPM 75450015 SPM RETN RESET PROGRAM MASK 75480015 L SAVE,IEKSAVE+4 75520014 LM RETN,RETN-2,12(SAVE) 75600014 MVI 12(SAVE),EXIT 75680014 DROP BASE 75760014 USING IEKAA00,LINK 75840014 LH LINK,ERRCODE CONDITION CODE FOR STEP 75920014 BR RETN 76000014 * 76080014 EJECT 76160014 * 76240014 * ENTRY FOR IMMEDIATE DELETION 76320014 USING IEKAA00,BASE 76400014 ENTRY IEKAA9 SYSDIR 76480014 USING IEKAA9,LINK 76560014 IEKAA9 L BASE,ADIEKAA0 76640014 DROP LINK 76720014 * 76800014 L AA02,ADAA02 76805019 ST ARG,PARSAV 3261 76810015 LA ARG,WINDPARM ALWAYS REWIND 3261 76820015 L LINK,ADFIOCS 3261 76830015 BALR RETN,LINK 3261 76840015 L ARG,PARSAV 3261 76850015 LA SAVE,IEKSAVE 76880014 L ARG,0(ARG) 76960014 L NPTR,ADNPTR ADDRESS OF NPTR TABLE 77040014 L ARG,0(ARG) 77120014 SH ARG,H1 PHASE 10 'RETURNS' BY CALLING 77200014 BZ RTNPH10 WITH ARG=1 77280014 BM PGMINT 77360014 MVI QUITCODE,MSG5 ERROR MSG.5, PANIC CALL 77440014 B QUIT 77520014 * 77600014 PGMINT MVI QUITCODE,MSG2 ERROR MSG.2, PROG. INTER. 77680014 TM PARMSW,ALL IF STILL PROCESSING PARMS, 77760014 BO NEXT TRY NEXT ONE 77840014 * 77920014 ENTRY QUIT 77940019 QUIT EQU * 77960019 TM PROCBITS,DUMP 78000019 BO DUMPNOW 78080014 * 78160014 LA SAVE,IEKSAVE 78220019 L AA02,ADAA02 78280019 MVI ERRCODE+1,16 SET HIGHEST COND-CODE 78320014 SR ARG,ARG SET SPECIAL INDICATOR 78340017 L 15,VEND CALL IEKTLOAD TO 78360017 BALR 14,15 RESET PARAMETERS. 78380017 * 78400014 L LINK,ADFIOCS ADDRESS OF FIOCS 78480014 LA ARG,QUITPARM 78560014 BALR RETN,LINK GET BUFFER 78640014 L GRX,0(1) ADDRESS OF BUFFER 78720014 MVC 0(QUITLGTH,GRX),QUITMSG 78800014 TM BEG,X'01' TEST TO SEE IF IN GETMAIN 78820014 BO OUT 78840014 * 78880014 CLI QUITCODE,MSG6 78960014 BE OUTQUICK DELETE STEP, MSG6 79040014 BH TESTERR TEST FOR ERRORS, MSG 7 79120014 * 79200014 TESTEND TM 99(NPTR),ANY 79280014 BM TESTERR 79360015 L LINK,ADDRREAD READ TO END CARD 79440014 BALR RETN,LINK 79520014 TESTERR EQU * 79760014 TM 279(NPTR),ANY ANY ERROR MSGS ? 79840014 BZ NOPH30 NO 79920014 L R15,ADNPTR 79930018 L R15,172(R15) 79940018 BCTR R15,0 79950018 L R14,NUMERR NUMBER OF ERRORS SO FAR 79960018 AR R14,R15 79970018 ST R14,NUMERR 79980018 MVI 83(NPTR),64 80000014 L LINK,ADDRPH30 80080014 BALR RETN,LINK 80160014 NOPH30 EQU * 80240014 CLI QUITCODE,MSG7 WAS ENDFILE READ ? 80320014 BE OUT YES 80400014 SR ZERO,ZERO 80407014 LA R5,BLKCHN CHAIN OF BLOCKS 80414014 LA GRY,16 80421014 LA GRX,4 80428014 SR R4,R4 80435014 REINIT BAL RETN,FINDFREQ 80442014 L RA,0(R4,R5) POINTER TO CURRENT CHAIN 80449014 ST RA,0(QUE) PUT INTO FREE QUE 80456014 ST ZERO,0(R4,R5) ZERO CHAIN 80463014 BXLE R4,GRX,REINIT 80470014 B AGAIN GO REINIT FOR PHASE 10 80480014 USING *,LINK 80490015 ARITH L LINK,ADIBCOM 80500015 BC 15,IBARITH(0,LINK) 80510015 DROP LINK 80520015 DUMPNOW EQU * 80560014 LH COUNT,ABENDCNT LOOP TRYING TO CLOSE FILES ? 80562020 BCT COUNT,ABENDNOW YES BRANCH TO GET DUMP 80564020 LA COUNT,2(0) WITHOUT FINAL CALL TO FIOCS 80566020 STH COUNT,ABENDCNT 80568020 L LINK,ADFIOCS ADDRESS OF FIOCS 80570019 LA ARG,QUITPARM 80580019 BALR RETN,LINK GET BUFFER 80590019 L GRX,0(1) ADDRESS OF BUFFER 80600019 MVC 0(QUITLGTH,GRX),QUITMSG 80610019 LA ARG,CLOSPARM CLOSE DATA SETS 80640014 L LINK,ADFIOCS ADDRESS OF FIOCS 80720014 BALR RETN,LINK 80800014 ABENDNOW ABEND 16,DUMP 80880020 * 80960014 ABENDCNT DC H'1' 81000020 EJECT 81040014 * 81120014 * 81520014 * CONSTANTS 81600014 H1 DC H'1' 81680014 H4 DC H'4' 81760014 H8 DC H'8' 81840014 H40 DC H'40' 81920014 H56 DC H'56' 82000014 H10 DC H'10' 82040019 * 82080014 F256 DC F'256' 82160014 ONEK DC F'1024' 82200014 * 82240014 DS 0H 82800014 OPSW DC H'0' 82810018 HISPM DS F OLD PROGRAM MASK 82820015 HLDSPIE DS F OLD SPIE 82840015 * 82880014 AMTTXT DC F'4096' 83040014 ENTRY ANSWER 83120019 ANSWER EQU * 83200014 ADDRESS DS 1F 83280014 LENGTH DS 1F 83360014 DICTARG DC A(D2) 83440014 IEKSAVE DS 18F SAVE AREA 83520014 PARSAV DS 1F 3261 83560015 ERMSNO DC F'410' 83570019 ADERR DC A(IEKAER) 83580019 * 83600014 * CALLING SEQUENCES FOR SYSTAB 83680014 DEC29 DC XL1'80' 83760014 DC AL3(D29) 83840014 D29 DC F'29' 83920014 DEC24 DC XL1'80' 84000014 DC AL3(D24) 84080014 D24 DC F'24' 84160014 DEC26 DC XL1'80' 84240014 DC AL3(D26) 84320014 D26 DC F'26' 84400014 DEC2 DC XL1'80' 84480014 DC AL3(D2) 84560014 D2 DC F'2' 84640014 * 84720014 ADFIOCS DC V(FIOCS#) 84800014 ADIBCOM DC V(IBCOM#) 84880014 ADIEKAA0 DC A(IEKAA00) ADDR OF THIS CSECT 84960014 ADNPTR DC A(IEKAAA) 85120014 ADP10A DC A(IEKCAA) 85200014 EXTRN IEKCAA 85280014 ADADCON DC A(IEKAAD) 85360014 EXTRN IEKAAD 85400016 ADDRPH10 DC V(IEKCIN) 85440014 ADDRREAD DC V(IEKAREAD) 85520014 ADDRXREF DC V(IEKXRF) 85600014 ADDRXRS DC V(IEKXRS) 85680014 ADDRSTAL DC V(IEKGST) 85760014 ADDRPH15 DC V(IEKJA) 85840014 ADDRCORA DC V(IEKGCR) 85920014 ADDRPH20 DC V(IEKPLS) 86000014 ADDRPH25 DC V(IEKTA) 86080014 ADDRTABS DC V(IEKATB) 86160014 ADDRPH30 DC V(IEKP30) 86240014 VEND DC A(IEKUND) 86260017 EXTRN IEKUND 86280017 PACKED DC D'0' 86310019 ADAA01 DC A(IEKAA01) 86320021 EXTRN IEKAA01 86330021 ADAA02 DC A(IEKAA02) 86340019 ADAINT DC V(IEKAINIT) 86370019 PARMLIST DC F'0' ADDRESS OF PARMS 86400019 NEXT L LINK,ADAINT 86430019 SR ARG,ARG 86460019 BR LINK 86490019 CNOP 0,4 86560014 NUMERR DC F'0' 86600018 CORETOT DS 3F 86620019 CLOSPARM DC X'05' 86640014 ERRCODE DS H 86680019 CNOP 0,4 86720014 READPARM DC X'02',X'05',H'80' 86800014 QUITPARM DC XL1'3',XL1'6',H'23' 86880014 ENDPARM DC XL1'3',XL1'6',H'100' 86960019 HEADPARM DC XL1'3',XL1'6',H'120' 87040014 WINDPARM DC XL1'4',XL1'8',H'0' 3261 87080015 WINDXREF DC XL1'4',XL1'9',H'0' REWINDS XREF 87090021 STATPARM DC XL1'3',XL1'6',H'70' 87100018 UNUSED DC C'K BYTES OF CORE NOT USED' 87110019 IND DS X 87116019 EJECT 87123019 * 87126019 IEKAA02 CSECT 87129019 * 87132019 PROCDD EQU * 87135019 SYSLIN DS D'0' 87138019 SYSIN DS D'0' 87141019 SYSPRINT DS D'0' 87144019 SYSPUNCH DS D'0' 87147019 SYSUT1 DS D'0' 87150019 SYSUT2 DS D'0' 87153019 NUMDD EQU 6 87156019 DEFDD EQU * DEFAULT DDNAMES (ORDER DEPEN) 87159019 DC CL8'SYSLIN ' 1 87162019 DC CL8'SYSIN ' 2 87165019 DC CL8'SYSPRINT' 3 87168019 DC CL8'SYSPUNCH' 4 87171019 DC CL8'SYSUT1 ' 5 87174019 DC CL8'SYSUT2 ' 6 87177019 * 87180019 PROCPARM DS 2F NAME 87183019 PROCOPT DS F OPT= 87186019 DS F 87189019 DS F 87192019 PROCLINE DS F LINECNT= 87195019 DS F BIT SWITCHES 87198019 PROCBITS EQU PROCPARM+26 87201019 PGHDLGTH EQU 120 87204019 ENTRY PAGEHEAD 87207019 PAGEHEAD DC CL120'1 LEVEL 21 (OCT 71) O187210021 S/360 FORTRAN H DATE Y287213019 Y.DDD/HH.MM.SS' 87216019 YEAR EQU PAGEHEAD+105 87219019 HOUR EQU YEAR+7 87222019 DS 0D 87225019 TEMPNAME DC D'0' 87228019 * PTRS FOR GETCOR 87243019 BLKCHN DS 6F 87246019 FREQUE EQU BLKCHN+20 87249019 CORECHN DS 6F 87249319 AMTCORE EQU CORECHN+20 87249619 FC DS X FIRST COMPILATION 87250019 ERRSW DS 1X 87250519 BEG DS X GETMAIN SWITCH 87251019 OPTLINE DC CL120'0 COMPILER OPTIONS -' 87252019 OPTLINE1 DC CL120' ' 87253019 OPTLGTH EQU 120 87255019 PARMSW DC X'00' SET TO 'FF' WHILE PROC. PARMS 87258019 QUITLGTH EQU 23 87261019 QUITMSG DC CL23'0COMPILATION DELETED. 0' 87264019 QUITCODE EQU QUITMSG+22 87267019 EJECT 87280014 DUMIEK DSECT 87320016 * THIS DSECT IS A DUMMY 87360016 * OF CSECT IEKAA01 87400016 DEFAULTS DC CL8' MAIN' NAME GIVEN TO MAIN PGM BY DEFAULT 89280014 DC F'0' OPTIMIZATION LEVEL BY DEFAULT 89360014 DC F'0' TRACE SWITCH 89440014 DC F'0' 89480015 DC F'50' LINECOUNT BY DEFAULT 89520014 * XREF,ID,EDIT,MAP,LOAD,DECK,LIST,BCD,SOURCE 89600014 * ARE INDICATED BY BITS ON 89680014 DC BL4'0000010001' 89760014 CMPLRSIZ DS 1F COMPILER SIZE WITH INSTALLATION-DETERMINED TABLES 90160021 HEADER DS 7F LEFT-HAND SECTION OF LISTING HEADING (LVL AND DATE) 90560021 SPACE 3 91040014 IEKAER CSECT 91120014 ERLGTH EQU 100 91200014 DS 200F 91280014 SPACE 3 91600014 IEKAAA CSECT 91680014 DS 72F 91760018 END 91840014 ./ ADD SSI=08012094,NAME=IEKAA01,SOURCE=0 EJECT 01000019 IEKAA01 CSECT 02000019 DEFAULTS DC CL8' MAIN' NAME GIVEN TO MAIN PGM BY DEFAULT 27000019 DC F'0' OPTIMIZATION LEVEL BY DEFAULT 28000019 DC F'0' TRACE SWITCH 29000019 DC F'0' 30000019 DC F'50' LINECOUNT BY DEFAULT 31000019 * XREF,ID,EDIT,MAP,LOAD,DECK,LIST,BCD,SOURCE 32000019 * ARE INDICATED BY BITS ON 33000019 DC BL4'0000010001' 34000019 BLNKSIZE DC F'31744' 44000019 IEKAAD CSECT 51200019 DC F'600' SIZE IN WORDS OF ADCON TABLE 51400019 DS 600F 51600019 END 52000019 ./ ADD SSI=00011350,NAME=IEKAFP,SOURCE=0 IEKAFP START 0 01000014 ENTRY AFIXPI 02000014 EXTRN IBCOM 03000014 ENTRY FIXPI 04000014 ENTRY FIXPI# 05000014 * FIXED POINT BASE, FIXED POINT EXPONENT LIBRARY ROUTINE 06000014 DC CL5'FIXPI' NAME OF THIS EXPONENTIAL ROUTINE 07000014 DC X'05' LENGTH OF NUMBER OF CHARS IN NAME 08000014 USING *,LINK MAKE LINK REG THE BASE ADDRESS REG 09000014 AFIXPI EQU * 10000014 FIXPI STM RTN,ADDR,12(SAVE) STORE CURRENT VALUES OF GP REG 14 -7 11000014 L ADDR,0(0,PLIST) LOAD PLIST OF BASE NO IN ADDR REG 12000014 L BASE,0(0,ADDR) LOAD BASE NO INTO BASE NO REG 13000014 L ADDR,4(0,PLIST) LOAD PLIST OF EXPONENT IN ADDR REG 14000014 L EXPN,0(0,ADDR) LOAD EXPONENT INTO EXPN REG 15000014 LR RESULT,BASE LOAD BASE NO INTO RESULT REG 16000014 LTR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 17000014 BC 8,ERROR IF BASE NO IS ZERO, BRANCH TO ERROR 18000014 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 19000014 BC 8,LOAD1 IF EXPONENT IS ZERO, BRANCH TO LOAD1 20000014 BCTR BASE,0 DECREMENT BY ONE VALUE OF BASE NO 21000014 LTR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 22000014 BC 8,EXIT IF BASE NO NOW ZERO, BRANCH TO EXIT 23000014 LA BASE,2(BASE) INCREMENT BY TWO VALUE OF BASE NO 24000014 LTR BASE,BASE CHECK IF BASE NO PLUS, MINUS,OR ZERO 25000014 BC 8,TEST IF BASE NO NOW ZERO, BRANCH TO TEST 26000014 LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 27000014 BC 2,PLUS IF EXPN IS POSITIVE, BRANCH TO PLUS 28000014 SR RESULT,RESULT EXPN MINUS,MAKE VALUE OF RESULT ZERO 29000014 BC 15,EXIT BRANCH TO EXIT TO LEAVE THIS ROUTINE 30000014 PLUS LR BASE,RESULT RELOAD ORG BASE NO FROM RESULT REG 31000014 L FACTOR,ONE LOAD FACTOR OF ONE IN FACTOR REG 32000014 LOOP SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 33000014 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 34000014 BC 10,JUMP IF SIGN BIT NOT MINUS,BRANCH TO JUMP 35000014 MR FACT,BASE MULTIPLY FACTOR REGS BY BASE NO REGS 36000014 JUMP LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 37000014 BC 8,NEXT IF EXPONENT NOW ZERO, BRANCH TO NEXT 38000014 MR BASE1,BASE MULTIPLY BASE NO BY DOUBLING ITSELF 39000014 BC 15,LOOP BRANCH TO LOOP TO TEST NEXT EXPN BIT 40000014 NEXT LR RESULT,FACTOR LOAD FACTOR (ANSWER) INTO RESULT REG 41000014 BC 15,EXIT BRANCH TO EXIT TO LEAVE THIS ROUTINE 42000014 TEST SRDL EXPN,1 SHIFT LOW BIT EXPN REG INTO ADDR REG 43000014 LTR ADDR,ADDR TEST SIGN POS ADDR REG FOR MINUS BIT 44000014 BC 4,EXIT IF SIGN MINUS (EXPN ODD), GO TO EXIT 45000014 LOAD1 L RESULT,ONE LOAD RESULT REG WITH VALUE OF PLUS 1 46000014 EXIT LM RTN,LINK,12(SAVE) RELOAD FORMER VALUES OF GP REG 14-15 47000014 LM FACT,ADDR,28(SAVE) RELOAD FORMER VALUES OF GP REG 2 - 7 48000014 MVI 12(SAVE),X'FF' STORE ALL 1 BITS IN SAVE AREA WORD 4 49000014 BCR 15,RTN BRANCH TO ADDRESS IN RETURN REG RTN 50000014 ERROR LTR EXPN,EXPN CHECK IF EXPONENT PLUS,MINUS,OR ZERO 51000014 BC 2,EXIT IF EXPN IS POSITIVE, BRANCH TO EXIT 52000014 CNOP 0,4 SET NEXT STEP ON FULL WORD BOUNDARY 53000014 L LINK,VIBCOM LOAD LINK REG WITH ERROR RTN ADDRESS 54000014 BAL RTN,60(LINK) BRANCH TO STANDARD ERROR ROUTINE 55000014 ERMSG DC XL2'241C' BASE NO ZERO AND EXPN ZERO OR MINUS 56000014 * GENERAL PURPOSE REGISTERS 57000014 SAVE EQU 13 REGISTER CONTAINS SAVE REG AREA ADDR 58000014 RTN EQU 14 REGISTER FOR RETURN TO PREVIOUS RTN 59000014 LINK EQU 15 REGISTER FOR LINKAGE TO ANOTHER RTN 60000014 RESULT EQU 0 REGISTER FOR PASSING ON FINAL RESULT 61000014 PLIST EQU 1 REGISTER USED FOR PARAMETER LIST REF 62000014 FACT EQU 2 REGISTER USED AS MPY REG FOR FACTOR 63000014 FACTOR EQU 3 REGISTER USED FOR FACTOR AND ANSWER 64000014 BASE1 EQU 4 REGISTER USED AS MPY REG FOR BASE NO 65000014 BASE EQU 5 REGISTER FOR BASE NO IN COMPUTATION 66000014 EXPN EQU 6 REGISTER FOR EXPONENT IN COMPUTATION 67000014 ADDR EQU 7 REGISTER FOR INDEXING PARAMETER ADDR 68000014 FIXPI# EQU FIXPI 69000014 * CONSTANTS AND ADCON AREAS 70000014 ONE DC F'1' INTERGER CONSTANT OF ONE 71000014 VIBCOM DC AL4(IBCOM) ADCON OF STANDARD ERROR ROUTINE 72000014 END 73000014 ./ ADD SSI=02000674,NAME=IEKAINIT,SOURCE=0 IEKAINIT CSECT 00100019 *2094139090-139900,148100-148900,463700 20.1 35112 00120020 *2094059000 PTM1590 00150020 *0981139180-139810 20.1 35112 00170020 * 377500,463400,522600-523200 JL2108.02 00180021 * A401650-401719,A463120 LLPTM5635 00190021 * A377000,A378000 LL59707 00192021 * A139020-139040 LL61515 00194021 ********************************************************************** 00200019 * 00300019 * THIS MODULE PROCESSES PARAMETERS FROM OS/360 00400019 * AND GETS CORE FOR THE COMPILER 00500019 * 00600019 ********************************************************************** 00700019 * 00800019 * 00900019 * REGISTERS USED BY THE MODULE 01000019 ZERO EQU 0 01100019 ARG EQU 1 01200019 GRX EQU 2 01300019 END EQU 8 01400019 GRY EQU 3 01500019 RN EQU 3 01600019 FIRST EQU 4 01700019 * 01800019 TABLE EQU 4 01900019 SCAN EQU 5 02000019 RA EQU 6 02100019 RB EQU RA+1 02200019 QUE EQU 8 02300019 COUNT EQU 9 02400019 RE EQU 10 02500019 * 02600019 NPTR EQU 10 02700019 AA01 EQU 9 02800019 AA02 EQU 11 02900019 BASE EQU 12 03000019 SAVE EQU 13 03100019 RETN EQU 14 03200019 LINK EQU 15 03300019 * 03400019 * 03500019 R0 EQU 0 03600019 R1 EQU 1 03700019 R2 EQU 2 03800019 R3 EQU 3 03900019 R4 EQU 4 04000019 R5 EQU 5 04100019 R6 EQU 6 04200019 R7 EQU 7 04300019 R8 EQU 8 04400019 R9 EQU 9 04500019 R10 EQU 10 04600019 R11 EQU 11 04700019 R12 EQU 12 04800019 R13 EQU 13 04900019 R14 EQU 14 05000019 R15 EQU 15 05100019 * 05200019 * 05300019 * CONSTANTS NEEDED BY THE MODULE 05400019 NONE EQU X'00' 05500019 COMMA EQU C',' 05600019 ALL EQU X'FF' 05700019 XREF EQU X'01' 05800019 NOEDIT EQU X'BF' 05900020 EDIT EQU X'40' 06000019 DUMP EQU X'04' 06100019 LGTH1 EQU 31 06200019 MSG1 EQU C'1' 06300019 EJECT 06400019 BC 15,12(15) 06500019 DC C'IEKAINIT' 06600019 STM RETN,RETN-2,12(SAVE) SAVE CALLERS REGISTERS 06700019 LR BASE,LINK BASE REGISTER 06800019 USING IEKAINIT,BASE 06900019 LA RA,IEKSAVE 07000019 ST RA,8(SAVE) OUR SAVE AREA TO CALLER 07100019 ST SAVE,IEKSAVE+4 CALLER'S SAVE AREA TO US 07200019 LR SAVE,RA SAVE AREA FOR THOSE WE CALL 07300019 ST ARG,PARMLIST SAVE POINTER TO PARAMETERS 07400019 L AA02,ADAA02 07500019 USING DUMMI2,AA02 07600019 LTR ARG,ARG 07700019 BZ REENT 07800019 L AA01,ADAA01 07900019 USING DUMIEK,AA01 08000019 LM R2,R8,DEFAULTS DET DEFAULTS FOR COMPILER 08100019 STM R2,R8,PROCPARM 08200019 STM R2,R3,TEMPNAME IN CASE NO NAME ON EXEC CARD 08300019 * 08400019 MVC PROCDD(8*NUMDD),DEFDD SETUP DEFAULT DDNAMES 08500019 * 08600019 MVI NEWMETH,X'00' 08650019 MVI ERRSW,X'00' 08670019 L ARG,PARMLIST INITIALIZE FOR PARAMETERS 08700019 L SCAN,0(ARG) LOAD POINTER TO OPTIONS 08800019 LH COUNT,0(SCAN) LOAD NO. OF BYTES 08900019 LTR COUNT,COUNT WERE ANY PARMS PASSED ? 09000019 BZ ENDPARMS NO 09100019 * 09200019 MVI PARMSW,ALL 09300019 LA SCAN,2(SCAN) POINT TO LIST 09400019 * 09500019 * SCAN LIST, SETTING SWITCHES 09600019 * 09700019 LR END,SCAN THESE TWO DELIMIT OPTION 09800019 CKCHAR CLI 0(END),COMMA IS CHAR A COMMA ? 09900019 BE OPTS YES 10000019 CNT LA END,1(END) NO, BUMP PTR 10100019 BCT COUNT,CKCHAR DECREMENT TOTAL NO. OF CHARS 10200019 OPTS EQU * 10300019 LA TABLE,OPTIONS ADDR OF OPTIONS TABLE 10400019 LA RN,OPTNO NO. OF KEYWORDS 10500019 LR ZERO,RN TO USE AS +/- SWITCH 10600019 LR RE,END 10700019 SR RE,SCAN NO. OF CHARS FOR EXECUTE 10800019 BZ SR1 10900019 BCTR RE,0 11000019 SR1 EQU * 11100019 SR ARG,ARG 11200019 XECCOMP IC ARG,0(TABLE) NO. OF CHARS THIS ENTRY LESS 3 11300019 EX RE,COMP COMP WITH ENTRY IN TABLE 11400019 BNE NOCOMP NOT YET 11500019 * HAVE FOUND KEYWORD 11600019 * FIND MASK TO (RE)SET BIT 11700019 AR TABLE,ARG PTS TO MASK 11800019 LTR ZERO,ZERO PLUS OR MINUS ? 11900019 BP SET PLUS 12000019 NC PROCBITS(2),2(TABLE) THIS IS THE 2 MORE 12100019 B NEXT 12200019 SET OC PROCBITS(2),2(TABLE) THIS IS 2 MORE 12300019 B NEXT 12400019 NOCOMP EQU * TRY NEXT ENTRY 12500019 LA TABLE,4(ARG,TABLE) TABLE PTS TO ENTRY 12600019 LCR ZERO,ZERO FLIP SIGN 12700019 BCT RN,XECCOMP 12800019 * 12900019 * IF FALL THRU, TRY NUMERIC OPTS 13000019 * 13100019 LA RN,NONUM ACTUAL NO. TIMES 4 13200019 CKNUM IC RE,0(TABLE) CHAR FOR EXECUTE 13300019 EX RE,COMP COMP WITH ENTRY IN TABLE 13400019 BNE NOCALC 13500019 * 13600019 * HAVE FOUND KEYWORD, CONVERT 13700019 * DIGITS 13800019 LA SCAN,1(RE,SCAN) PT TO FIRST DIGIT (FOR PACK) 13900019 CR SCAN,END CHECK FOR ANY DIGIT? 13902021 BNL NEXT NO DIGITS.GO TO NEXT 13904021 ST SCAN,SAVESCAN CHECK FOR VALID DIGITS BEFORE PACK 13909020 CHKDIGIT CR SCAN,END END OF PARM ? 13918020 BNL RESUME YES PACK DIGIT 13927020 CLI 0(SCAN),X'F9' 13936020 BH NEXT IGNORE PARM INVALID DIGIT 13945020 CLI 0(SCAN),X'F0' 13954020 BL CHECKK 'K' IN SIZE PARM ? 13963020 LA SCAN,1(SCAN) 13972020 B CHKDIGIT 13981020 RESUME L SCAN,SAVESCAN YES, RESUME PROCESSING 13990020 LR RE,END 14000019 SR RE,SCAN NO. OF DIGITS 14100019 BZ EX1 14200019 BCTR RE,0 LESS ONE FOR EXECUTE 14300019 CH RN,H12 14330019 BE SIZRUTEN 14360019 EX1 EQU * 14400019 EX RE,PACK 14500019 CVB SCAN,PACKED SCAN RELOADED LATER 14600019 ST SCAN,PROCPARM+4(RN) STORE FOR COMPILER 14700019 B NEXT 14800019 * 14810020 CHECKK CLI 0(SCAN),X'D2' IS IT K 14820020 BNE NEXT NO, SKIP PARM 14830020 CH RN,H12 IS IT THE SIZE PARM ? 14840020 BNE NEXT NO, SKIP PARM 14850020 LA SCAN,1(SCAN) 14860020 CR SCAN,END IS K THE LAST CHAR OF PARM ? 14870020 BNE NEXT NO, SKIP PARM 14880020 B RESUME VALID PARM FIELD PROCESS DIGITS 14890020 NOCALC EQU * 14900019 LA TABLE,2(RE,TABLE) BUMP PTR TO NEXT KEYWORD 15000019 SH RN,H4 15100019 BP CKNUM 15200019 * 15300019 * IF FALL THRU, CHECK FOR NAME 15400019 CLC 0(5,SCAN),NAME 15500019 BNE CKDMP TRY NEXT POSSIBLE 15600019 LA SCAN,5(SCAN) SKIP 'NAME=' 15700019 MVC TEMPNAME(MAXNAME),0(SCAN) MOVE NAME TO TEMP 15800019 LA RE,MAXNAME MAX NO. OF CHARS. IN NAME 15900019 SR SCAN,END 16000019 LCR SCAN,SCAN 16100019 CR RE,SCAN 16200019 BNH MOVENAME MOVE NO MORE THAN MAXNAME 16300019 LR RE,SCAN 16400019 MOVENAME EQU * 16500019 LM RA,RB,TEMPNAME LOAD INTO EVEN/ODD PR OF REGS 16600019 LA SCAN,8(0) 16700019 SR SCAN,RE NOW HAVE NO. OF CHARS TO SHIFT 16800019 SLL SCAN,3(0) EIGHT BITS PER BYTE 16900019 SRDL RA,0(SCAN) RIGHT ADJUST 17000019 STM RA,RB,TEMPNAME STORE FOR FIRST PROG. 17100019 * CHECK FOR DUMP PARM 17200019 CKDMP CLC 0(4,SCAN),DUMPPARM 17300019 BNE NEXT IGNORE INVALID PARM 17400019 OI PROCBITS,DUMP SET DUMP SWITCH 17500019 NEXT EQU * 17600019 LA SCAN,1(END) RESET SCAN TO NEXT 17700019 LTR COUNT,COUNT WAS LAST LOOP 'FALL THRU' ? 17800019 BP CNT NO, GO TRY NEXT ONE 17900019 B ENDPARMS YES, END OF PARM LIST 18000019 * 18100019 REENT L ARG,PARMLIST 18200019 B NEXT 18300019 * 18303019 * 18306019 * 18309019 SIZRUTEN LTR RE,RE 18312019 BZ INVALID 18315019 LR ARG,END 18318019 BCTR ARG,0 18321019 CLI 0(ARG),C'K' 18324019 BNE INVALID 18327019 CH RE,H4 18330019 BH INVALID 18333019 CH RE,H2 18336019 BNH INVALID 18339019 LR ARG,RE 18342019 LR RB,SCAN 18345019 SIZLOOP CLI 0(RB),C'0' 18348019 BL INVALID 18351019 CLI 0(RB),C'9' 18354019 BH INVALID 18357019 LA RB,1(RB) 18360019 BCT ARG,SIZLOOP 18363019 BCTR RE,0 18366019 EX RE,PACK 18366819 CVB SCAN,PACKED CONVERT SIZE 18367619 C SCAN,F100 18368419 BL INVALID SIZE TOO SMALL 18369219 ST SCAN,PROCPARM+4(RN) STORE SIZE FOR COMPILER USE 18370019 B NEXT 18370819 * 18372019 * 18375019 INVALID EQU * 18378019 MVI ERRSW,X'0F' 18381019 B NEXT 18384019 EJECT 18400019 * CONSTANTS, WORK AREAS, TABLES 18500019 * FOR PARM PROCESSING 18600019 COMP CLC 0(0,SCAN),1(TABLE) COMPARES KEYWORD 18700019 PACK PACK PACKED(8),0(0,SCAN) PACKS DIGITS FOR CONVERT 18800019 * 18900019 * 19000019 * TABLES OF OPTIONS/COUNTS 19100019 OPTNO EQU 20 NUMBER OF OPTIONS 19200019 * 19300019 OPTIONS EQU * OPTIONS RECOGNIZED 19400019 * BIT SWITCH OPTIONS 19500019 * # CHARS - 1,KEYWORD,MASK 19600019 DC FL1'5',CL6'SOURCE',BL2'1' SOURCE 19700019 DC FL1'7',CL8'NOSOURCE',BL2'1111111111111110' NOSOURCE 19800019 DC FL1'2',CL3'BCD',BL2'10' BCD 19900019 DC FL1'5',CL6'EBCDIC',BL2'1111111111111101' EBCDIC 20000019 DC FL1'3',CL4'LIST',BL2'100' LIST 20100019 DC FL1'5',CL6'NOLIST',BL2'1111111111111011' NOLIST 20200019 DC FL1'3',CL4'DECK',BL2'1000' DECK 20300019 DC FL1'5',CL6'NODECK',BL2'1111111111110111' NODECK 20400019 DC FL1'3',CL4'LOAD',BL2'10000' LOAD 20500019 DC FL1'5',CL6'NOLOAD',BL2'1111111111101111' NOLOAD 20600019 DC FL1'2',CL3'MAP',BL2'100000' MAP 20700019 DC FL1'4',CL5'NOMAP',BL2'1111111111011111' NOMAP 20800019 DC FL1'3',CL4'EDIT',BL2'1000000' EDIT 20900019 DC FL1'5',CL6'NOEDIT',BL2'1111111110111111' NOEDIT 21000019 DC FL1'1',CL2'ID',BL2'10000000' ID 21100019 DC FL1'3',CL4'NOID',BL2'1111111101111111' NOID 21200019 DC FL1'3',CL4'XREF',BL2'100000000' XREF 21300019 DC FL1'5',CL6'NOXREF',BL2'1111111011111111' NOXREF 21400019 DC FL1'1',CL2'XL',BL2'1000000000' XL 21500019 DC FL1'3',CL4'NOXL',BL2'1111110111111111' NOXL 21600019 * 21700019 * 21800019 * NUMERIC VALUE OPTIONS 21900019 NONUM EQU 4*4 TOTAL NUMERIC OPTIONS*4 22000019 * 22100019 * #CHARS - 1,KEYWORD= 22200019 LINECNT DC FL1'7',CL8'LINECNT=' LINECNT= 22300019 SIZE DC FL1'4',CL5'SIZE=' SIZE= 22400019 DC FL1'5',CL6'TRACE=' TRACE= 22500019 OPT DC FL1'3',CL4'OPT=' OPT= 22600019 * 22700019 NAME DC CL5'NAME=' 22800019 MAXNAME EQU 6 MAX CHARS FOR NAME 22900019 DUMPPARM DC CL4'DUMP' 23000019 * 23100019 * ROUTINE USED TO OBTAIN 23200019 * KEYWORD PARMS TO PRINT 23300019 MOVRESET IC ARG,0(TABLE) 23400019 LA TABLE,4(ARG,TABLE) BUMP TO NEXT WORD 23500019 MOVSET IC ARG,0(TABLE) 23600019 MVI 0(GRX),COMMA INSERT COMMA 23700019 EX ARG,MOVPARM MOVE WORD TO BUFF 23800019 LA GRX,2(ARG,GRX) BUMP BUFF PTR 23900019 LA TABLE,4(ARG,TABLE) BUMP TO NEXT WORD 24000019 BR RETN 24100019 MOVPARM MVC 1(0,GRX),1(TABLE) TO BE EXECUTED 24200019 * 24300019 * 24400019 * 24500019 * 24600019 EJECT 24700019 ENDPARMS EQU * END OF PARM PROCESSING 24800019 * TEST PARAMETER LIST FOR 24900019 * DDNAMES 25000019 L ARG,PARMLIST 25100019 TM 0(ARG),X'80' 25200019 BO ENDLIST THAT'S ALL 25300019 L SCAN,4(ARG) 25400019 LH RA,0(SCAN) NO. OF CHARS IN LIST 25500019 LTR RA,RA 25600019 BZ ENDLIST 25700019 LA SCAN,2(SCAN) PT TO DD'S 25800019 CH RA,H40 25900019 BL A2 26000019 BE A3 26100019 CH RA,H56 26200019 BL A4 26300019 BE A5 26400019 TM 64(SCAN),ALL 26500019 BZ A6 NO ENTRY 26600019 MVC SYSUT2(8),64(SCAN) DDNAME FOR SYSUT2 26700019 A6 TM 56(SCAN),ALL 26800019 BZ A5 26900019 MVC SYSUT1(8),56(SCAN) DDNAME FOR SYSUT1 27000019 A5 TM 48(SCAN),ALL 27100019 BZ A4 27200019 MVC SYSPUNCH(8),48(SCAN) DDNAME FOR SYSPUNCH 27300019 A4 TM 40(SCAN),ALL 27400019 BZ A3 27500019 MVC SYSPRINT(8),40(SCAN) DDNAME FOR SYSPRINT 27600019 A3 TM 32(SCAN),ALL 27700019 BZ A2 27800019 MVC SYSIN(8),32(SCAN) DDNAME FOR SYSIN 27900019 A2 TM 0(SCAN),ALL 28000019 BZ A1 28100019 MVC SYSLIN(8),0(SCAN) DDNAME FOR SYSLIN 28200019 A1 EQU * 28300019 ENDLIST EQU * 28400019 * 28500019 MVI PARMSW,NONE 28600019 * 28700019 * 28800019 * SET UP OPTIONS TO WRITE 28900019 MVC OPTLINE+LGTH1(OPTLGTH-LGTH1),OPTLINE+LGTH1-1 29000019 LA GRX,OPTLINE+LGTH1 29100019 * MOVE NAME 29200019 MVC 0(5,GRX),NAME 'NAME=' 29300019 OC 5(6,GRX),TEMPNAME+2 6 CHARS OF NAME 29400019 * BUFFER WAS FILLED WITH BLANKS 29500019 MVI 11(GRX),COMMA INSERT COMMA 29600019 LA GRX,12(GRX) BUMP BUFF PTR 29700019 * MOVE OPT 29800019 MVC 0(4,GRX),OPT+1 'OPT=' 29900019 L ZERO,PROCOPT 30000019 TM PROCBITS+1,EDIT IS EDIT A PARM 30100019 BZ NOED 30200019 CH ZERO,H1 30300019 BH NOED OPT=2,EDIT OR NOEDIT OK 30400019 NI PROCBITS+1,NOEDIT 30500019 NOED EQU * 30600019 CVD ZERO,PACKED 30700019 UNPK 4(2,GRX),PACKED+6(2) UNPACK INTO BUFF 30800019 OI 5(GRX),X'F0' GET RID OF SIGN 30900019 MVI 6(GRX),COMMA INSERT COMMA 31000019 LA GRX,7(GRX) BUMP BUFF PTR 31100019 * MOVE LINECNT 31200019 MVC 0(8,GRX),LINECNT+1 'LINECNT=' 31300019 L ZERO,PROCLINE 31400019 CVD ZERO,PACKED 31500019 UNPK 8(2,GRX),PACKED+6(2) UNPACK UNTO BUFF 31600019 OI 9(GRX),X'F0' GET RID OF SIGN 31700019 MVI 10(GRX),COMMA 31710019 LA GRX,11(GRX) BUMP BUFFER POINTER 31720019 * MOVE SIZE 31730019 MVC 0(5,GRX),SIZE+1 SIZE= 31740019 L ZERO,PROCSIZE 31750019 CVD ZERO,PACKED 31760019 UNPK 5(4,GRX),PACKED+4(4) UNPACK INTO BUFFER 31770019 OI 8(GRX),X'F0' GET RID OF SIGN 31780019 MVI 9(GRX),C'K' 31790019 MVI 10(GRX),COMMA 31800019 LA GRX,11(GRX) 31810019 * NOW OTHER OPTIONS 31820019 * START NEW PRINT LINE 31830019 MVC OPTLINE1+LGTH1(OPTLGTH-LGTH1),OPTLINE1+LGTH1-1 31840019 LA GRX,OPTLINE1+LGTH1-1 31850019 * NOW OTHER OPTIONS 31900019 COPT SR ARG,ARG 32000019 LA RN,PROCBITS+1 32100019 STH ARG,COUNTER INITIALIZE COUNT 32200019 LA TABLE,OPTIONS ADDR OF TABLE 32300019 LA RE,1 TO TEST PROCBITS 32400019 TNEXTPR EX RE,TMBITS TEST BIT 32500019 BO FIRSTONE 32600019 BAL RETN,MOVRESET MOVE SECOND OF PARI 32700019 B NEXTPAIR 32800019 FIRSTONE BAL RETN,MOVSET MOVE FIRST OF PAIR 32900019 IC ARG,0(TABLE) 33000019 LA TABLE,4(ARG,TABLE) BUMP TO NEXT WORD 33100019 NEXTPAIR SLL RE,1 TO LOOK AT NEXT BIT 33200019 STC RE,MASK 33300019 LH RE,COUNTER 33400019 AH RE,H1 BUMP COUNT 33500019 STH RE,COUNTER 33600019 CH RE,H8 NUMBER OF PARAMETERS WITHOUT 'XL' 33700019 BC 8,FIXUP 33800019 BC 2,CONTINUE NO MORE PARAMETERS 33900019 IC RE,MASK 34000019 B TNEXTPR 34100019 FIXUP BCTR RN,0 RE-INITIALIZE FOR SECOND BYTE 34200019 LA RE,1 34300019 B TNEXTPR 34400019 TMBITS TM 0(RN),0 34500019 CONTINUE EQU * 34540019 MVI FC,X'00' 34580019 MVI BEG,X'00' 34620019 MVI OPTLINE1+LGTH1-1,C' ' 34660019 XC BLKCHN(24),BLKCHN ZERO CHAIN 34700019 MVI BEG,X'01' SET SWITCH FOR QUIT CONDITION 34800019 L NPTR,ADNPTR 34900019 SR RB,RB 35000019 ST RB,120(NPTR) ZERO PAGE NO. FOR EARLY END 35100019 ST RB,128(NPTR) ZERO LINE COUNT TOO 35200019 TM PROCBITS,XREF 35300019 BZ ADINIT NOT ON 35400019 L FIRST,ADADCON ADDR OF ADCON TABLE 35500019 L RB,0(FIRST) FIRST WORD CONTAINS LGTH 35600019 SLA RB,2 MULTIPLY TO GET BYTES 35700019 DEVTYPE SYSUT2,56(NPTR) FIND DEVICE BLKSIZE 35800019 * OF INFORMATION 35900019 C RB,60(NPTR) COMPARE WITH ADCON TABLE 36000019 BNH BEFINIT ADCON TABLE IS SMALLER THAN BLKSIZE 36100019 NI 63(NPTR),X'FC' 36200019 * ALLIGNMENT 36300019 B ADINIT 36400019 BEFINIT ST RB,60(NPTR) MOVE IN SIZE OF ADCON TABLE 36500019 ADINIT LA ARG,INITPARM 36600019 L LINK,ADFIOCS ADDRESS OF FIOCS 36700019 BALR RETN,LINK 36800019 * 36900019 ********************************************************************** 37000019 * GET CORE STORAGE FOR COMPILER USE 37100019 ********************************************************************** 37200019 * 37300019 MVI QUITCODE,MSG1 37310019 SR R9,R9 37320019 L R11,PROCSIZE IS THERE A SIZE 37330019 LTR R11,R11 PARAMETER VALUE 37340019 BZ ALLCORE 37350019 FINDSIZE SR R4,R4 YES. 37450019 LR R5,R11 COMPUTE AMOUNT OF 37550019 M R4,KAY CORE NEEDED 37650019 L AA01,ADAA01 37700021 S R5,CMPLRSIZ FOR THAT SIZE 37750021 SR R9,R9 37800021 COMPUTE LR GRY,R5 37900019 D R4,AMTTXT 38000019 SR GRY,R4 38100019 C GRY,AMTTXT 38130019 BNH IQUIT 38160019 ST GRY,MAXIMUM 38200019 L AA02,ADAA02 38230019 B MORECORE 38260019 ALLCORE L GRY,LGSTVALU 38280019 ST GRY,MAXIMUM 38300019 L AA02,ADAA02 GET ALL THE CORE 38320019 MVI NEWMETH,X'01' 38350019 MORECORE GETMAIN VC,LA=REQUEST,A=ANSWER,SP=1 38400019 LTR LINK,LINK TEST RETURN CODE 38500019 BNZ TEST 38600019 BAL RETN,FINDFREQ FIND END OF CHAIN 38700019 L R10,ADDRESS 38800019 ST R10,0(QUE) 38900019 L GRX,LENGTH 39000019 ST GRX,4(R10) 39100019 SR ZERO,ZERO 39200019 ST ZERO,0(R10) 39300019 AR R9,GRX TOTAL LENGTH 39400019 CR R9,GRY IS IT ENOUGH 39500019 BC 10,AGAIN 39600019 LR GRX,GRY 39700019 SR GRX,R9 AMOUNT NEEDED 39800019 C GRX,AMTTXT IS LESS THAN MINIMUM 39900019 BC 10,RESTORE 40000019 L GRX,AMTTXT NEVER ASK FOR LESS THAN MINUMUM 40100019 RESTORE TM NEWMETH,X'01' 40109019 BO MORECORE 40118019 ST GRX,MAXIMUM 40127019 B MORECORE 40136019 TEST TM NEWMETH,X'01' 40145019 BZ IQUIT 40154019 L R10,FREEAMT 40163019 * FOR AOS, FREE 6K 40165021 LA QUE,16 40167021 L QUE,0(QUE) GET ADDRESS OF CVT 40169021 CLI 116(QUE),X'22' TEST BYTE IN CVT FOR AOS 40171021 BNE NOTAOS IF NOT AOS, BRANCH 40171421 L R10,FREEAMT2 SET 6K TO BE FREED 40171821 NOTAOS SR R9,R10 40171921 BNP IQUIT 40181019 SR ZERO,ZERO 40190019 THERE BAL RETN,FINDFREQ 40199019 C R10,4(QUE) COMPARE LENGTH OF CHAIN AND 3K 40208019 BE FINE EQUAL 40217019 BL DIVIDE TOO MUCH 40226019 * 40235019 * LESS THAN 3K 40244019 * 40253019 B IQUIT 40262019 DIVIDE L RB,4(QUE) 40271019 SR RB,R10 LENGTH - 3K 40280019 ST RB,4(QUE) 40289019 AR QUE,RB STARTING ADDR OF 3K BLOCK 40298019 ST R10,4(QUE) LENGTH FOR THAT BLOCK 40307019 LR R10,ZERO HAVE 3K CORE 40316019 B FREEIT 40325019 FINE LR R10,ZERO 40334019 ST ZERO,0(RB) ZERO OUT CHAIN FIELD 40343019 FREEIT ST QUE,ADDRESS 40352019 MVC LENGTH(4),4(QUE) 40361019 FREEMAIN V,A=ANSWER,SP=1 40370019 LTR R10,R10 HAVE 3K BEEN FREED 40379019 BNZ THERE 40388019 AGAIN ST R9,AMTCORE SAVE AMT. OF CORE GOTTEN 40438019 L SAVE,IEKSAVE+4 40500019 LM RETN,RETN-2,12(SAVE) 40600019 BR RETN 40700019 EJECT 40800019 * 40900019 * FINDS END OF CHAIN OF BLOCKS 41000019 * 41100019 FINDFREQ LA QUE,FREQUE 41200019 FINDEND L RA,0(QUE) LOAD CONTENTS 41300019 LTR RA,RA TEST 41400019 BCR 8,RETN BRANCH WITH END OF CHAIN 41500019 LR RB,QUE SAVE NEXT TO LAST BLOCK 41600019 L QUE,0(QUE) CHAIN TO NEXT BLOCK 41700019 B FINDEND 41800019 * 41900019 * 42000019 * RETURN TO IEKAA00 TO ABNORMALLY END 42100019 * 42200019 IQUIT EQU * 42300019 L LINK,VQUIT 42400019 L BASE,ADAA00 42500019 BR LINK 42600019 * 42700019 * 42800019 * AREAS FOR CORE ALLOCATION 42900019 REQUEST DS 0F 42950019 AMTTXT DC F'4096' 43100019 MAXIMUM DS 1F 43200019 ANSWER EQU * 43300019 ADDRESS DS 1F 43400019 LENGTH DS 1F 43500019 PACKED DC D'0' 43600019 PARMLIST DC F'0' 43700019 * 43800019 * 43900019 * ADCONS 44000019 ADADCON DC A(IEKAAD) 44100019 EXTRN IEKAAD 44200019 ADNPTR DC A(IEKAAA) 44300019 EXTRN IEKAAA 44400019 ADAA01 DC V(IEKAA01) 44500019 ADFIOCS DC V(FIOCS#) 44600019 ADAA02 DC V(IEKAA02) 44700019 VQUIT DC V(QUIT) 44800019 ADAA00 DC V(IEKAA00) 44900019 * 45000019 IEKSAVE DS 18F 45100019 * 45200019 * CONSTANTS 45300019 F100 DC F'100' 45350019 H1 DC H'1' 45400019 H2 DC H'2' 45450019 H4 DC H'4' 45500019 H8 DC H'8' 45600019 H12 DC H'12' 45650019 H40 DC H'40' 45700019 H56 DC H'56' 45800019 * 45900019 COUNTER DS H 46000019 MASK DS CL1 46100019 CNOP 0,4 46200019 INITPARM DC X'01' 46300019 FREEAMT DC F'3072' 46310019 FREEAMT2 DC F'6144' 46312021 LGSTVALU DC X'00FFFFF8' 46320019 KAY DC F'1024' 46330019 NEWMETH DS 1X 46350019 SAVESCAN DS 1F 46370020 EJECT 46400019 DUMMI2 DSECT 46500019 * THIS DSECT IS A DUMMY 46600019 * OF CSECT IEKAA02 46700019 CNOP 0,4 46800019 PROCDD EQU * 46900019 SYSLIN DS D'0' 47000019 SYSIN DS D'0' 47100019 SYSPRINT DS D'0' 47200019 SYSPUNCH DS D'0' 47300019 SYSUT1 DS D'0' 47400019 SYSUT2 DS D'0' 47500019 NUMDD EQU 6 47600019 DEFDD EQU * DEFAULT DDNAMES (ORDER DEPEN) 47700019 * 47800019 DC CL8'SYSLIN ' 1 47900019 DC CL8'SYSIN ' 2 48000019 DC CL8'SYSPRINT' 3 48100019 DC CL8'SYSPUNCH' 4 48200019 DC CL8'SYSUT1 ' 5 48300019 DC CL8'SYSUT2 ' 6 48400019 * 48500019 PROCPARM DS 2F NAME 48600019 PROCOPT DS F OPT= 48700019 DS F 48800019 PROCSIZE DS F 48900019 PROCLINE DS F LINECNT= 49000019 DS F BIT SWITCHES 49100019 PROCBITS EQU PROCPARM+26 49200019 PGHDLGTH EQU 120 49300019 PAGEHEAD DC CL120'1 LEVEL 18 ( SEPT 69 ) O149400019 S/360 FORTRAN H DATE Y249500019 Y.DDD/HH.MM.SS' 49600019 YEAR EQU PAGEHEAD+105 49700019 HOUR EQU YEAR+7 49800019 DS 0D 49900019 TEMPNAME DC D'0' 50000019 * 50100019 * PTRS FOR GETCOR 50600019 BLKCHN DS 6F 50700019 FREQUE EQU BLKCHN+20 50800019 CORECHN DS 6F 50810019 AMTCORE EQU CORECHN+20 50820019 FC DS X FIRST COMPILATION 50830019 ERRSW DS X 50840019 BEG DS X GETMAIN SWITCH 50860019 OPTLINE DC CL120'0 COMPILER OPTIONS -' 50900019 OPTLINE1 DC CL120' ' 50950019 OPTLGTH EQU 120 51000019 PARMSW DC X'00' SET TO 'FF' WHILE PROC. PARMS 51100019 QUITLGTH EQU 23 51200019 QUITMSG DC CL23'0COMPILATION DELETED. 0' 51300019 QUITCODE EQU QUITMSG+22 51400019 EJECT 51500019 DUMIEK DSECT 51600019 DEFAULTS DC CL8' MAIN' NAME GIVEN TO MAIN PGM 51700019 DC F'0' OPTIMIZATION LEVEL BY DEFAULT 51800019 DC F'0' TRACE SWITCH 51900019 DC F'0' 52000019 DC F'50' LINECOUNT BY DEFAULT 52100019 DC BL4'0000010001' 52200019 CMPLRSIZ DS 1F COMPILER SIZE WITH INSTALLATION-DETERMINED TABLES 52260021 HEADER DS 7F LEFT-HAND SECTION OF LISTING HEADING (LVL AND DATE) 52320021 END 52400019 ./ ADD SSI=00011350,NAME=IEKAPT,SOURCE=0 IEKAPT START 0 03000014 ENTRY PUTOUT 06000014 EXTRN FIOCS# 09000014 * SUBROUTINE PUTOUT BRANCHES TO FIOCS TO WRITE TITLES FOR SECTIONS 12000014 * OF CODE GENERATED BY THE COMPILER. 15000014 * CALLED BY SUBR, NADOUT, AND END. 18000014 * TWO PARAMETERS, THE ADDRESS OF THE TITLE AND THE ADDRESS OF 21000014 * ITS LENGTH, ARE POINTED TO BY REGISTER 1. 24000014 PUTOUT BC 15,12(0,15) 27000014 DC X'0700' 30000014 DC C'IEKAPT' 33000014 STM 14,12,12(13) SAVE REGISTERS 36000014 LR 12,15 39000014 USING IEKAPT,12 42000014 LM 4,5,0(1) ADDRESSES OF ARRAY, LENGTH 45000014 L 5,0(0,5) 48000014 STH 5,WUNIT+2 SET LENGTH 51000014 LA 1,WUNIT SELECT SYSOUT 54000014 L 15,AFIOCS 57000014 BALR 14,15 LOCATE A BUFFER 60000014 L 2,0(0,1) 63000014 BCTR 5,0 66000014 EX 5,MOVE MOVE ARRAY INTO BUFFER 69000014 LM 14,12,12(13) 72000014 BCR 15,14 RETURN TO CALLER 75000014 * 78000014 AFIOCS DC A(FIOCS#) 81000014 WUNIT DC X'03060000' 84000014 MOVE MVC 0(1,2),0(4) 87000014 END 90000014 ./ ADD SSI=00011261,NAME=IEKARW,SOURCE=0 IEKARW CSECT 06000014 BC 15,12(15) 12000014 DC CL8'IEKARWND' 18000014 STM 14,12,12(13) 24000014 BALR 10,0 30000014 USING *,10 36000014 L 15,ADFIOCS 42000014 LA 1,EDITPARM 48000014 BALR 14,15 54000014 LM 14,12,12(13) 60000014 BR 14 66000014 ADFIOCS DC V(IEKFIOCS) 72000014 EDITPARM DC X'4',X'8',H'0' 78000014 END 84000014 ./ ADD SSI=01010030,NAME=IEKATB,SOURCE=0 SUBROUTINE IEKATB(N) 00400014 C 00500015 C 572000 0000A 00600015 C 00800014 C THIS ROUTINE PRINTS COMPILER TABLES IMPLICITLY 01200014 C REQUESTED BY THE PARAMETER N. 01600014 C THE DECODING OF N IS AS FOLLOWS: 02000014 C 02400014 C 1- PHASE 10 TEXT 02800014 C 2- PHASE 15/20 TEXT 03200014 C 4- 03600014 C 8- DICTIONARY 04000014 C 04400014 IMPLICIT INTEGER*4 (A-Z) 04800014 DATA MSK/Z00FFFFFF/,LADR/ZFFFFF8/ 05200014 C X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X 05600014 C 06000014 C 06400014 C DICTIONARY LAYOUT 06800014 C 07200014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 07600014 LOGICAL*1 BYA,BYB,BYC 08000014 INTEGER*2 DIS,MDD,TYP 08400014 STRUCTURE // IX1,LNGTH,CHN 08800014 C STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 09200014 C STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI,NAM1,NAM2,NAM3,NAM4 09600014 C 10000014 C 10400014 C 10800014 C LABEL LAYOUT 11200014 C 11600014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 12000014 LOGICAL*1 COMP,DN 12400014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 12800014 C 13200014 C 13600014 C 14000014 C DIMENSION ENTRY LAYOUT 14400014 C 14800014 INTEGER ASIZE,DIM1 15200014 INTEGER*2 ELGTH,NDIM 15600014 STRUCTURE // ASIZE,NDIM,ELGTH,DIM1 16000014 C 16400014 C 16800014 C 17200014 C NORMAL TEXT LAYOUT 17600014 C 18000014 INTEGER CH,SM,P1,P2,P3,DP,DPTR,BLKEND 18400014 LOGICAL*1 FC,R1,R2,R3,L11,L12,L13 18800014 INTEGER*2 H1,H2,H3 19200014 STRUCTURE // CH,SM,P1,P2,P3,DP 19600014 STRUCTURE // CH,H1,FC,L11,R1,L12,H2,R2,L13,H3,R3 20000014 C 20400014 C 20800014 C 21200014 C TEXT LABEL LAYOUT 21600014 C 22000014 LOGICAL*1 ABFN 22400014 STRUCTURE // CH,H1,FC,ABFN,DPTR,BLKEND,MVF,MV1,MV2,MV3, 22800014 * MVS,MV4,MV5,MV6,MVX 23200014 C 23600014 C 24000014 C 24400014 C PHASE 10 TEXT LAYOUT 24800014 C 25200014 C 25600014 INTEGER*2 MD,TP 26000014 LOGICAL*1 ADJ 26400014 STRUCTURE // CH,MD,TP,PTR 26800014 STRUCTURE // ADJ 27200014 C 27600014 C 28000014 C 28400014 COMMON/IEKAAA/NPTR(2,35) 28800014 DIMENSION NPTRX(70) 29200014 EQUIVALENCE(NPTR(1,1),NPTRX(1)) 29600014 COMMON/IEKAAD/IAD,JAD(500) 30000014 IF(LAND(N,16).EQ.0) GOTO 1010 30400014 C 30800014 C WRITE NPTR 31200014 C 31600014 WRITE(6, 105) ((NPTRX(I),NPTRX(I+1),I=J,70,10),J=1,9,2) 32000014 105 FORMAT ('0 POINTER TABLE' //(' ',7(Z5,2X,Z5,5X))) 32400014 1010 CONTINUE 32800014 IF(LAND(N,8).EQ.0) GOTO 1035 33200014 C 33600014 C WRITE THE DICTIONARY 34000014 C 34400014 IX = LAND(NPTR(1,25),LADR) 34800014 IX2 = IX - 8 35200014 WRITE(6,110) 35600014 110 FORMAT(' DICTIONARY') 36000014 GO TO 1151 36400014 1015 WRITE(6,115) IX,CH(IX),CH(IX+4),CH(IX+8),CH(IX+12),CH(IX+16), 36800014 1 CH(IX+20),CH(IX+24),CH(IX+28) 37200014 115 FORMAT (' (',Z8,') ',4Z11,15X,4Z11) 37600014 IX=IX+32 38000014 IF ( IX .LT. END) GO TO 1015 38400014 IF ( END .EQ. NPTR(2,30)) GO TO 1021 38800014 1151 END = IX2 + LNGTH(IX2) - 1 39200014 IX = IX2 + 8 39600014 IX2 = IX1(IX2) 40000014 GO TO 1015 40400014 C 40800014 C SEE IF ADDITIONAL DICTIONARY PRINTOUT IS DESIRED 41200014 C BY EXAMINING BIT 30 OF THE TRACE SWITCH 41600014 C 42000014 1021 IF (LAND(NPTR(2,11),2).EQ.0) GO TO 3020 42400014 IX=NPTR(2,1) 42800014 ASSIGN 1040 TO N 43200014 1025 IF(IX.NE.0) GOTO 1030 43600014 GOTO N,(1020,1040,1050,1060,1070,1080) 44000014 1030 WRITE(6,120) IX,CH(IX),CH(IX+4),CH(IX+8),CH(IX+12),CH(IX+16), 44400014 1 CH(IX+20),CH(IX+24),CH(IX+28),CH(IX+32) 44800014 120 FORMAT (' (',Z8,') ',7Z11,3X,2A4) 45200014 IX=CH(IX) 45600014 GOTO 1025 46000014 1040 ASSIGN 1050 TO N 46400014 IX=NPTR(2,2) 46800014 GOTO 1025 47200014 1050 ASSIGN 1060 TO N 47600014 IX=NPTR(2,3) 48000014 GOTO 1025 48400014 1060 ASSIGN 1070 TO N 48800014 IX=NPTR(2,4) 49200014 GOTO 1025 49600014 1070 ASSIGN 1080 TO N 50000014 IX=NPTR(2,5) 50400014 GOTO 1025 50800014 51200014 1080 ASSIGN 1020 TO N 51600014 IX=NPTR(2,6) 52000014 GOTO 1025 52400014 1020 CONTINUE 52800014 IX=NPTR(2,14) 53200014 ASSIGN 2010 TO N 53600014 2025 IF(IX.NE.0) GOTO 2030 54000014 GOTO N,(2010,2020,2040) 54400014 2030 WRITE(6,125) IX,CH(IX),CH(IX+4),CH(IX+8),CH(IX+12),CH(IX+16), 54800014 1 CH(IX+20),CH(IX+24),CH(IX+28),CH(IX+32) 55200014 125 FORMAT (' (',Z8,') ',9Z11) 55600014 IX=CH(IX) 56000014 GOTO 2025 56400014 2010 IX=NPTR(2,15) 56800014 ASSIGN 2020 TO N 57200015 GOTO 2025 57600014 2020 IX=NPTR(2,16) 58000014 ASSIGN 2040 TO N 58400014 GOTO 2025 58800014 2040 CONTINUE 59200014 IX=NPTR(2,17) 59600014 2050 IF(IX.EQ.0) GOTO 3020 60000014 WRITE(6,130) IX,CH(IX),CH(IX+4),CH(IX+8),CH(IX+12),CH(IX+16), 60400014 1 CH(IX+20),CH(IX+24),CH(IX+28) 60800014 130 FORMAT (' (',Z8,') ',2(Z8,3X),I6,Z11,2I6,Z8) 61200014 IX=CH(IX) 61600014 GOTO 2050 62000014 3020 CONTINUE 62400014 C 62800014 C WRITE THE ADCON TABLE 63200014 C 63600014 J=NPTR(2,34) 64000014 WRITE(6,84321)IAD 64400014 84321 FORMAT(' COUNT OF ADCONS ',I10) 64800014 WRITE(6,135) (JAD(I),I=1,J) 65200014 135 FORMAT('0 ADCON TABLE'//(1H ,10Z10)) 65600014 1035 CONTINUE 66000014 IF(LAND(N,2).EQ.0) GOTO 1075 66400014 C 66800014 C WRITE PHASE 15/20 TEXT 67200014 C 67600014 WRITE(6,140) 68000014 140 FORMAT('0 TEXT') 68400014 LAB=NPTR(2,17) 68800014 4010 IX=NPBP(LAB) 69200014 4015 OP=FC(IX) 69600014 END=IX+16 70000014 IF(OP.EQ.14.OR.OP.EQ.22) END=END+4 70400014 IF(OP.NE.222.AND.OP.NE.223) GOTO 4020 70800014 END=END-4 71200014 IF (NPTR(2,24).EQ.0) GO TO 4030 71600015 END=END+48 72000014 WRITE(6,146) IX,OP,(CH(I),I=IX,END,4) 72400014 GOTO 147 72800014 4020 CONTINUE 73200014 4030 WRITE(6,145) IX,OP,(CH(I),I=IX,END,4) 73600014 145 FORMAT(' (',Z6,') ',I6,6Z11) 74000014 146 FORMAT(' (',Z6,') ',I6,4Z11/20X,3(3X,4Z8)) 74400014 147 IX=CH(IX) 74800014 IF(IX.NE.0) GOTO 4015 75200014 LAB=BPC(LAB) 75600014 IF(LAB.NE.0) GOTO 4010 76000014 1075 CONTINUE 76400014 IF (LAND(N,1).EQ.0) GO TO 9999 76800014 IX=NPTR(2,28) 77200014 C 77600014 C WRITE PHASE 10 TEXT 78000014 C 78400014 WRITE(6,140) 78800014 5045 CHAIN=LAND(CH(IX),M SK) 79200014 ADJIX=ADJ(IX) 79600014 WRITE(6,150) IX,CHAIN,ADJIX ,PTR(IX),MD(IX),TP(IX) 80000014 150 FORMAT(' ('Z8,') ',Z6,I6,' ',Z8,2I6) 80400014 IX=CHAIN 80800014 IF(IX.NE.0) GOTO 5045 81200014 C 81600014 C WRITE DATA TEXT 82000014 C 82400014 DCHN=NPTR(2,27) 82800014 WRITE(6,155) 83200014 155 FORMAT('0 DATA') 83600014 6010 IF(DCHN.EQ.0) GOTO 6040 84000014 WRITE(6,160) DCHN,CH(DCHN),CH(DCHN+4),CH(DCHN+8) 84400014 160 FORMAT(' (',Z8,') ',3Z11) 84800014 IX = MOD24 (CH(DCHN)) 85200015 6020 IF(IX.EQ.0) GOTO 6030 85600014 WRITE(6,160) IX,CH(IX),CH(IX+4),CH(IX+8) 86000014 IX = MOD24 (CH(IX)) 86400015 GOTO 6020 86800014 6030 DCHN=CH(DCHN+8) 87200014 GOTO 6010 87600014 C 88000014 C WRITE NAMELIST TEXT 88400014 C 88800014 6040 DCHN=NPTR(1,32) 89200014 WRITE (6,165) 89600014 165 FORMAT('0 NAMELIST') 90000014 6050 IF(DCHN.EQ.0) GO TO 6070 90400014 WRITE(6,160) DCHN,CH(DCHN),CH(DCHN+4),CH(DCHN+8) 90800014 IX = MOD24 (CH(DCHN)) 91200015 DCHN=CH(IX+8) 91600014 6060 IF(IX.EQ.0) GO TO 6050 92000014 WRITE(6,160) IX,CH(IX),CH(IX+4),CH(IX+8) 92400014 IX = MOD24 (CH(IX)) 92800015 GO TO 6060 93200014 C 93600014 C WRITE DEFINE FILE TEXT 94000014 C 94400014 6070 DCHN=NPTR(1,26) 94800014 WRITE (6,170) 95200014 170 FORMAT('0 DEFINE FILE') 95600014 6080 IF(DCHN.EQ.0) GO TO 6090 96000014 WRITE(6,160) DCHN,CH(DCHN),CH(DCHN+4),CH(DCHN+8) 96400014 DCHN = MOD24 (CH(DCHN)) 96800015 GO TO 6080 97200014 6090 CONTINUE 97600014 9999 RETURN 98000014 END 98400014 ./ ADD SSI=00011350,NAME=IEKATM,SOURCE=0 TIMR TITLE 'SPECIAL TIMING ROUTINE, LEE CASSETTY' 00400014 IEKATM CSECT 00800014 * SPECIAL TIMING ROUTINE FOR P.L. DRENNING 01200014 * 01600014 * 02000014 * COMPILER VERSION --- USES FIOCS FOR I/O 02400014 * 02800014 * THIS ROUTINE WILL MAINTAIN TEN TIMES. THE PARAMETER 03200014 * PASSED WILL SPECIFY THE DESIRED SLOT. 03600014 * LINKAGE INTO ROUTINE IS VIA THE CALL MACRO. 04000014 * 04400014 * 04800014 * 05200014 * ENTRY POINTS 05600014 * 06000014 * TST WILL COMPUTE BIAS ON FIRST ENTRY AT THIS POINT THEN SYNC 06400014 * ON TIMER UPDATE AND RETURN. ON SUBSEQUENT ENTRIES TO THIS 06800014 * POINT, IT WILL ONLY SYNC ON TIMER UPDATE. 07200014 * 07600014 * TSP WILL COMPUTE THE ELASPED TIME BETWEEN AN ENTRY AT TST AND 08000014 * THIS ENTRY. 08400014 * 08800014 * TOUT WILL PRINT OUT THE ELASED TIME ON SYSOUT 09200014 * 09600014 * 10000014 * PHASB IS USED BY THE COMPILER FOR PHASE TIMINGS. THIS ENTRY 10400014 * IS TO START THE CLOCK 10800014 * PHASS IS USED TO STOP THE PASE-TIMING CLOCK 11200014 * 11600014 * PHAZSS WILL STOP THE CURRENT CLOCK AND START THE NEXT CLOCK 12000014 * 12400014 * 12800014 ENTRY TIMERC 13200014 ENTRY PHAZSS 13600014 ENTRY PHASB,PHASS 14000014 ENTRY TST,TSP,TOUT 14400014 * 14800014 * 15200014 USING *,15 15600014 TIMERC EQU * 16000014 PHAZSS ST 14,OUTSAVE 16400014 LA 15,PHASS 16800014 BALR 14,15 17200014 USING *,14 17600014 LA 15,*+8 18000014 L 14,OUTSAVE 18400014 USING *,15 18800014 PHASB L 1,PARM 19200014 LA 1,1(1) 19600014 ST 1,PARM 20000014 LA 1,PPARM 20400014 LA 15,*+4 20800014 USING *,15 21200014 TST ST 10,REGSAVE 21600014 SWIX1 BC 15,INITIAL FIRST TIME IN GO TO INITIAL 22000014 TSTARTA L 10,0(1) 22400014 L 10,0(10) 22800014 SLL 10,2 23200014 LA 10,TABLE(10) 23600014 MVC 0(4,10),80(0) READ TIMER INTO TABLE 24000014 SYNC1 CLC 80(4,0),0(10) LOOP UNTIL TIME CHANGES 24400014 BC 8,SYNC1 24800014 MVC 0(4,10),80(0) STORE START TIME IN TABLE 25200014 L 10,REGSAVE RESTORE REG 10 25600014 BR 14 RETURN TO CALLING PROGRAM 26000014 INITIAL NI SWIX1+1,X'0F' TURN OFF INITIAL SWITCH 26400014 STM 3,6,FTTSV12 26800014 LA 6,4 PLACE 4 IN INDEX 27200014 SR 4,4 CLEAR 4 27600014 INITIAL3 L 5,80 READ TIME INTO 5 28000014 INITIAL0 C 5,80 Q. TIME CHANGED 28400014 BE INITIAL0 GO BACK IF NO 28800014 L 5,80 READ TIME 29200014 INITIAL2 LA 4,1(4) ADD 1 TO R4 29600014 C 5,80 Q. TIME CHANGED 30000014 BE INITIAL2 GO BACK IF NO 30400014 A 4,LOOPCON ADD PREVIOUS LOOPS TO THIS LOOP 30800014 ST 4,LOOPCON STORE SUM 31200014 SR 4,4 CLEAR 4 31600014 BCT 6,INITIAL3 Q. FORTH TIME THRU 32000014 L 5,LOOPCON 32400014 D 4,T4CON COMPUTE AVERAGE LOOP TIME 32800014 ST 5,LOOPCON 33200014 L 5,T16MSECO 33600014 SR 4,4 34000014 D 4,LOOPCON 34400014 ST 5,LOOPCON STORE TIME FOR 1 LOOP 34800014 LA 6,4 SET INDEX TO 4 35200014 L 5,0(1) 35600014 L 5,0(5) 36000014 SLL 5,2 36400014 STH 5,LA5+2 36800014 STM 14,15,REGSAVE+16 37200014 FAKE1A L 15,FAKE1 * CREATE A FAKE START 37600014 BALR 14,15 ** 38000014 FAKE2A L 15,FAKE2 * CREATE A FAKE STOP 38400014 BALR 14,15 ** 38800014 USING *,14 39200014 LM 14,15,REGSAVE+16 39600014 DROP 14 40000014 LA5 LA 5,0 40400014 L 5,TABLE(5) 40800014 A 5,BIAS 41200014 ST 5,BIAS 41600014 BCT 6,FAKE1A Q. 4 TIMES THRU BIAS COMPUTATIONS 42000014 LA 6,4 42400014 SR 4,4 42800014 DR 4,6 43200014 ST 5,BIAS 43600014 LM 3,6,FTTSV12 44000014 B TSTARTA RETURN TO MAIN LINE 44400014 USING *,15 44800014 PHASS LA 1,PPARM 45200014 LA 15,*+4 45600014 USING *,15 46000014 TSP STM 9,13,OUTSAVE2 46400014 SR 13,13 CLEAR 13 46800014 L 10,80(0) READ TIME 47200014 SYNC2 LA 13,1(13) BUMP 13 BY 1 47600014 C 10,80(0) HAS TIME CHANGED 48000014 BE SYNC2 48400014 SR 12,12 CLEAR 12 48800014 M 12,LOOPCON COMPUTE TIME IN SYNC2 LOOP 49200014 SR 12,12 49600014 D 12,HUNDRED TRUNCATE TIME IN LOOP TO MICRO SEC 50000014 A 13,BIAS ADD TO LOOP TIME THE BIAS OF 'FRTR' 50400014 SR 12,12 CLEAR 12 50800014 C 13,T16MSEC Q. IS TIME OF LOOP AND BIAS GREATER 51200014 BC 2,GLCA THAN 16.666 BRANCH IF YES 51600014 L 12,T16MSEC 52000014 SR 12,13 SUBTRACT LOOP+BIAS FROM 16.666 52400014 GLCA L 9,0(1) 52800014 L 9,0(9) 53200014 SLL 9,2 53600014 L 11,TABLE(9) 54000014 SR 11,10 SUBTRACT STOP TIME 54400014 SR 10,10 CLEAR REG 54800014 M 10,T13CON CONVERT TIME TO 55200014 AR 11,12 TOTAL TIME 55600014 ST 11,TABLE(9) 56000014 LM 9,13,OUTSAVE2 56400014 RETURN BR 14 56800014 USING *,15 57200014 TOUT STM 0,15,OUTSAVE2 57600014 LA 1,WUNIT SELECT SYSOUT 58000014 LR 2,15 58400014 L 15,AFIOCS 58800014 BALR 14,15 LOCATE A BUFFER 59200014 LR 15,2 59600014 L 2,0(0,1) 60000014 SR 9,9 60400014 BACK LA 9,4(9) 60800014 L 10,TABLE(9) 61200014 LTR 10,10 61600014 BZ NEXT 62000014 CVD 10,DECIMAL 62400014 MVC PBUFFR(18),PATTERN 62800014 ED PBUFFR(18),DECIMAL 63200014 LR 10,9 63600014 SLL 10,6 64000014 A 10,PATERN 64400014 C 9,TENA 64800014 BL OLDP 65200014 A 10,PATN10 65600014 OLDP ST 10,BUFFR+8 66000014 MVC 0(66,2),BUFFR 66400014 LA 0,0 66800014 ST 0,TABLE(9) CLEAR THE TABLE --- PREP FOR NEXT SEQUENCE 67200014 NEXT C 9,TEN 67600014 BNE BACK 68000014 ST 0,PARM 68400014 LM 0,15,OUTSAVE2 68800014 BR 14 69200014 FAKE1 DC A(TST) * 69600014 FAKE2 DC A(TSP) * 70000014 PPARM DC A(PARM) 70400014 AFIOCS DC V(FIOCS#) 70800014 WUNIT DC X'03060042' 71200014 PARM DC F'0' 71600014 REGSAVE DC 5F'0' 72000014 TABLE DC 21F'0' 72400014 LOOPCON DC F'0' 72800014 BIAS DC F'0' 73200014 T4CON DC F'4' 73600014 HUNDRED DC F'100' 74000014 PATERN DC C' 0 ' 74400014 PATN10 DC X'00B0F600' 74800014 TEN DC F'80' 75200014 TENA DC F'40' 75600014 T16MSEC DC F'16666' 76000014 DECIMAL DC D'0' 76400014 FTTSV12 DC 4F'0' 76800014 T13CON DC F'13' 77200014 T16MSECO DC X'00196E28' 77600014 OUTSAVE DS 1F 78000014 OUTSAVE2 DC 18F'0' 78400014 PATTERN DC X'402020202020202020202020214B20202040' 78800014 CNOP 0,4 79200014 BUFFR DC C' * * * * 1 * * ' 79600014 PBUFFR DC C' MILLI SECONDS' 80000014 DC C' * * * * * * * *' 80400014 END 80800014 ./ ADD SSI=00011150,NAME=IEKCAA,SOURCE=0 TITLE 'PH10 - COMMUNICATIONS REGION FOR PHASE 10' 00400014 IEKCAA START 0 PH10 COMMON 00800014 * STATUS - CHANGE LEVEL 0 01200014 * 01600014 * FUNCTION - THIS CONTROL SECTIONS CONTAINS NO EXECUTABLE INSTRUCTIONS. 02000014 * IT CONTAINS TABLES, WORK AREAS AND COMMON COMMUNICATIONS 02400014 * REGIONS FOR PHASE 10 OF THE FORTRAN H COMPILER 02800014 * 03200014 NCARD DC 4F'0' 03600014 NCDIN DC 1392X'00' 19 CONTINUATION CARDS 04000014 SPACE 04400014 *********************************************************************** 04800014 SPACE 05200014 * IMPLICIT MODE TABLE 05600014 SPACE 06000014 NIMPCT DC C'A',X'05' 06400014 DC C'B',X'05' 06800014 DC C'C',X'05' 07200014 DC C'D',X'05' 07600014 DC C'E',X'05' 08000014 DC C'F',X'05' 08400014 DC C'G',X'05' 08800014 DC C'H',X'05' 09200014 DC C'I',X'03' 09600014 DC C'J',X'03' 10000014 DC C'K',X'03' 10400014 DC C'L',X'03' 10800014 DC C'M',X'03' 11200014 DC C'N',X'03' 11600014 DC C'O',X'05' 12000014 DC C'P',X'05' 12400014 DC C'Q',X'05' 12800014 DC C'R',X'05' 13200014 DC C'S',X'05' 13600014 DC C'T',X'05' 14000014 DC C'U',X'05' 14400014 DC C'V',X'05' 14800014 DC C'W',X'05' 15200014 DC C'X',X'05' 15600014 DC C'Y',X'05' 16000014 DC C'Z',X'05' 16400014 SPACE 2 16800014 *********************************************************************** 17200014 SPACE 17600014 * MODE TABLE 18000014 SPACE 18400014 NMODET DC F'3' LOGICAL*4 18800014 DC F'4' INTEGER*2 19200014 DC F'5' INTEGER*4 19600014 DC F'6' REAL*8 20000014 DC F'7' REAL*4 20400014 DC F'8' COMPLEX*16 20800014 DC F'9' COMPLEX*8 21200014 DC F'7' MODE OF $ 21600014 DC F'2' LOGICAL*1 22000014 SPACE 2 22400014 *********************************************************************** 22800014 SPACE 23200014 M2R3 DC X'FFFFFFFE' 23600014 NEQ DC XL3'0',C'=' 24000014 NQUOT DC XL3'0',C'''' 24400014 NPLUS DC XL3'0',C'+' 24800014 NPER DC XL3'0',C'.' 25200014 NLFPR DC XL3'0',C'(' 25600014 NMIN DC XL3'0',C'-' 26000014 NASTR DC XL3'0',C'*' 26400014 NSLAS DC XL3'0',C'/' 26800014 NCOMA DC XL3'0',C',' 27200014 NRTPR DC XL3'0',C')' 27600014 NGPMK DC XL4'0000004F' 28000014 NDOLAR DC XL3'0',C'$' 28400014 SPACE 2 28800014 *********************************************************************** 29200014 SPACE 29600014 * LOGICAL ADJECTIVE CODE TABLE NLOGTB(2,10) 30000014 SPACE 30400014 NLOGTB DC XL4'00D5D6E3' NOT ' 30800014 DC F'1' 31200014 DC XL4'00C1D5C4' AND 4 31600014 DC F'4' 32000014 DC XL4'0000D6D9' OR 6 32400014 DC F'6' 32800014 DC XL4'0000C7C5' GE 17 33200014 DC F'17' 33600014 DC XL4'0000D3C5' LE 16 34000014 DC F'16' 34400014 DC XL4'0000C5D8' EQ 18 34800014 DC F'18' 35200014 DC XL4'0000C7E3' GT 20 35600014 DC F'20' 36000014 DC XL4'0000D3E3' LT 19 36400014 DC F'19' 36800014 DC XL4'0000D5C5' NE 21 37200014 DC F'21' 37600014 DC XL4'00E7D6D9' XOR 7 38000014 DC F'7' 38400014 SPACE 2 38800014 *********************************************************************** 39200014 SPACE 39600014 * DELIMITER ADJECTIVE CODE TABLE NDLMTB(2,12) 40000014 SPACE 40400014 NDLMTB DC C'.',X'03' 40800014 DC C')',X'05' 41200014 DC C'=',X'08' 41600014 DC C',',X'09' 42000014 DC C'+',X'0A' 42400014 DC C'-',X'0B' 42800014 DC C'*',X'0C' 43200014 DC C'/',X'0D' 43600014 DC C'(',X'19' 44000014 DC X'4F',X'1A' 44400014 DC X'00',X'1C' 44800014 DC C'''',X'1F' 45200014 SPACE 2 45600014 *********************************************************************** 46000014 SPACE 46400014 * TABLE OF ALLOWABLE TYPES IN AN 46800014 * IMPLICIT STATEMENT NAMTYP(2,5) 47200014 SPACE 47600014 NAMTYP DC CL8' INTEGER' 48000014 DC CL8' REAL' 48400014 DC CL8' COMPLEX' 48800014 DC CL8' LOGICAL' 49200014 DC CL8' LITERAL' 49600014 SPACE 2 50000014 *********************************************************************** 50400014 NGENLB DC F'100000' VALUE TO BE ASSIGNED NEXT GENERATED LABEL 50800014 ISN DC F'1' INTERNAL STATEMENT NUMBER 51200014 IDOLEV DC F'1' NUMBER OF IMPLIED DO'S UNRESOLVED 51600014 NAME DC 4F'0' PACKED VARIABLE OR CONST. RIGHT JUSTIFIED 52000014 NBEGPT DC F'0' STARTING POINT OF SCAN 52400014 NSCNPT DC F'0' SCAN POINT 52800014 LENGTH DC F'0' # OF CHARS IN LAST VAR OR CONST SCANNED 53200014 NPRVDL DC F'0' PREVIOUS DELIMITER ENCOUNTERED IN SCAN 53600014 NDELM DC F'0' DELIMITER AT END OF SCAN 54000014 NTST DC F'0' SET TO 1 WHEN GETWD BEGINS PROCESSING STMT 54400014 * SET TO 0 WHEN ENDMARK IS ENCOUNTERED 54800014 NNT DC F'0' 1 INDICATES CONVERTED CONST. AN INTEGER 55200014 NLOG DC F'0' 1 INDICATES CONVERTED CONST. LOGICAL 55600014 NCPLX DC F'0' 1 INDICATES CONVERTED CONST. COMPLEX 56000014 NACCM DC F'0' CONTAINS BINARY REPRESENTATION OF SINGLE 56400014 * PRECISION CONSTANT. 56800014 NACCSV DC F'0' ITEM SCANNED BY GETWD WAS A 0 - DELIMITER, 57200014 * 1 - A CONSTANT, OR 2 - A VARIABLE. 57600014 NMNSW DC F'0' 1 INDICATES CONVERTED CONST. IS NEGATIVE 58000014 NCPX DC F'0' 1 INDICATES COMPLEX CONSTANT WAS SCANNED 58400014 NSHFT1 DC F'0' MODE OF CONSTANT OR VARIABLE 58800014 ISAVE2 DC F'0' 1 INDICATES ASF IS BEING PROCESSED 59200014 NXTRN DC F'0' 1 INDICATES CURRENT STMT. HAS A LABEL 59600014 NTST2 DC F'0' COUNTS NO. OF &LABEL ARGS. IN CALL STMT. 60000014 IFTRLG DC F'0' 1 INDICATES 1ST PART OF A LOGICAL IF HAS 60400014 * BEEN PROCESSED AND MUST CHECK 2ND PART FOR 60800014 * GO TO. 2 INDICATES 2ND PART OF IF STATE- 61200014 * MENT HAS BEEN PROCESSED. 61600014 NDOSG DC F'0' 1 INDICATES CURRENT STMT ENDS A DO LOOP. 62000014 NCALLG DC F'0' 1 INDICATES CALL STMT BEING PROCESSED 62400014 NASF DC F'0' 1 INDICATES AN ASF IS BEING PROCESSED 62800014 NRELIF DC F'0' 1 INDICATES RELATIONAL IF BEING PROCESSED 63200014 NXSMNG DC F'0' 63600014 NDATSG DC F'0' 1 INDICATES MUST GENERATE LABEL AFTER IF 64000014 NPRCNT DC F'0' PARENTHESIS COUNT 64400014 LBSWG DC F'0' 1 TELLS LABTLU THAT LABEL IS GENERATED 64800014 NSBOL DC F'0' 1 INDICATES THAT VARIABLE WAS PROCESSED 65200014 NDVSV DC F'0' 65600014 INEWDL DC F'0' 66000014 IPREDL DC F'0' 66400014 IASTR DC F'0' COMAST REMEMBERS IF 1 ASTERISK HAS ALREADY 66800014 * OCCURRED IN CHECKING FOR EXPONENTIATION. 67200014 NARGSW DC F'0' 1 INDICATES PRESENCE OF ARGUMENTS IN CALL 67600014 NCOMEX DC F'0' 1 SET BY XCOMON BEFORE CALLING XDIM 68000014 NTYPEX DC F'0' 1 SET BY XTYPE BEFORE CALLING XDIM AND 68400014 * 2 SET BY XTYPE BEFORE CALLING INTCON 68800014 IMDOSW DC F'0' 1 SET BY XIMPDO BEFORE CALLING CDOPAR 69200014 NLFARY DC F'0' 1 INDICATES SUBSCRIPTED VARIABLE APPEARS 69600014 * ON LEFT OF = SIGN IN ARITHMETIC ASSIGNMENT 70000014 * STATEMENT. 70400014 NDOLRT DC F'0' 1 INDICATES 1ST CHAR OF SYMBOL IS $ 70800014 NHRETN DC F'0' 1 INDICATES HOLLERITH FIELD WAS SCANNED 71200014 IOSWG DC F'0' 1 INDICATES I/O LIST FOLLOWS READ/WRITE 71600014 NAMLST DC F'0' 1 INDICATES NAMELIST STMT BEING PROCESSED 72000014 NIF DC F'0' 1 INDICATES AN IF STMT IS BEING PROCESSED 72400014 NSUBCT DC F'0' 72800014 NSUBSW DC F'0' 73200014 LABCMP DC F'0' TEMPORARILY HOLDS LABEL TO BE PLACED 73600014 * IN NLABWK. RESET BY LABTLU OR DSPTCH. 74000014 NDATSV DC F'0' XEQUI SETS THIS TO 1 IF SUBSCRIPTED 74400014 * VARIABLE IS EQUIVALENCED. XGO AND XCLASS 74800014 * SAVE POINTER TO A TEXT ENTRY WHICH 75200014 * REQUIRES A (POSSIBLY GENERATED) LABEL. 75600014 NXTRA DC F'0' XCLASS SETS A POINTER TO THE TEXT ENTRY 76000014 * CREATED FOR A STATEMENT NUMBER DEFINITION. 76400014 NBEGDO DC F'0' 1 INDICATES DO STMT IS BEING PROCESSED 76800014 NEXCSG DC F'0' 1 INDICATES EXECUTABLE STMT HAS OCCURRED 77200014 NDOLEV DC F'0' NUMBER OF DO'S CURRENTLY UNRESOLVED 77600014 LIFTXL DC F'0' POINTS TO TEXT FOR AN IF STMT REQUIRING 78000014 * A FALL THRU LABEL. 78400014 LSTXX DC F'0' 78800014 LABSAV DC F'0' CONTAINS LABEL MARKING END OF DO LOOP 79200014 NSUBRG DC F'0' LOCATION OF TEXT W/ADJ.CODE 208 (FUNCTION) 79600014 NTRYMD DC F'0' 1 INDICATES DICTIONARY ENTRY MADE 80000014 IDCTPT DC F'0' POINTER TO CURRENT DICTIONARY ENTRY 80400014 ILABPT DC F'0' POINTER TO CURRENT LABEL ENTRY 80800014 NCLSTX DC F'0' SET TO 0 FOR PUTX, 1 FOR CLOSE. 81200014 MTPSET DC F'0' 0 -- PUTX SETS MODE, TYPE, POINTER 81600014 * 1 -- PUTX SETS MODE=11 AND POINTER 82000014 * 2 -- NO SETTING 82400014 NPUTSV DC F'0' 82800014 LPUT DC F'0' 83200014 MSGNO DC F'0' ERROR MESSAGE NUMBER 83600014 NERSW DC F'0' 1 INDICATES ERROR WAS DETECTED 84000014 *********************************************************************** 84400014 SPACE 2 84800014 *********************************************************************** 85200014 SPACE 85600014 IMPDOD DC 120F'0' ARRAY (6,20) IN WHICH IMPLIED DO INFOR- 86000014 * MATION IS STORED. THE 6 PARAMETERS PER 86400014 * IMPLIED DO STATEMENT-- 86800014 * 1. IMPDOD POINTER 87200014 * 2. INDEX VARIABLE 87600014 * 3. INCREMENT 88000014 * 4. MAXIMUM INDEX VALUE 88400014 * 5. GENERATED LABEL POINTER 88800014 * 6. INITIAL INDEX VALUE 89200014 SPACE 89600014 *********************************************************************** 90000014 SPACE 90400014 IASFTB DS 60F 90800014 KSV1 DS 1F 91200014 NSSEQ DS 1F 91600014 SLIMS DS 10F 92000014 LFPUTS DS 10F 92400014 LPUTS DS 5F 92800014 LASTEM DS 1F 93200014 NDOPDN DS 150F 93600014 SPACE 94000014 END 94400014 ./ ADD SSI=21410020,NAME=IEKCAR,SOURCE=0 C SUBROUTINE XARITH 00070014 SUBROUTINE IEKCAR 00140014 C 812700 0000A 00170015 C0030256200,273700 15767 00180016 C0030632100,634900,637700,639100,641900,644700 000B 00190016 C2271136900-137100,260700-260900 17385 00200017 C2980390900,657600 19014 00203017 C2980175800-176200 19360 00206017 C3134260000,260700 000C 00208017 C3230219100,256630-256840 21066 00208618 C3230275700-277700 PTM1066 00209218 C0301054900,103100-103300,212300-212500,256730-256830, 000D 00209418 C 274700-279700,282900,383100-383300 000D 00209618 C0480707300 21937 00209818 C0500103300,256606-256624,256811-256816,557500 19345 00209918 C 260000,658100-658500,915700-916100 23397 00219919 C 623000-624400 23394 00229919 C 617500-617900 24781 00239919 C 291200-293300 0000E 00259919 C 256626-256628,452400-452800 34224 00269920 C A382920-383040 LL51353 00274921 C A052600-053100,A203100-203500,A214300-214600, LL51322 00275921 C A245800-246100,A385800-386200,A621000-621300 LL51322 00276921 C A658530-658650,A819780-820260,A916130-916250 LL51332 00277921 C DICTIONARY LAYOUT 00280014 C 00350014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00420014 LOGICAL*1 BYA,BYB,BYC 00490014 INTEGER*2 DIS,MDD,TYP 00560014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00630014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 00700014 * NAM1,NAM2,NAM3,NAM4 00770014 C 00840014 C 00910014 C INTERMEDIATE TEXT LAYOUT 00980014 C 01050014 LOGICAL * 1 ADJCD 01120014 INTEGER * 2 TMOD,TTYP 01190014 INTEGER TXTCHN,TPTR 01260014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 01330014 C 01400014 C DIMENSION ENTRY LAYOUT 01470014 C 01540014 INTEGER ASIZE,DIM1 01610014 INTEGER*2 ELGTH,NDIM 01680014 STRUCTURE // ASIZE,NDIM,ELGTH,DIM1 01750014 C 01820014 C BRANCH TABLE LAYOUT 01890014 C 01960014 LOGICAL * 1 IND 02030014 INTEGER CHN,PTRSN,RELOC 02100014 STRUCTURE // IND // CHN,PTRSN,RELOC 02170014 C 02240014 COMMON /IEKAAA/ NPTR (2,35) 02310014 COMMON /IEKAER/ NERTBL (2,50) 02380014 C 02450014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 02520014 INTEGER SLIMS 02590014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 02660014 *M2R3,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 02730014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 02800014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 02870014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 02940014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 03010014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 03080014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 03150014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 03220014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 03290014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 03360014 C 03430014 EQUIVALENCE (NPTR (1,9), NPUT) 03500014 DATA NTRU, NFLSE /ZE3D9E4C5, ZC1D3E2C5/ 03570014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC03640014 C C03710014 C XARITH - IEKCAR C03780014 C C03850014 C C03920014 C FUNCTION - XARITH TRANSLATES ARITHMETIC STATEMENTS, CALL ARGUMENTS, C03990014 C ARITHMETIC IF ARGUMENTS, I/O LISTS, VARIABLE AND ARRAY C04060014 C NAMES IN NAMELISTS, COMPLEX LITERALS IN DATA STATEMENTS, C04130014 C AND ARITHMETIC EXPRESSIONS IN STATEMENT FUNCTIONS. XARITH C04200014 C CHECKS SYNTAX AND GENERATES THE NECESSARY TEXT AND/OR C04270014 C DICTIONARY ENTRIES. C04340014 C C04410014 C CALLED BY - COMAST, GRPKEQ, MINSLS, PERLOG, RTPRQT, TXTBLD, XCLASS C04480014 C C04550014 C CALLS - COMAST, COMPAT, ERROR, GRPKEQ, MINSLS, RTPRQT, PUTX, PERLOG C04620014 C CSORN, GETWD, DSPTCH, TXTBLD C04690014 C C04760014 C COMMON - BLANK, PH10, P10A C04830014 C C04900014 C ERRORS - 32, 33, 48, 76, 60 04970014 C C05040014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC05110014 C 05180014 C 05250014 C 05260021 C INDICATES WE HAVE SCANNED ASF IN ARITHMETIC STMT 05270021 NASFSW=0 05280021 C 05290021 C COUNTS PARENS AFTER ASF IS SCANNED IN ARITH STMT 05300021 NASFCT=0 05310021 C 05320014 C 05390014 C 05460014 NSUB=0 05490018 GO TO (1045,1055,1020,1145,3060), NERSW 05530014 C VARIABLE WAS DIMENSIONED BUT IS 05600014 C USED HERE WITHOUT A SUBSCRIPT. 05670014 C FOLLOWING SETS THE NECESSARY 05740014 C TEXT ENTRIES TO REPRESENT THE 05810014 C SUBSCRIPT. 05880014 C 05950014 1015 CALL IEKCPX 06020014 C 06090014 C OBTAIN ADDRESS OF DIMENSION 06160014 C ENTRY OF THE VARIABLE. 06230014 1020 I = PDI (IDCTPT) 06300014 C OBTAIN NUMBER OF DIMENSIONS. 06370014 I = NDIM (I) 06440014 C SET ADJECTIVE CODE FOR OPENING 06510014 C PAREN IN TEXT WORK AREA. 06580014 ADJCD (NPUT) = 22 06650014 C SET ADDRESS OF DICTIONARY 06720014 C ENTRY FOR THE CONSTANT 1, 06790014 C GIVING THE FIRST ELEMENT OF 06860014 C THE ARRAY AS THE SUBSCRIPT. 06930014 1025 IDCTPT = NPTR (1,25) + 72 07000014 C FOLLOWING CALL TO PUTX HAS THE 07070014 C TEXT ENTRY FOR THE ABOVE 07140014 C GENERATED. 07210014 C CALL PUTX 07280014 CALL IEKCPX 07350014 C TEST IF ALL DIMENSION ENTRIES 07420014 C HAS BEEN MADE. IF THEY HAVE, 07490014 C BRANCH. 07560014 IF(I.EQ.1) GOTO 1030 07630014 C DECREMENT NUMBER OF DIMENSIONS. 07700014 I=I-1 07770014 C SET ADJECTIVE CODE FOR A COMMA. 07840014 ADJCD (NPUT) = 9 07910014 C BRANCH BACK TO COMPLETE ENTRY 07980014 C MAKING. 08050014 GOTO 1025 08120014 C 08190014 C SET CLOSING PAREN. 08260014 C 08330014 1030 ADJCD (NPUT) = 5 08400014 C 08470014 MSGNO = 206 08540014 C 08610014 NERSW = 6 08680014 C 08750014 CALL IEKCDP 08820014 C 08890014 C SET INDICATORS AS IF THE RIGHT 08960014 C PAREN HAD BEEN USED. 09030014 C 09100014 LENGTH = 0 09170014 C 09240014 NPRVDL = NRTPR 09310014 C 09380014 IF(NDELM .EQ. NEQ) NLFARY = 1 09450014 C 09520014 GO TO 1145 09590014 C 09660014 C ARRAY. SET ADJECTIVE CODE FOR A 09730014 C SUBSCRIPT PAREN. 09800014 C 09870014 3060 ADJCD (NPUT) = 22 09940014 C 10010014 C INCREMENT PAREN COUNT. 10080014 C 10150014 3062 NPRCNT = NPRCNT + 1 10220014 C 10290014 C INCREMENT SUBSCRIPT COUNT IN I/O LIST10310018 IF(IOSWG.NE.0.AND.ADJCD(NPUT).NE.15)NSUB=NSUB+1 10330018 GO TO 1045 10360014 C 10430014 1600 MTPSET = 1 10500014 C 10570014 C CALL PUTX 10640014 1602 CALL IEKCPX 10710014 1045 NERSW = 0 10780014 C 10850014 C IF THE NEW DELIMITER IS NOT AN 10920014 C ASTERISK, SET INDICATOR OFF. 10990014 C 11060014 IF(NDELM .NE. NASTR) IASTR = 0 11130014 C 11200014 C FOLLOWING CALL TO GETWD ACCESSES THE 11270014 C FIRST (NEXT) ELEMENT. 11340014 C CALL GETWD 11410014 1055 CALL IEKCGW 11480014 C 11550014 C IF THE ELEMENT ACCESSED IS NOT A 11620014 C DELIMITER, BRANCH. 11690014 C 11760014 IF(LENGTH .NE. 0) GO TO 1058 11830014 C 11900014 C FOLLOWING DO-LOOP SETS INEWDL 11970014 C ACCORDING TO THE NEW DELIMITER. 12040014 C 1) . 12110014 C 2) ) 12180014 C 3) = 12250014 C 4) , 12320014 C 5) + 12390014 C 6) - 12460014 C 7) * 12530014 C 8) / 12600014 C 9) ( 12670014 C 10) END MARK 12740014 C 11) NOT USED 12810014 C 12) ' 12880014 C 12950014 1145 DO 3145 INEWDL = 1, 12 13020014 C 13090014 IF(NDELM .EQ. NDLMTB (1,INEWDL)) GO TO 3150 13160014 C 13230014 3145 CONTINUE 13300014 C 13370014 13 MSGNO = 13 13440014 C 13510014 1300 NERSW = 6 13580014 GO TO 90000 13650014 C 13660016 11 MSGNO = 11 13670016 GO TO 1300 13680016 C 13690017 15 MSGNO = 15 13700017 GO TO 1300 13710017 C 13720014 53 MSGNO = 53 13790014 GO TO 1300 13860014 C 13930014 167 MSGNO = 167 14000014 GO TO 1300 14070014 C 14140014 C IF THE NEW DELIMITER IS NOT 14210014 C IMMEDIATELY PRECEEDED BY A DELIMITER,14280014 C BRANCH. 14350014 C . ) = , + - 14420014 3150 IF(LENGTH .NE. 0) GO TO (10000,20003, 53,40007,1602 ,1602 , 14490014 C * / ( ENDMK NO USE ' 14560014 * 70000, 1602, 13,22000, 1045, 13), INEWDL 14630014 C . ) = , + - * / ( 14700014 3152 GO TO (10000,20000,30000,40000,50000,50000,70005,80000,90002, 14770014 C ENDMK NOUSE ' 14840014 * 22000, 1045,12000), INEWDL 14910014 C 14980014 C IF A STATEMENT FUNCTION DEFINITION IS15050014 C NOT BEING PROCESSED OR THE ELEMENT 15120014 C ACCESSED IS A CONSTANT, BRANCH. 15190014 C 15260014 1058 IF(ISAVE2 .NE. 1 .OR. NACCSV .EQ. 1) GO TO 1060 15330014 C 15400014 C STATEMENT FUNCTION DEFINITION. 15470014 C 15540014 CALL IEKCS1 15610014 C 15680014 C FOLLOWING DO-LOOP DETERMINES IF THE 15750014 C VARIABLE IS A STATEMENT FUNCTION 15820014 C ARGUMENT. IF IT IS, BRANCH. 15890014 C (NSSEQ CONTAINS THE NUMBER OF 15960014 C ARGUMENTS PROCESSED). 16030014 C 16100014 DO 1125 NP = 1, NSSEQ 16170014 C 16240014 IF (NAME(4).EQ.IASFTB(3,NP).AND.NAME(3).EQ.IASFTB(2,NP)) 16280017 XGO TO 1130 16320017 C 16380014 1125 CONTINUE 16450014 C 16520014 GO TO 1060 16590014 C 16660014 C STATEMENT FUNCTION ARGUMENT. 16730014 C 16800014 C INDICATE THAT ARGUMENT HAS BEEN USED.16870014 C 16940014 1130 IASFTB(1,NP) = BITON(IASFTB(1,NP),0) 17010017 C 17080014 C SAVE RELATIVE POSITION IN TABLE. 17150014 C 17220014 NASF = NP 17290014 C 17360014 GO TO 1145 17430014 C CALL CSORN 17500014 1060 CALL IEKCCR 17570014 C SET SYMBOL REFERRED TO BIT ON IF CONSTANT 17580017 C IN INTEGER EXPRESSION FOR RELATIVE 17590017 C POSITION IN DIRECT ACCESS I/O STATEMENT. 17600017 IF((NCARD(4).EQ.44.OR.NCARD(4).EQ.51).AND.NSUBCT.EQ.1.AND. 17610017 *TYP(IDCTPT).EQ.5) BYA(IDCTPT)=BITON(BYA(IDCTPT),1) 17620017 C 17640014 C IF THE ELEMENT ACCESSED IS A 17710014 C HOLLERITH COUNT, BRANCH. 17780014 C 17850014 IF(NHRETN .NE. 0) GO TO 12000 17920014 C 17990014 C IF THE ELEMENT ACCESSED IS A VARIABLE18060014 C BRANCH. 18130014 C 18200014 1063 IF(NACCSV .EQ. 2) GO TO 1065 18270014 C 18340014 C INSURE CONSTANT IS NOT BEING USED AS 18410014 C A LIST ITEM. 18480014 C 18550014 IF(IOSWG .EQ. 0 .OR. NPRCNT .NE. 0) GO TO 1145 18620014 C 18690014 MSGNO = 157 18760014 C 18830014 GO TO 1300 18900014 C 18970014 C IF THE VARIABLE IS A CALL OR 19040014 C FUNCTION ARGUMENT, SET THE 19110014 C INDICATOR. 19180014 C 19250014 1065 IF(NCALLG + NDVSV .NE. 0) BYB (IDCTPT) = BITON (BYB (IDCTPT),2) 19320014 C 19390014 C 19460014 C IF THE STATEMENT FUNCTION NAME IS 19530014 C BEING REFERENCED IN ITS OWN 19600014 C DEFINITION, SET THE ERROR. 19670014 C 19740014 IF(ISAVE2 .EQ. 1 .AND. IDCTPT .EQ. KSV1) GO TO 167 19810014 C IF THE VARIABLE IS STRUCTURED, BRANCH19880014 C 19950014 IF(TBIT (BYA (IDCTPT),0)) GO TO 1198 20020014 C IF THE VARIABLE IS NOT A STATEMENT 20090014 C FUNCTION NAME, BRANCH. 20160014 C 20230014 IF(TYP (IDCTPT) .NE. 6) GO TO 1075 20300014 C 20310021 C IN ARITH STMT AND SCANNED AN ASF, THEN SET ASF 20320021 C SWITCH TO 1 20330021 C 20340021 IF(NCARD(4) .EQ. 56) NASFSW=1 20350021 C 20370014 C INSURE LEFT PAREN FOLLOWS VARIABLE 20440014 C AND THAT IT IS NOT A LIST ITEM. 20510014 IF(NDELM .NE. NLFPR .OR. IOSWG .EQ. 1 .AND. NPRCNT .EQ. 0) 20580014 * GO TO 167 20650014 C CALL PUTX 20720014 1110 CALL IEKCPX 20790014 C 20860014 C SET ADJECTIVE CODE FOR A FUNCTION 20930014 C LEFT PAREN. 21000014 C 21070014 ADJCD (NPUT) = 15 21140014 C 21210014 C INCREMENT SUBSCRIPT COUNT IN I/O LIST21230018 IF(IOSWG.NE.0)NSUB=NSUB+1 21250018 C INCREMENT FUNCTION PAREN COUNT. 21280014 C 21350014 NDVSV = NDVSV + 1 21420014 C 21430021 C INCREMENT ASF PAREN CT IF ASF SWITCH IS ON 21440021 C 21450021 IF(NASFSW .EQ. 1) NASFCT=NASFCT+1 21460021 C 21490014 GO TO 3062 21560014 C 21630014 C IF THE VARIABLE IS NOT DIMENSIONED, 21700014 C BRANCH. 21770014 C 21840014 1075 IF(LAND (TYP (IDCTPT),M2R3) .NE. 2) GO TO 1076 21910018 C IF THE VARIABLE IS FOLLOWED BY A LEFT21980014 C PAREN, BRANCH. 22050014 C 22120014 IF(NDELM .EQ. NLFPR) GO TO 1197 22190014 C ARRAY NAME IS NOT FOLLOWED BY A LEFT 22260014 C PAREN. 22330014 C IF IT IS NOT IN AN I/O LIST AND IS 22400014 C NOT A FUNCTION OR CALL ARGUMENT, 22470014 C BRANCH. 22540014 C 22610014 IF(IOSWG + NDVSV + NCALLG .EQ. 0) GO TO 1015 22680014 C 22750014 C IF THE VARIABLE IS NOT DELIMITED BY 22820014 C A COMMA, RIGHT PAREN, OR AN END 22890014 C MARK, BRANCH. 22960014 C 23030014 IF(NDELM .NE. NCOMA .AND. NDELM .NE. NRTPR .AND. NDELM .NE. 23100014 C 23170014 * NGPMK) GO TO 1015 23240014 C 23310014 C IF THE PREVIOUS DELIMITER IS NOT A 23380014 C COMMA, LEFT PAREN, OR A RIGHT 23450014 C PAREN (SINGLE LIST ITEM), BRANCH. 23520014 C 23590014 IF(NPRVDL.NE. NCOMA .AND. NPRVDL.NE. NRTPR .AND. NPRVDL.NE. 23660014 C 23730014 * NLFPR) GO TO 1015 23800014 C 23870014 C ARRAY WITHOUT SUBSCRIPT IS VALID. 23940014 C 24010014 GO TO 1145 24080014 C 24150014 C VARIABLE IS VALIDLY FOLLOWED BY A 24220014 C LEFT PAREN. 24290014 C IF FUNCTION ARGUMENTS ARE BEING 24360014 C PROCESSED, RESET COUNT. 24430014 C 24500014 1197 IF(NDVSV .GT. 0) NDVSV = NDVSV + 1 24570014 C 24580021 C INCREMENT ASF PAREN CT IF ASF SWITCH IS ON 24590021 C 24600021 IF(NASFSW .EQ. 1) NASFCT=NASFCT+1 24610021 C 24640014 CALL IEKCPX 24710014 C 24780014 GO TO 3060 24850014 C 24920014 C VARIABLE IS STRUCTURED. IF IT IS 24990014 C FOLLOWED BY A LEFT PAREN, BRANCH. 25060014 C 25130014 1198 IF(NDELM .EQ. NLFPR) GO TO 1197 25200014 C 25270014 60 MSGNO = 60 25340014 GO TO 1300 25410014 C 25480014 153 MSGNO = 153 25550014 GO TO 1300 25620014 157 MSGNO=157 25640016 GO TO 1300 25660016 163 MSGNO=163 25660618 GO TO 1300 25661218 164 MSGNO=164 25661818 GO TO 1300 25662418 192 MSGNO=192 25662620 GO TO 1300 25662820 1074 NBEGPT=NBEGPT+LENGTH 25663018 GO TO 13 25666018 C 25669018 C VARIABLE IS NOT DIMENSIONED. 25672018 C BRANCH IF I/O SUBSCRIPT NOT BEING 25673018 C PROCESSED. 25674018 1076 IF(NSUB.EQ.0)GO TO 1078 25675018 C BRANCH IF WRONG DELIMITER IN 25676018 C I/O SUBSCRIPT. 25677018 IF(NDELM.EQ.NGPMK.OR.NDELM.EQ.NEQ.OR.NDELM.EQ.NQUOT)GO TO 1074 25678018 GO TO 1077 25679018 C BRANCH IF NOT I/O LIST ITEM. 25680018 1078 IF(IOSWG.NE.1)GO TO 1077 25681018 C BRANCH IF FUNCTION REFERENCE IS USED 25681118 C AS AN I/O LIST ITEM. 25681218 IF(TYP(IDCTPT).EQ.4.OR.TYP(IDCTPT).EQ.12)GO TO 164 25681318 C BRANCH IF UNDIMENSIONED ARRAY IN I/O 25681418 C LIST. 25681518 IF(NDELM.EQ.NLFPR)GO TO 163 25681618 C BRANCH IF WRONG DELIMITER IN I/O LIST25682018 IF(NDELM.NE.NCOMA.AND.NDELM.NE.NGPMK)GO TO 1074 25683018 C 25690014 C VARIABLE IS NOT DIMENSIONED. 25760014 C IF IT IS NOT DELIMITED BY A LEFT 25830014 C PAREN, BRANCH. 25900014 C 25970014 1077 IF(NTRYMD.NE.1.AND.NDELM.NE.NLFPR.AND..NOT.TBIT(BYB(IDCTPT),2) 26000019 ..AND.TYP(IDCTPT).EQ.4.AND..NOT.TBIT(BYA(IDCTPT),0)) GO TO 11 26030016 IF(NDELM.NE.NLFPR) GO TO 1145 26060016 IF(NTRYMD.NE.1.AND.DIS(IDCTPT).GE.(2**NDOLEV+1) 26070017 ..AND.NDELM.EQ.NLFPR.AND.TYP(IDCTPT).NE.4.AND.TYP(IDCTPT).NE.12 26080017 ..AND..NOT.TBIT(BYA(IDCTPT),0)) GO TO 15 26090017 C 26110014 C NON - DIMENSIONED VARIABLE IS 26180014 C FOLLOWED BY LEFT - PAREN. 26250014 C EXTERNAL FUNCTION IS ASSUMED. 26320014 C 26390014 C IF THE VARIABLE WAS EQUIVALENCED, 26460014 C USED IN A COMMON, DATA, OR NAMELIST 26530014 C STATEMENT, SET THE ERROR. 26600014 C 26670014 IBYA = BYA (IDCTPT) 26740014 C 26810014 IBYB = BYB (IDCTPT) 26880014 C 26950014 IF(LAND (IBYA,40) .NE. 0 .OR. LAND (IBYB,17) .NE. 0) GO TO 153 27020014 C 27090014 C SET EXTERNAL FUNCTION INDICATOR. 27160014 C 27230014 NPTR (1,23) = 1 27300014 C 27370014 C BRANCH IF NOT I/O STATEMENT. 27470018 IF(NCARD(4).NE.39.AND.NCARD(4).NE.40.AND.NCARD(4).NE.44.AND. 27570018 * NCARD(4).NE.51)GO TO 1079 27670018 C BRANCH IF NEITHER IN I/O SUBSCRIPT 27770018 C NOR IN DA I/O INTEGER EXPRESSION. 27870018 IF(NSUB.EQ.0.AND.NSUBCT.EQ.0)GO TO 157 27970018 C SET TYPE TO EXTERNAL FUNCTION. 28210014 C 28280014 1079 TYP (IDCTPT) = 4 28290018 C 28300014 C IF THE NAME WAS PASSED AS AN ARGUMENT28310014 C RESET THE TYPE TO DUMMY EXTERNAL 28320014 C FUNCTION. 28330014 C 28340014 IF(TBIT (BYB (IDCTPT),0)) TYP (IDCTPT) = 12 28350014 C 28420014 GO TO 1110 28490014 C 28560014 C DELIMITER IS A PERIOD. 28630014 C IF THE CHARACTER FOLLOWING THE PERIOD28700014 C IS NOT A DIGIT, BRANCH. 28770014 C 28840014 10000 IF(NCDIN (NSCNPT) .LT. 234) GO TO 10005 28910014 C 28980014 C REAL CONSTANT. 29050014 C IF PRECEEDED BY A VARIABLE OR A 29100019 C LEFT PAREN SET THE ERROR 29150019 C 29200019 C 29250019 IF( LENGTH.NE.0 .OR. NPRVDL.EQ.NRTPR ) GO TO 13 29300019 C 29400014 CALL IEKCCR 29470014 C INSURE LENGTH IS GREATER THAN ZERO. 29540014 LENGTH = 2 29610014 GO TO 1145 29680014 C NON-DIGIT FOLLOWS PERIOD. 29750014 C 29820014 C SAVE PREVIOUS LENGTH. 29890014 C 29960014 10005 LNGHSV = LENGTH 30030014 C 30100014 C FOLLOWING CALL TO GETWD ACCESSES THE 30170014 C VARIABLE. 30240014 C 30310014 CALL IEKCGW 30380014 C 30450014 C INSURE ELEMENT IS NOT A DELIMITER. 30520014 C 30590014 IF(LENGTH .EQ. 0) GO TO 7 30660014 C 30730014 CALL IEKCS1 30800014 C 30870014 C INSURE THE VARIABLE IS DELIMITED BY 30940014 C A PERIOD. 31010014 C 31080014 IF(NDELM .NE. NPER) GO TO 13 31150014 C 31220014 C IF THE VARIABLE LENGTH IS LESS THAN 31290014 C 4, BRANCH. 31360014 C 31430014 IF(LENGTH .LT. 4) GO TO 10025 31500014 C 31570014 C VALID VARIABLE ONLY IF TRUE OR FALSE.31640014 C IF THE VARIABLE IS FALSE, BRANCH. 31710014 C 31780014 IF(LENGTH .EQ. 5 .AND. NAME (4) .EQ. NFLSE .AND. NCDIN (NBEGPT) 31850014 C 31920014 * .EQ. 198) GO TO 10010 31990014 C 32060014 C IF THE VARIABLE IS TRUE, BRANCH. 32130014 C 32200014 IF(LENGTH .EQ. 4 .AND. NAME (4) .EQ. NTRU) GO TO 10015 32270014 C 32340014 3 MSGNO = 3 32410014 C 32480014 GO TO 1300 32550014 C 32620014 C .FALSE. 32690014 C SET FOR CONSTANT = 0 32760014 C 32830014 10010 NAME (4) = 0 32900014 NAME (3) = 0 32970014 GO TO 10020 33040014 C 33110014 C .TRUE. 33180014 C SET FOR CONSTANT = 1 33250014 C 33320014 10015 NAME (4) = 1 33390014 C INSURE DELIMITER PRECEEDED CONSTANT. 33460014 10020 IF(LNGHSV .NE. 0) GO TO 13 33530014 C SET CONSTANT ENTRY INDICATORS. 33600014 LENGTH = 14 33670014 C 33740014 NSHFT1 = 3 33810014 C 33880014 C CALL SYMTLU 33950014 CALL IEKCS2 34020014 C 34090014 C INSURE DELIMITER FOLLOWS CONSTANT. 34160014 C 34230014 CALL IEKCGW 34300014 C 34370014 IF(LENGTH .NE. 0) GO TO 13 34440014 C 34510014 C RESET LENGTH AS IF CONSTANT PRECEEDED34580014 C NEW DELIMITER. 34650014 C 34720014 LENGTH = 1 34790014 C 34860014 GO TO 1145 34930014 C 35000014 C LOGICAL OR RELATIONAL OPERATOR. 35070014 C 35140014 C SET PREVIOUS ITEM TO TEXT. 35210014 C 35280014 10025 IF(LNGHSV .EQ. 0) MTPSET =1 35350014 C 35420014 CALL IEKCPX 35490014 C 35560014 C FOLLOWING DO-LOOP INSURES THAT THE 35630014 C VARIABLE IS A VALID LOGICAL OR 35700014 C RELATIONAL OPERATOR. 35770014 C 35840014 DO 10030 I = 1,10 35910014 C 35980014 IF(NAME (4) .EQ. NLOGTB (1,I)) GO TO 10035 36050014 C 36120014 10030 CONTINUE 36190014 C 36260014 GO TO 3 36330014 C 36400014 C VALID OPERATOR. 36470014 C SET ADJECTIVE CODE TO TEXT. 36540014 C 36610014 10035 ADJCD (NPUT) = NLOGTB (2,I) 36680014 C 36750014 GO TO 1045 36820014 C 36890014 C DELIMITER IS A RIGHT PAREN AND 36960014 C PREVIOUS ELEMENT IS A DELIMITER. 37030014 C IF IT IS NOT A RIGHT PAREN, PERIOD, 37100014 C OR APOSTROPHE, SET THE ERROR. 37170014 C 37240014 20000 IF(NPRVDL .NE. NRTPR .AND. NPRVDL .NE. NPER .AND. NPRVDL .NE. 37310014 C 37380014 * NQUOT) GO TO 7 37450014 C 37520014 MTPSET = 1 37590014 C 37660014 C IF THE DELIMITER ENDS THE EXPRESSION 37730014 C PARAMETER OF A D/A - I/O STATEMENT, 37800014 C RETURN. 37870014 C 37940014 20003 IF(NSUBCT .NE. 0 .AND. NPRCNT .EQ. 0) GO TO 9998 38010014 C RESET PAREN COUNT. 38080014 C 38150014 20005 NPRCNT = NPRCNT - 1 38220014 C 38290014 C 38292021 C CHECK THAT IF IN I/O LIST AND A ) THAT ENDS A 38294021 C SUBSCRIPT, THE ONLY VALID FOLLOWING DELIMETERS ARE 38296021 C COMMA AND END MARK. 38298021 C 38300021 IF(IOSWG .EQ. 1 .AND.NSUB .EQ. 1 .AND. NCDIN(NSCNPT) .NE. 38302021 C NCOMA .AND. NCDIN(NSCNPT) .NE. NGPMK ) GO TO 164 38304021 C DECREMENT I/O SUBSCRIPT COUNT. 38310018 IF(NSUB.GT.0)NSUB=NSUB-1 38330018 C IF FUNCTION ARGUMENTS ARE BEING 38360014 C PROCESSED, RESET COUNT. 38430014 C 38500014 IF(NDVSV .GT. 0) NDVSV = NDVSV - 1 38570014 C 38580021 C DECREMENT ASF PAREN CT AND IF 0,SET ASF SWTCH OFF 38590021 C 38600021 IF(NASFSW .EQ. 1)NASFCT=NASFCT-1 38610021 IF(NASFCT .EQ. 0) NASFSW=0 38620021 C 38640014 C INSURE THAT THE RIGHT PAREN IS 38710014 C FOLLOWED BY A DELIMITER (ALLOW FOR 38780014 C ARITHMETIC IF). 38850014 C 38920014 IF(NCDIN (NSCNPT) .GT.192.AND. NCARD (4) .NE. 32) GO TO 13 38990014 C 39060014 IF(NDELM.EQ.NRTPR.AND.ADJCD(NPUT).EQ.15)MTPSET=0 39090017 C INSURE END MARK DELIMITS CALL 39130014 C ARGUMENTS. 39200014 C 39270014 IF(NCALLG .NE. 0 .AND. NPRCNT .EQ. 0 .AND. NCDIN (NSCNPT) .NE. 39340014 C 39410014 * NGPMK) GO TO 13 39480014 C 39550014 IF(NPRCNT) 5,20015,20010 39620014 C 39690014 5 MSGNO = 5 39760014 C 39830014 GO TO 1300 39900014 C 39970014 20010 IF(ADJCD (NPUT) .NE. 3) GO TO 1602 40040014 C 40110014 ADJCD (NPUT) = 5 40180014 C 40250014 GO TO 1045 40320014 C 40390014 C PAREN COUNT EQUALS ZERO. 40460014 C IF AN IF-STATEMENT IS NOT BEING 40530014 C PROCESSED, BRANCH. 40600014 C 40670014 20015 IF(NIF .EQ. 0) GO TO 20010 40740014 C 40810014 C IF THE PAREN IS IN A LOGICAL-IF 40880014 C TRAILER AND THE TRAILER IS NOT AN 40950014 C ARITHMETIC-IF, BRANCH. 41020014 C 41090014 IF(IFTRLG .NE. 0 .AND. NCARD (4) .NE. 32) GO TO 20010 41160014 C 41230014 IF(ADJCD (NPUT) .EQ. 3) GO TO 20020 41300014 C 41370014 CALL IEKCPX 41440014 C 41510014 C SET ADJECTIVE CODE FOR RIGHT PAREN. 41580014 C 41650014 20020 ADJCD (NPUT) = 5 41720014 C 41790014 MTPSET = 1 41860014 C 41930014 CALL IEKCPX 42000014 C 42070014 C SAVE LOCATION OF TEXT ENTRY FOR THE 42140014 C CLOSING PAREN. 42210014 C 42280014 NDATSG = LPUT 42350014 C 42420014 C SET END MARK TO TEXT. 42490014 C 42560014 ADJCD (NPUT) = 26 42630014 C 42700014 MTPSET = 1 42770014 C 42840014 CALL IEKCPX 42910014 C 42980014 C IF THE PAREN IS NOT FOR A LOGICAL-IF,43050014 C BRANCH. 43120014 C 43190014 IF(NCARD (4) .NE. 31) GO TO 20025 43260014 C 43330014 C SET TRAILER INDICATOR. 43400014 C 43470014 IFTRLG = 1 43540014 C 43610014 GO TO 1010 43680014 C 43750014 C ARITHMETIC-IF. 43820014 C FOLLOWING PROCESSES THE BRANCH LABELS43890014 C 43960014 20025 KNT = 0 44030014 C 44100014 C FOLLOWING CALL TO GETWD ACCESSES THE 44170014 C THE FIRST (NEXT) LABEL. 44240014 C 44310014 20030 CALL IEKCGW 44380014 C 44450014 C INSURE ELEMENT ACCESSED IS A CONSTANT44520014 C 44590014 IF(NACCSV .EQ. 1) GO TO 20035 44660014 C 44730014 6 MSGNO = 6 44800014 C 44870014 GO TO 1300 44940014 C 45010014 20035 CALL IEKCLT 45080014 C 45150014 BYA (ILABPT) = BITON (BYA (ILABPT),7) 45220014 C ERROR IF FORMAT LABEL IS USED 45240020 IF( TBIT(BYA(ILABPT),4 )) GO TO 192 45260020 C 45290014 ADJCD (NPUT) = 71 45360014 C 45430014 C BRANCH TO SET CONDITION CODE. 45500014 C 45570014 IF(KNT - 1) 20040,20045,20050 45640014 C 45710014 C FIRST LABEL - LESS THAN 0. 45780014 C 45850014 20040 TMOD (NPUT) = 4 45920014 C 45990014 GO TO 20055 46060014 C 46130014 C SECOND LABEL - EQUAL TO 0. 46200014 C 46270014 20045 TMOD (NPUT) = 8 46340014 C 46410014 GO TO 20055 46480014 C 46550014 C THIRD LABEL - GREATER THAN 0. 46620014 C 46690014 20050 TMOD (NPUT) = 2 46760014 C 46830014 C SET LABEL POINTER. 46900014 C 46970014 20055 TPTR (NPUT) = ILABPT 47040014 C 47110014 MTPSET = 1 47180014 C 47250014 CALL IEKCPX 47320014 C 47390014 C INCREMENT LABEL COUNT. 47460014 C 47530014 KNT = KNT + 1 47600014 C 47670014 C IF 3 LABELS HAVE BEEN PROCESSED, 47740014 C BRANCH. 47810014 C 47880014 IF(KNT .EQ. 3) GO TO 20060 47950014 C 48020014 C INSURE COMMA DELIMITS LABEL. 48090014 C 48160014 IF(NDELM .EQ. NCOMA) GO TO 20030 48230014 C 48300014 50 MSGNO = 50 48370014 C 48440014 GO TO 1300 48510014 C 48580014 C INSURE END MARK DELIMITS LABEL. 48650014 C 48720014 20060 IF(NDELM .NE. NGPMK) GO TO 50 48790014 C 48860014 C END OF STATEMENT. 48930014 C CLOSE TEXT. 49000014 NCLSTX = 1 49070014 C 49140014 CALL IEKCPX 49210014 C 49280014 GO TO 1010 49350014 C 49420014 C DELIMITER IS AN EQUAL SIGN AND 49490014 C PREVIOUS ELEMENT IS A DELIMITER. 49560014 C 49630014 C IF IT DOES NOT DELIMIT AN ARRAY, SET 49700014 C THE ERROR. 49770014 C 49840014 30000 IF(NPRVDL .NE. NRTPR .OR. NLFARY .EQ. 0) GO TO 53 49910014 C 49980014 NLFARY = 0 50050014 C 50120014 GO TO 1600 50190014 C 50260014 C DELIMITER IS A COMMA AND PREVIOUS 50330014 C ELEMENT IS A DELIMITER. 50400014 C INSURE VALID DOUBLE DELIMITER 50470014 C GROUPING. 50540014 C 50610014 40000 IF(NPRVDL .NE. NRTPR .AND. NPRVDL .NE. NPER .AND. NPRVDL .NE. 50680014 C 50750014 * NQUOT) GO TO 7 50820014 C 50890014 MTPSET = 1 50960014 C 51030014 C IF THE DELIMITER ENDS THE EXPRESSION 51100014 C PARAMETER OF A D/A - I/O STATEMENT, 51170014 C RETURN. 51240014 C 51310014 IF(NSUBCT .NE. 0 .AND. NPRCNT .EQ. 0) GO TO 9998 51380014 C 51450014 C IF THE PREVIOUS DELIMITER IS NOT A 51520014 C RIGHT PAREN OR AN I/O LIST IS NOT 51590014 C BEING PROCESSED OR THE PAREN COUNT IS51660014 C NOT ZERO. BRANCH. 51730014 IF(IOSWG .EQ. 0 .OR. NPRCNT .NE. 0 .OR. NPRVDL .NE. NRTPR) 51800014 C 51870014 * GO TO 1602 51940014 C 52010014 C RIGHT PAREN CLOSES LIST ITEM. 52080014 C SET PAREN TO TEXT. 52150014 C 52220014 40005 CALL IEKCPX 52290014 C 52360014 C DELIMIT LIST ITEM. 52430014 C 52500014 ADJCD (NPUT) = 26 52570014 C 52640014 MTPSET = 1 52710014 C 52780014 CALL IEKCPX 52850014 C 52920014 C SET FOR NEXT LIST ITEM. 52990014 C 53060014 ADJCD (NPUT) = 247 53130014 C 53200014 GO TO 1045 53270014 C 53340014 C DELIMITER IS COMMA AND PREVIOUS 53410014 C ELEMENT IS A VARIABLE OR CONSTANT. 53480014 C IF THE DELIMITER ENDS THE EXPRESSION 53550014 C PARAMETER OF A D/A - I/O STATEMENT, 53620014 C RETURN. 53690014 C 53760014 40007 IF(NSUBCT .EQ. 0 .OR. NPRCNT .NE. 0) GO TO 40010 53830014 C 53900014 9998 CALL IEKCPX 53970014 C 54040014 9999 RETURN 54110014 C 54180014 C IF AN I/O LIST IS NOT BEING 54250014 C PROCESSED OR THE PAREN COUNT IS NOT 54320014 C ZERO, BRANCH. 54390014 C 54460014 40010 IF(IOSWG .EQ. 0 .OR. NPRCNT .NE. 0) GO TO 1602 54530014 C 54600014 GO TO 40005 54670014 C 54740014 C DELIMITER IS A PLUS OR MINUS SIGN 54810014 C AND PREVIOUS ELEMENT IS A 54880014 C DELIMITER. 54950014 C 55020014 C IF IT IS PRECEEDED BY A RIGHT 55090014 C PAREN, IT IS BINARY. 55160014 C 55230014 50000 IF(NPRVDL .EQ. NRTPR) GO TO 1600 55300014 C 55370014 C INSURE VALID DOUBLE DELIMITER GROUPIN55440014 C 55510014 IF(NPRVDL.NE.NLFPR.AND.NPRVDL.NE.NCOMA.AND.NPRVDL.NE.NEQ.AND. 55580014 C 55650014 * NPRVDL.NE.NPER) GO TO 7 55720014 IF(IOSWG.EQ.1.AND.NSUB.EQ.0)GO TO 164 55750018 C 55790014 C IF IT IS A MINUS, SET INDICATOR. 55860014 C 55930014 IF(NDELM .EQ. NMIN) NXSMNG = 1 56000014 C 56070014 C TREAT AS UNARY 56140014 C 56210014 GO TO 1045 56280014 C 56350014 7 MSGNO = 7 56420014 C 56490014 GO TO 1300 56560014 C 56630014 C DELIMITER IS AN ASTERISK AND PREVIOUS56700014 C ELEMENT IS A VARIABLE OR CONSTANT. 56770014 C SET INDICATOR. 56840014 C 56910014 70000 IASTR = 1 56980014 C 57050014 GO TO 1602 57120014 C 57190014 C DELIMITER IS AN ASTERISK AND PREVIOUS57260014 C ELEMENT IS A DELIMITER. 57330014 C IF THE PREVIOUS DELIMITER IS NOT A 57400014 C RIGHT PAREN, BRANCH. 57470014 C 57540014 70005 IF(NPRVDL .NE. NRTPR) GO TO 70010 57610014 C 57680014 IASTR = 1 57750014 C 57820014 GO TO 1600 57890014 C 57960014 C IF THE PREVIOUS ELEMENT WAS NOT AN 58030014 C ASTERISK, SET THE ERROR. 58100014 C 58170014 70010 IF(IASTR .NE. 1) GO TO 7 58240014 C 58310014 C EXPONENTIATION. 58380014 C RESET INDICATOR. 58450014 C 58520014 IASTR = 0 58590014 C 58660014 C RESET ADJECTIVE CODE TO 58730014 C EXPONENTIATION. 58800014 C 58870014 ADJCD (NPUT) = 14 58940014 C 59010014 C SET CALL INDICATOR. 59080014 C 59150014 NPTR (1,23) = 1 59220014 C 59290014 GO TO 1055 59360014 C 59430014 C DELIMITER IS A SLASH AND PREVIOUS 59500014 C ELEMENT IS A DELIMITER. 59570014 C IF IT IS A RIGHT PAREN, BRANCH. 59640014 C 59710014 C 59780014 80000 IF(NPRVDL .EQ. NRTPR) GO TO 1600 59850014 C 59920014 GO TO 7 59990014 C 60060014 C DELIMITER IS A LEFT PAREN AND THE 60130014 C PREVIOUS ELEMENT IS A DELIMITER. 60200014 C IF AN I/O LIST IS NOT BEING 60270014 C PROCESSED, BRANCH. 60340014 C 60410014 90002 IF(IOSWG .EQ. 0 .OR. NPRCNT .NE. 0) GO TO 90005 60480014 C 60550014 C IMPLIED DO. 60620014 C INSURE PREVIOUS DELIMITER IS A COMMA 60690014 C OR RIGHT PAREN. 60760014 C 60830014 IF(NPRVDL .NE. NCOMA .AND. NPRVDL .NE. NRTPR) GO TO 7 60900014 C 60970014 CALL IEKCDO 61040014 GO TO 1045 61110014 C 61180014 C IF PREVIOUS DELIMITER IS A RIGHT 61250014 C PAREN, SET ERROR. 61320014 C 61390014 90005 IF(NPRVDL .EQ. NRTPR) GO TO 7 61460014 C 61530014 C RESET PAREN COUNT. 61600014 C 61670014 NPRCNT = NPRCNT + 1 61740014 C 61750019 C IF IN I/O SUBSCRIPT INCREMENT 61760019 C SUBSCRIPT LEVEL 61770019 C 61780019 IF(NSUB.GT.0) NSUB=NSUB+1 61790019 C 61810014 C IF FUNCTION ARGUMENTS ARE BEING 61880014 C PROCESSED, RESET COUNT. 61950014 C 62020014 IF(NDVSV .GT. 0) NDVSV = NDVSV + 1 62090014 C 62100021 C INCREMENT ASF PAREN CT IF ASF SWITCH IS ON 62110021 C 62120021 IF(NASFSW .EQ. 1) NASFCT=NASFCT+1 62130021 C 62160014 C IF AN I/O LIST IS BEING PROCESSED, 62230014 C AND THE SUBSCRIPT CONTAINS NO 62300019 C FUNCTION REFERENCES,BRANCH 62370019 IF( IOSWG.NE.0 .AND. NDVSV.EQ.0 ) GOTO 90010 62440019 C 62510014 C FOLLOWING CHECKS FOR A COMPLEX 62580014 C CONSTANT. 62650014 C SAVE POINTERS. 62720014 C 62790014 ISVSCN = NSCNPT 62860014 C 62930014 ISVBEG = NBEGPT 63000014 C 63070014 C CALL GETWD 63140014 CALL IEKCGW 63210014 IF(NDELM.EQ.NCOMA) GO TO 10402 63240016 IF%NDELM.EQ.NPER< GOTO 10352 63280014 IF%NDELM.NE.NPLUS.AND.NDELM.NE.NMIN< GOTO 10552 63350014 CALL IEKCGW 63420014 IF(NDELM.EQ.NCOMA) GO TO 10402 63440016 IF(NDELM.EQ.NPER) GO TO 10352 63460016 IF (NDELM.EQ. NPLUS.OR.NDELM.EQ.NMIN) GO TO 10503 63480016 GO TO 10552 63500016 10352 CALL IEKCGW 63560014 IF%NDELM.EQ.NCOMA< GOTO 10402 63630014 IF%NDELM.NE.NPLUS.AND.NDELM.NE.NMIN< GOTO 10552 63700014 10503 CALL IEKCGW 63770016 IF%NDELM.NE.NCOMA< GOTO 10552 63840014 10402 CALL IEKCGW 63910014 IF (NDELM.EQ.NRTPR) GO TO 10502 63940016 IF%NDELM.EQ.NPER< GOTO 10452 63980014 IF%NDELM.NE.NPLUS.AND.NDELM.NE.NMIN< GOTO 10552 64050014 CALL IEKCGW 64120014 IF (NDELM.EQ. NRTPR) GO TO 10502 64140016 IF (NDELM.EQ.NPER) GO TO 10452 64160016 IF(NDELM.EQ.NPLUS.OR.NDELM.EQ.NMIN) GO TO 10504 64180016 GO TO 10552 64200016 10452 CALL IEKCGW 64260014 IF%NDELM.EQ.NRTPR< GOTO 10502 64330014 IF%NDELM.NE.NPLUS.AND.NDELM.NE.NMIN< GOTO 10552 64400014 10504 CALL IEKCGW 64470016 IF%NDELM.NE.NRTPR< GOTO 10552 64540014 10502 NCPX#1 64610014 10552 NSCNPT = ISVSCN 64680014 C 64750014 NBEGPT = ISVBEG 64820014 C 64890014 NDELM = NLFPR 64960014 INEWDL = 9 65030014 C 65100014 LENGTH = 0 65170014 IF(NCPX .EQ. 0) GO TO 90010 65240014 C 65310014 CALL IEKCGW 65380014 C CALL CSORN 65450014 CALL IEKCCR 65520014 NPRCNT#NPRCNT-1 65590014 TMOD (NPUT) = MDD (IDCTPT) 65660014 TTYP (NPUT) = TYP (IDCTPT) 65730014 IF(NXSMNG.EQ.1)TTYP(NPUT)=TYP(IDCTPT)+8 65760017 TPTR (NPUT) = IDCTPT 65800014 C 65810019 C IF FUNCTION ARGUMENTS ARE BEING PROCESSED, 65820019 C RESET COUNT. 65830019 C 65840019 IF(NDVSV.GT.0) NDVSV=NDVSV-1 65850019 C 65853021 C DECREMENT ASF PAREN CT AND IF 0,SET ASF SWTCH OFF 65856021 C 65859021 IF(NASFSW .EQ. 1)NASFCT=NASFCT-1 65862021 IF(NASFCT .EQ. 0) NASFSW=0 65865021 C 65870014 GO TO 1045 65940014 C 66010014 C IF A UNARY MINUS DID NOT PRECEED THE 66080014 C LEFT PAREN, BRANCH. 66150014 C 66220014 90010 IF(NXSMNG .EQ. 0) GO TO 1600 66290014 C 66360014 NXSMNG = 0 66430014 C 66500014 MTPSET = 1 66570014 C 66640014 CALL IEKCPX 66710014 C 66780014 C SET MINUS OPERATOR. 66850014 C 66920014 ADJCD (NPUT) = 11 66990014 C 67060014 MTPSET = 1 67130014 C 67200014 CALL IEKCPX 67270014 C 67340014 ADJCD (NPUT) = 25 67410014 C 67480014 GO TO 1045 67550014 C 67620014 C DELIMITER IS AN END MARK. 67690014 C IF AN I/O LIST IS NOT BEING 67760014 C PROCESSED, BRANCH. 67830014 C 67900014 22000 IF(IOSWG .EQ. 0) GO TO 22010 67970014 C 68040014 C CLOSING TEXT FOR I/O LIST 68110014 C INSURE NO HANGING COMMA 68180014 C 68250014 IF(NCDIN (NSCNPT - 2) .EQ. NCOMA) GO TO 13 68320014 C 68390014 C IF THE LAST LIST ITEM WAS A 68460014 C SUBSCRIPTED VARIABLE OR AN IMPLIED - 68530014 C DO, SET SWITCH PREVENTING SETTING OF 68600014 C TMOD, TTYP, AND TPTR. 68670014 C 68740014 IF(ADJCD (NPUT) .NE. 247) MTPSET = 1 68810014 C 68880014 CALL IEKCPX 68950014 C 69020014 C DELIMIT LIST ITEM. 69090014 C 69160014 ADJCD (NPUT) = 26 69230014 C 69300014 MTPSET = 1 69370014 C 69440014 CALL IEKCPX 69510014 C 69580014 C SET END I/O LIST CODE. 69650014 C 69720014 ADJCD (NPUT) = 210 69790014 C 69860014 MTPSET = 1 69930014 C 70000014 CALL IEKCPX 70070014 C 70140014 IOSWG = 0 70210014 GO TO 22025 70280014 C 70350014 C CLEAR INDICATORS. 70420014 C 70490014 22005 NPRCNT = 0 70560014 NCALLG = 0 70630014 NDVSV = 0 70700014 IDOLEV=1 70730018 IF(NCARD(4).NE.31.AND.NPTR(1,2).NE.31.OR.NCARD(4).NE.32) NIF = 0 70770014 C ACCESS NEXT CARD. 70840014 1010 NERSW = 4 70910014 90000 CALL IEKCDP 70980014 C 71050014 C NON-I/O LIST. 71120014 C IF THE END MARK IS NOT PRECEEDED BY A71190014 C DELIMITER, BRANCH. 71260014 C 71330014 22010 IF(LENGTH .NE. 0) GO TO 22015 71400014 C 71470014 C INSURE VALID DELIMITER PRECEEDS. 71540014 C 71610014 IF(NPRVDL .NE. NRTPR .AND. NPRVDL .NE. NPER) GO TO 13 71680014 C 71750014 MTPSET = 1 71820014 C 71890014 22015 CALL IEKCPX 71960014 C 72030014 C IF THE STATEMENT IS NOT A CALL 72100014 C STATEMENT WITH &-LABEL ARGUMENTS, 72170014 C BRANCH. 72240014 C 72310014 IF(IMPDOD (1,9) .EQ. 0) GO TO 22020 72380014 C 72450014 NCOMEX # IMPDOD %1,9< 72520014 IMPDOD%1,9<#0 72590014 IF (ADJCD(LPUT) .EQ. 26) GO TO 22016 72620015 ADJCD (NPUT) = 26 72660014 MTPSET = 1 72730014 C CALL PUTX 72800014 CALL IEKCPX 72870014 22016 ADJCD (NPUT)=250 72940015 MTPSET = 1 73010014 C CALL PUTX 73080014 CALL IEKCPX 73150014 ADJCD (NPUT) = 0 73220014 MTPSET = 1 73290014 C CALL PUTX 73360014 CALL IEKCPX 73430014 ADJCD (NPUT) = 0 73500014 TPTR (NPUT) = NCOMEX 73570014 MTPSET = 1 73640014 C CALL PUTX 73710014 CALL IEKCPX 73780014 ADJCD (NPUT) = 65 73850014 TMOD (NPUT) = 255 73920014 C NTST2 IS LABLE COUNT CELL 73990014 TPTR (NPUT) = NTST2 * 4 74060014 NPTR (2,18) = NPTR (2,18) + TPTR (NPUT) + 4 74130014 MTPSET = 1 74200014 C CALL PUTX 74270014 CALL IEKCPX 74340014 NTST2#0 74410014 LBSWG#1 74480014 C CALL LABTLU 74550014 CALL IEKCLT 74620014 BYB %ILABPT< # BITON %BYB %ILABPT<,7< 74690014 NCLSTX = 1 74760014 C CALL PUTX 74830014 CALL IEKCPX 74900014 ADJCD (NPUT) = 223 74970014 PTRSN %NCOMEX< # ILABPT 75040014 C TO INSURE LABEL PLUGGING 75110014 NCARD%4< # 27 75180014 C 75250014 GO TO 22005 75320014 C 75390014 C IF A STATEMENT FUNCTION DEFINITION IS75460014 C NOT BEING PROCESSED, BRANCH. 75530014 C 75600014 22020 IF(ISAVE2 .EQ. 0) GO TO 22025 75670014 C 75740014 ISAVE2#0 75810014 C FOLLOWING SETS THE ADJECTIVE 75880014 C CODE FOR A RIGHT PAREN INTO THE 75950014 C TEXT WORK AREA 76020014 ADJCD (NPUT) = 5 76090014 MTPSET = 1 76160014 C FOLLOWING CALL TO PUTX HAS A 76230014 C TEXT ENTRY FOR THE ABOVE 76300014 C GENERATED. 76370014 C CALL PUTX 76440014 CALL IEKCPX 76510014 C FOLLOWING DO-LOOP INSURES THAT 76580014 C ALL FUNCTION ARGUMENTS ARE USED 76650014 C IN THE EXPRESSION. 76720014 C THE FIRST FIELD OF THE ASF TABLE76790014 C FOR EACH ENTRY IS CHECKED. AS 76860014 C EACH ARGUMENT IN THE EXPRESSION 76930014 C WAS ACCESSED BY SUBROUTINE 77000014 C XARITH, THE FIRST FIELD OF THAT 77070014 C ARGUMENT5S ASF TABLE ENTRY WAS 77140014 C SET TO ONE. THEREFORE A ZERO IN 77210014 C THIS FIELD FOR ANY ENTRY 77280014 C INDICATES THAT THE ARGUMENT WAS 77350014 C NOT USED, AND A BRANCH OCCURS TO77420014 C RECORD THE ERROR. NSSEQ, WHICH 77490014 C CONTAINS THE NUMBER OF ARGUMENTS77560014 C SPECIFIED IN THE ARGUMENT LIST 77630014 C TO THE LEFT OF THE EQUAL SIGN, 77700014 C GOVERNS THE NUMBER OF ENTRIES 77770014 C IN THE TABLE TO BE CHECKED. 77840014 DO 20059 I = 1,NSSEQ 77910014 IF (.NOT.TBIT(IASFTB(1,I),0)) GO TO 229 77980017 20059 CONTINUE 78050014 C FOLLOWING SETS THE ADJECTIVE 78120014 C CODE FOR THE END MARK INTO THE 78190014 C TEXT WORK AREA. 78260014 20062 ADJCD (NPUT) = 26 78330014 C FOLLOWING CALL TO PUTX HAS A 78400014 C TEXT ENTRY FOR THE ABOVE 78470014 C GENERATED. 78540014 MTPSET = 1 78610014 C CALL PUTX 78680014 CALL IEKCPX 78750014 C FOLLOWING CLEARS THE ASF TABLE, 78820014 C SETTING IT TO ZERO. 78890014 DO 20209 I = 1,20 78960014 DO 20209 J = 1,3 79030014 20209 IASFTB (J,I) = 0 79100014 C FOLLOWING CALL TO CLOSE HAS THE 79170014 C TEXT ENTRY THAT SIGNIFIES THE 79240014 C END OF INTERMEDIATE TEXT 79310014 C GENERATED. 79380014 C CALL CLOSE 79450014 NCLSTX = 1 79520014 C CALL PUTX 79590014 CALL IEKCPX 79660014 NPUT = NPUTSV 79730014 C 79800014 GO TO 22005 79870014 229 MSGNO = 229 79940014 NERSW = 6 80010014 CALL IEKCDP 80080014 GO TO 20062 80150014 C 80220014 C CLOSE NORMAL TEXT. 80290014 C 80360014 22025 NCLSTX = 1 80430014 C 80500014 CALL IEKCPX 80570014 C 80640014 GO TO 22005 80710014 C 80780014 C DELIMITER IS AN APOSTROPHE AND THE 80850014 C PREVIOUS ELEMENT IS A DELIMITER. 80920014 C OR HOLLERITH FIELD TO BE PROCESSED. 80990014 C IF THE LITERAL IS BEING USED IN A 81060014 C CALL, BRANCH. 81130014 C 81200014 12000 IF (NCALLG+NDVSV .NE. 0) GO TO 12005 81270015 C 81340014 200 MSGNO = 200 81410014 C 81480014 GO TO 1300 81550014 C 81620014 C IF THE PREVIOUS DELIMITER IS NOT A 81690014 C LEFT PAREN AND IS NOT A COMMA, SET 81760014 C THE ERROR. 81830014 C 81900014 12005 IF(NPRVDL .NE. NCOMA .AND. NPRVDL .NE. NLFPR) GO TO 13 81970014 C 81978021 C IF THIS IS A LITERAL AS AN ARG TO AN ASF,BRANCH 81986021 C TO SET ERROR.(NASFCT SET TO 1 INDICATES WE ARE ONLY IN 1 81994021 C LEVEL OF ASF PARENS. ASF'S NESTED WITHIN ASF'S WILL 82002021 C NOT HAVE THEIR LITERAL ARGS DIAGNOSED.) 82010021 C 82018021 IF(NASFSW .EQ. 1 .AND. NASFCT .EQ. 1) GO TO 200 82026021 IF ((NPTR(2,29)+4).GT.NPTR(2,30)) CALL IEKAGC(2) 82040014 C 82110014 C OBTAIN NEXT DICTIONARY LOCATION. 82180014 C 82250014 10481 K = NPTR(2,29) 82320014 I = K 82390014 NPTR(2,29) = NPTR(2,29)+4 82460014 C INSURE N POINTS TO FIRST CHARACTER. 82530014 C 82600014 N = NBEGPT 82670014 C 82740014 IF(NHRETN .EQ. 0) N = N + 1 82810014 C 82880014 C INITIALIZE CHARACTER COUNT. 82950014 C 83020014 LITCNT = 0 83090014 C 83160014 10501 NPTR(2,29) = NPTR(2,29) + 4 83230014 IF (NPTR(2,29).LE.NPTR(2,30)) GO TO 10531 83300014 CALL IEKAGC(2) 83370014 GO TO 10481 83440014 10531 L = 1 83510014 C 83580014 C IF A HOLLERITH FIELD IS NOT BEING 83650014 C PROCESSED, BRANCH. 83720014 C 83790014 10551 IF(NHRETN .EQ. 0) GO TO 10701 83860014 C 83930014 C IF ALL CHARACTERS HAVE BEEN ENTERED, 84000014 C BRANCH. 84070014 C 84140014 IF(LITCNT .EQ. NACCM) GO TO 10751 84210014 C 84280014 C ENTER CHARACTER. 84350014 C 84420014 10601 ADC (I) = LOR (ADC (I), NCDIN (N) * 2 ** (32 - 8 * L)) 84490014 C 84560014 C INCREMENT CHARACTER COUNT. 84630014 C 84700014 LITCNT = LITCNT + 1 84770014 C 84840014 C INSURE COUNT IS NOT GREATER THAN 266.84910014 C 84980014 IF(LITCNT .LE. 255) GO TO 10651 85050014 C 85120014 MSGNO = 47 85190014 C 85260014 GO TO 1300 85330014 C 85400014 C ACCESS NEXT CHARACTER. 85470014 C 85540014 10651 N = N + 1 85610014 C 85680014 C POINT TO NEXT BYTE. 85750014 C 85820014 L = L + 1 85890014 C 85960014 C IF A WORD HAS NOT BEEN FILLED, BRANCH86030014 C 86100014 IF(L .LE. 4) GO TO 10551 86170014 C 86240014 I = I + 4 86310014 C 86380014 GO TO 10501 86450014 C 86520014 C APOSTROPHE LITERAL. 86590014 C IF THE CHARACTER TO BE ENTERED IS 86660014 C NOT AN APOSTROPHE, BRANCH. 86730014 C 86800014 10701 IF(NCDIN (N) .NE. NQUOT) GO TO 10601 86870014 C 86940014 C IF THE NEXT CHARACTER IS AN 87010014 C APOSTROPHE, INDICATING THE CHARACTER 87080014 C IS TO BE ENTERED, BRANCH. 87150014 C 87220014 N = N + 1 87290014 C 87360014 IF(NCDIN (N) .EQ. NQUOT) GO TO 10601 87430014 C 87500014 C END OF LITERAL. 87570014 10751 IF (L.EQ.1) GO TO 10801 87640014 NPTR(2,29) = NPTR(2,29)+4 87710014 IF (NPTR(2,29).GT.NPTR(2,30)) CALL IEKAGC(2) 87780014 C 87850014 C IF A PREVIOUS LITERAL CONSTANT HAS 87920014 C NOT BEEN ENTERED, BRANCH. 87990014 C 88060014 10801 IF (NPTR(1,27).EQ.0) GO TO 10451 88130014 C 88200014 C CHAIN MOST RECENT ENTRY TO NEW. 88270014 C 88340014 CHN(K) = NPTR(1,27) 88410014 C 88480014 C SET NEW ENTRY AS MOST RECENT. 88550014 C 88620014 10451 NPTR(1,27) = K 88690014 C 88760014 C SET MODE, TYPE, AND POINTER. 88830014 C 88900014 C 88970014 TMOD (NPUT) = 10 89040014 C 89110014 TTYP (NPUT) = 5 89180014 C 89250014 TPTR(NPUT) = K 89320014 C 89390014 C SET LENGTH. 89460014 C 89530014 BYA(K) = LITCNT 89600014 C 89670014 C SET LITERAL INDICATOR FOR 89740014 C LATER PHASE USAGE. 89810014 C 89880014 BYB (K) = 255 89950014 C 90020014 NHRETN = 0 90090014 C 90160014 C POINT TO AND ACCESS ELEMENT 90230014 C FOLLOWING THE LITERAL. 90300014 C 90370014 NSCNPT = N 90440014 C 90510014 CALL IEKCGW 90580014 C 90650014 C INSURE ELEMENT IS A DELIMITER. 90720014 C 90790014 IF(LENGTH .NE. 0) GO TO 13 90860014 C 90930014 C IF THE LITERAL IS NOT DELIMITED BY A 91000014 C COMMA OR RIGHT PAREN, SET THE ERROR. 91070014 C IF A RIGHT PAREN, ADJUST COUNT. 91140014 C 91210014 IF(NDELM .EQ. NCOMA) GO TO 1600 91280014 C 91350014 IF(NDELM .NE. NRTPR) GO TO 7 91420014 C 91490014 NPRCNT = NPRCNT - 1 91560014 C 91570019 C IF FUNCTION ARGUMENTS ARE BEING PROCESSED, 91580019 C RESET COUNT. 91590019 C 91600019 IF(NDVSV.GT.0) NDVSV=NDVSV-1 91610019 C 91613021 C DECREMENT ASF PAREN CT AND IF 0,SET ASF SWTCH OFF 91616021 C 91619021 IF(NASFSW .EQ. 1)NASFCT=NASFCT-1 91622021 IF(NASFCT .EQ. 0) NASFSW=0 91625021 C 91630014 GO TO 1600 91700014 END 91770014 ./ ADD SSI=01000042,NAME=IEKCCR,SOURCE=0 IEKCCR START 0 00060019 * 176000-181000 000A 00130015 * 183000,249000,251200,256000 000A 00160015 *0180740000-742000 000A 00180016 *1311319500 18051 00190017 * 000600,002000,072000 000E 00195019 * 188000,190000,209500 26133 00245019 * 234800-238600 20.1 34243 00255020 * 282100-283300,284200-288800,885300-885600, 20.1 36020 00265020 * 903300-903600,916000-917000,925300-925600 20.1 36020 00275020 * 824500-824600 LL40177 00280021 * 011200-011600,234830-237770,932500 LL48985 00292021 * A739300-739600 LL55184 00296021 ENTRY IEKCS3 COMSYM 00300014 ENTRY IEKCS1 COMPAT 00400014 ENTRY IEKCLC LITCON 00500014 ENTRY IEKCS2 SYMTLU 00600014 EXTRN IEKAAA 00700014 EXTRN IEKCAA 00800014 EXTRN IEKAAD 00900014 EXTRN IEKXRS 01000014 * 01100014 ONN EQU 1 01120021 LINK2 EQU 8 01140021 HOLD EQU 9 01160021 WORK EQU 0 01200014 RSIZE EQU 1 01300014 SOURCE EQU 2 01400014 TARGET EQU 3 01500014 J EQU 1 01600014 MIDPT EQU 2 01700014 CHAIN EQU 3 01800014 NEXT EQU 4 01900014 LAST EQU 5 02000014 RBEGPT EQU 3 02100014 DIGCTR EQU 4 02200014 DECCTR EQU 5 02300014 EXPCTR EQU 6 02400014 NAME1 EQU 6 02500014 NAME2 EQU 7 02600014 NAME3 EQU 8 02700014 NAME4 EQU 9 02800014 CALL EQU 10 02900014 INFO EQU 11 03000014 PH10R EQU 12 03100014 SCALE EQU 4 03200014 FLOAT EQU 6 03300014 * 03400014 EQUAL EQU 8 03500014 NOTEQ EQU 7 03600014 HIGH EQU 2 03700014 LOW EQU 4 03800014 HIEQ EQU 10 03900014 LOEQ EQU 12 04000014 ZERO EQU 8 04100014 NZERO EQU 7 04200014 PLUS EQU 2 04300014 MINUS EQU 4 04400014 ZPLUS EQU 10 04500014 ZMINUS EQU 12 04600014 UNDER EQU 12 04700014 OVER EQU 1 04800014 ALL EQU 1 04900014 NONE EQU 8 05000014 ALWAYS EQU 15 05100014 RISN EQU 5 05200014 XREF EQU 6 05300014 XREF1 EQU 7 05400014 XREF2 EQU 10 05500014 LINK EQU 14 05600014 NOTZERO EQU 7 05800014 * 05900014 ON EQU X'FF' 06000014 OFF EQU X'00' 06100014 LLOGSW EQU X'80' 06200014 TOBIG EQU X'40' 06300014 NNEG EQU X'20' 06400014 NDEC EQU X'10' 06500014 NESWG EQU X'08' 06600014 NDSWG EQU X'04' 06700014 NPERSG EQU X'02' 06800014 NPERFF EQU X'FD' 06900014 EJECT 07000014 USING *,15 07100014 BC ALWAYS,*+12 07200019 DC X'0700' 07300014 DC C'IEKCCR' 07400014 STM 14,12,12(13) SAVE REGISTERS 07500014 L PH10R,VPH10 07600014 USING PH10,PH10R 07700014 MVI NTYPE,0 CLEAR TYPE SWITCH 07800014 CLI NACCSV+3,2 07900014 BC EQUAL,SYMCAL BRANCH IF VARIABLE 08000014 LA SOURCE,NCDIN-1 08100014 A SOURCE,NBEGPT 08200014 CLI 0(SOURCE),X'50' 08300014 BC NOTEQ,LITCAL BRANCH IF NO AMPERSAND 08400014 MVI NDOLRT+3,1 08500014 MVI NCPX+3,0 08600014 MVI NERSW+3,9 08700014 L 15,VCLASS 08800014 BALR 14,15 CALL XCLASS FOR &LABEL 08900014 * 09000014 SYMCAL MVI NCPX+3,0 09100014 MVI SWITCH,ON SET SWITCH FOR COMPAT + SYMTLU 09200014 LA 15,IEKCS1 09300014 BC ALWAYS,20(0,15) 09400014 * 09500014 LITCAL MVI SWITCH,ON SET SWITCH FOR LITCON + CSORN 09600014 LA 15,IEKCLC 09700014 BC ALWAYS,20(0,15) 09800014 SPACE 5 09900014 USING *,15 SUBROUTINE COMSYM 10000014 IEKCS3 BC ALWAYS,*+12 10100014 DC X'0700' 10200014 DC C'IEKCS3' 10300014 MVI SWITCH,ON SET SWITCH FOR COMPAT + SYMTLU 10400014 LA 15,IEKCS1 ALTER BASE 10500014 * 10600014 USING *,15 SUBROUTINE COMPAT 10700014 IEKCS1 BC ALWAYS,*+12 10800014 DC X'0700' 10900014 DC C'IEKCS1' 11000014 STM 14,12,12(13) SAVE REGISTERS 11100014 L PH10R,VPH10 11200014 USING PH10,PH10R 11300014 * 11400014 ST 13,SAVE+4 11500014 MVC 8(4,13),SAVADD 11600014 LA 13,SAVE POINT TO SAVE AREA 11700014 XC NAME(16),NAME CLEAR NAME 11800014 CLI LENGTH+3,6 ERROR IF NAME EXCEEDS 11900014 BC HIGH,ERRMSG SIX CHARACTERS. 12000014 L RSIZE,LENGTH PICKUP SYMBOL LENGTH 12100014 SETNAM LA SOURCE,NCDIN-1 12200014 A SOURCE,NBEGPT GET NCDIN STARTING POINT 12300014 LA TARGET,NAME+16 12400014 SR TARGET,RSIZE ADJUST ADDRESS IN NAME 12500014 BCTR RSIZE,0 12600014 EX RSIZE,MOVNAM EXECUTE MOVE TO NAME 12700014 TM SWITCH,ON 12800014 BC NONE,RETURN EXIT IF COMPAT ONLY 12900014 MVI SWITCH,OFF RESET SWITCH 13000014 LA 15,IEKCS2 INITIALIZE BASE 13100014 BC ALWAYS,34(0,15) 13200014 * 13300014 ERRMSG MVI MSGNO+3,226 ERROR,NAME TOO LONG. 13400014 MVI NERSW+3,6 13500014 LR CALL,15 SAVE BASE 13600014 L 15,VERROR 13700014 BALR 14,15 13800014 LR 15,CALL RESTORE BASE 13900014 LA RSIZE,6 14000014 ST RSIZE,LENGTH SET LENGTH TO SIX 14100014 BC ALWAYS,SETNAM 14200014 EJECT 14300014 USING *,15 SUBROUTINE LITCON 14400014 IEKCLC BC ALWAYS,*+12 14500014 DC X'0700' 14600014 DC C'IEKCLC' 14700014 STM 14,12,12(13) SAVE REGISTERS 14800014 L PH10R,VPH10 14900014 ST 13,SAVE+4 15000014 MVC 8(4,13),SAVADD 15100014 LA 13,SAVE POINT TO SAVE AREA 15200014 * 15300014 XC NAME(16),NAME CLEAR NAME 15400014 MVI SCANSW,0 AND SWITCHES. 15500014 MVI NNT+3,0 15600014 MVI NCPLX+3,0 15700014 SR DIGCTR,DIGCTR CLEAR COUNTS 15800014 SR DECCTR,DECCTR AND REGISTERS. 15900014 SR NAME3,NAME3 16000014 SR NAME4,NAME4 16100014 STM NAME3,NAME4,NDBLE 16200014 L RBEGPT,NBEGPT SAVE BEGIN POINTER 16300014 LA SOURCE,NCDIN-1(RBEGPT) 16400014 LA EXPCTR,4 16500014 CLI NCPX+3,0 TEST FOR COMPLEX 16600014 BC EQUAL,CNTSCN 16700014 * 16800014 CLI 0(SOURCE),C'+' 16900014 BC EQUAL,BUMPC BRANCH IF PLUS 17000014 CLI 0(SOURCE),C'-' 17100014 BC NOTEQ,CNTSCN 17200014 OI SCANSW,NNEG SET SIGN SWITCH NEGATIVE 17300014 BUMPC LA SOURCE,1(0,SOURCE) 17400014 LA RBEGPT,1(0,RBEGPT) 17500014 CNTSCN CLI 0(SOURCE),C'9' CHECK FOR DIGIT 000A 17570015 BC HIGH,DELMCK 000A 17640015 CLI 0(SOURCE),C'0' 000A 17710015 BC LOW,DELMCK 000A 17780015 * CHANGE CONDITION TO NOTEQ TO COUNT SIGNIFICANT DIGITS ONLY 17820015 BC ALWAYS,SIGDIG 17860015 LTR DIGCTR,DIGCTR 000A 17920015 BC ZERO,TSTDEC IGNORE LEADING ZEROS 000A 17990015 SIGDIG LA DIGCTR,1(0,DIGCTR) BUMP DIGIT COUNTER 000A 18060015 CL NAME3,HIBYTE 18200014 BC HIEQ,SPILIT BRANCH IF OVERFLOW 000A 18300015 SLDL NAME3,2 N*4 18400014 AL NAME4,NDBLE+4 +N 18500014 BC UNDER,NOCARY 18600014 A NAME3,C1 ADD CARRY 18700014 BC OVER,SPILL 18800019 NOCARY A NAME3,NDBLE 18900014 BC OVER,SPILL 19000019 SLDL NAME3,1 *2 19100014 MVN DIGIT+3(1),0(SOURCE) 19200014 AL NAME4,DIGIT 19300014 BC UNDER,SETNUM 19400014 A NAME3,C1 ADD CARRY 19500014 SETNUM STM NAME3,NAME4,NDBLE 19600014 * 19700014 TSTDEC TM SCANSW,NPERSG 19800014 BC NONE,SCNRET NO DECIMAL POINT 19900014 A DECCTR,C1 BUMP DECIMAL COUNTER 20000014 SCNRET LA SOURCE,1(0,SOURCE) 20100014 LA RBEGPT,1(0,RBEGPT) 20200014 TM SCANSW,NESWG 20300014 BC ALL,TSTEXP EXPONENT ENCOUNTERED 20400014 TM SCANSW,NDSWG 20500014 BC NONE,CNTSCN NOT DOUBLE PRECISION 20600014 TSTEXP BCT EXPCTR,CNTSCN 20700014 BC ALWAYS,ERROR9 MORE THAN 4 CHARACTERS 20800014 * 20900014 SPILL LM NAME3,NAME4,NDBLE 20950019 SPILIT BCTR DECCTR,0 21000014 OI SCANSW,TOBIG SET OVERFLOW INDICATOR 21100014 BC ALWAYS,TSTDEC 21200014 * 21300014 DELMCK CLI NTYPEX+3,2 21400014 BC EQUAL,CNVRT 21500014 CLI 0(SOURCE),C'E' 21600014 BC EQUAL,SETDSG BRANCH ON CHAR E 21700014 CLI 0(SOURCE),C'D' 21800014 BC EQUAL,SETDSG BRANCH ON CHAR D 21900014 CLI 0(SOURCE),C'.' 22000014 BC EQUAL,SETPSG BRANCH ON PERIOD 22100014 CLI 0(SOURCE),C'H' 22200014 BC EQUAL,SETHSG BRANCH ON CHAR H 22300014 CLI 0(SOURCE),X'50' 22400014 BC EQUAL,SETRSG BRANCH ON AMPERSAND 22500014 * 22600014 CNVRT TM SCANSW,NESWG 22700014 BC ALL,SNGLX ASSUME SINGLE PRECISION 22800014 TM SCANSW,NDSWG 22900014 BC ALL,DBLEX ASSUME DOUBLE PRECISION 23000014 TM SCANSW,NPERSG 23100014 BC NONE,INTG NO DECIMAL, ASSUME INTEGER. 23200014 STM NAME3,NAME4,DATUM 23300014 SR NAME4,NAME4 23400014 EJECT 34243 23480020 * 23483021 * BY ZAPPING CERTAIN SPECIFIED BRANCHES IN THIS SECTION 23486021 * OF CODE DETERMINING THE PRECISION OF CONSTANTS WITHOUT 23489021 * EXPONENTS , THE USER CAN CHOOSE ANY ONE OF 6 METHODS 23492021 * OF FUNCTIONING.EACH IS EXPLAINED BELOW WITH THE ZAPS 23495021 * NECESSARY TO OBTAIN IT.EACH ZAP MUST CHANGE THE 23498021 * BC 15 INSTRUCTION TO A BC 0. METHOD 1 IS THE DEFAULT. 23501021 * 23504021 * METHOD 1 : NEW METHOD. (ALL CONSTANTS WITHOUT A D OR E 23507021 * EXPONENT,REGARDLESS OF NUMBER OF DIGITS, WILL 23510021 * BE CONVERTED TO SINGLE PRECISION) 23513021 * ZAPS : NO ZAPS NECESSARY.DEFAULT. 23516021 * 23519021 * METHOD 2 : OLD METHOD.(PRECISION OF NUMBER DETERMINED 23522021 * BY NUMBER OF DIGITS IT CONTAINS.) 23525021 * 23528021 * ZAPS : ZAP BC INSTRUCTIONS AT THESE LABELS: ZAPLAB1, 23531021 * ZAPLAB2,ZAPLAB3 23534021 * 23537021 * METHOD 3 : NEW METHOD WITH MESSAGES(THE NEW METHOD IS 23540021 * USED AND THE COMPILER WILL ISSUE A WARNING 23543021 * MESSAGE FOR EVERY CONSTANT WITH GREATER THAN 23546021 * 7 DIGITS THAT IT TRUNCATES TO R*4 PRECISION) 23549021 * ZAPS : ZAP BC INSTRUCTIONS AT THESE LABELS: ZAPLAB1 23552021 * 23555021 * METHOD 4 : NEW METHOD WITH ONLY 1 WARNING MESSAGE.(SAME 23558021 * AS METHOD 3 EXCEPT ONLY 1 MESSAGE IS ISSUED 23561021 * FOR THE FIRST CONSTANT TRUNCATED) 23564021 * 23567021 * ZAPS : ZAP BC INSTRUCTIONS AT THESE LABELS: ZAPLAB1, 23570021 * ZAPLAB4 23573021 * 23576021 * METHOD 5 : OLD METHOD WITH MESSAGES.(THE OLD METHOD IS 23579021 * USED AND THE COMPILER WILL ISSUE A WARNING 23582021 * MESSAGE FOR EVERY DOUBLE PRECISION CONSTANT 23585021 * THAT IT HAS NOT TRUNCATED TO SINGLE PRECISION) 23588021 * 23591021 * ZAPS: ZAP BC INSTRUCTIONS AT THESE LABELS: ZAPLAB1, 23594021 * ZAPLAB2 23597021 * 23600021 * METHOD6: OLD METHOD WITH 1 MESSAGE.(SAME AS METHOD 5 23603021 * EXCEPT ONLY 1 MESSAGE IS ISSUED FOR THE FIRST 23606021 * DOUBLE PRECISION CONSTANT THAT IS NOT TRUNCATED) 23609021 * 23612021 * ZAPS: ZAP BC INSTRUCTIONS AT THESE LABELS: ZAPLAB1, 23615021 * ZAPLAB2,ZAPLAB4 23618021 * 23621021 ZAPLAB1 BC 15,SNGL ALWAYS SET TO SINGLE.THIS 23624021 * BRANCH IS ZAPPED IF A METHOD 23627021 * OTHER THAN 1 IS DESIRED. 23630021 CH DIGCTR,C7 BRANCH TO SET SINGLE FOR ALL 23633021 BC LOEQ,SNGL CONSTANTS <= 7 DIGITS 23636021 ZAPLAB2 BC 15,NEWMSG BRANCH TO DO METHODS 3 OR 4. 23639021 * THIS BRANCH IS ZAPPED IF ANY 23642021 * METHOD OTHER THAN 3 OR 4 OR 23645021 * 1 IS DESIRED 23648021 ZAPLAB3 BC 15,OLDMSG BRANCH TO DO METHODS 5 OR 6. 23651021 * THIS BRANCH IS ZAPPED ONLY IF 23654021 * METHOD 2 IS DESIRED. 23657021 B DBLE BRANCH TO DO METHOD2.SET ALL 23660021 * CONSTANTS > 7 DIGITS TO DOUBLE 23663021 * PRECISION. 23666021 * 23669021 * 23672021 * THIS SECTION OF CODE IS FOR 23675021 * THE OLD WAY WITH MESSAGES- 23678021 * METHODS 5 AND 6. 23681021 OLDMSG MVI MSGNO+3,214 SET WARNING MESSAGE NUMBER 23684021 BAL LINK2,MSG BRANCH TO PUT OUT MESSAGE 23687021 SR NAME3,NAME3 CLEAR REGISTER 23690021 B DBLE GO TO SET AS DOUBLE 23693021 * 23696021 * 23699021 * THIS SECTION OF CODE IS FOR 23702021 * THE NEW METHOD WITH MESSAGES- 23705021 * METHODS 3 AND 4. 23708021 NEWMSG MVI MSGNO+3,213 SET ERROR NUMBER 23711021 BAL LINK2,MSG BRANCH TO PUT OUT MESSAGE 23714021 SR NAME3,NAME3 CLEAR REGISTER 23717021 B SNGL BRANCH TO SET SINGLE 23720021 * THIS SECTION OF CODE PUTS 23723021 * OUT THE MESSAGE. 23726021 * 23729021 * 23732021 MSG EQU * 23735021 ZAPLAB4 BC 15,EVRYTIME BRANCH TO PUT OUT MESSAGE 23738021 * EVERY TIME.THIS BRANCH IS 23741021 * ZAPPED IF THE MESSAGE IS TO 23744021 * BE PUT OUT ONLY ONCE. 23747021 TM MSGSWTCH,X'80' IS SWITCH ON (MSG OUT ONCE) 23750021 BCR ONN,LINK2 IF YES , RETURN 23753021 OI MSGSWTCH,X'80' IF NO, TURN SWITCH ON 23756021 EVRYTIME MVI NERSW+3,6 PREPARE TO CALL CDP FOR MESSAGE 23759021 LR HOLD,15 23762021 L 15,VERROR 23765021 BALR 14,15 23768021 LR 15,HOLD 23771021 SR HOLD,HOLD CLEAR REGISTER 23774021 BR LINK2 RETURN 23777021 EJECT 34243 23860020 * 23900014 DBLE MVI NSHFT1+3,6 SET MODE TO REAL*8 24000014 EXPTST TM DATUM,X'FF' 24100014 BC NONE,EXP4E ROOM FOR CHARACTERISTIC 24200014 LM NAME1,NAME2,DATUM 24300014 SRDA NAME1,4 NO, SHIFT OUT ONE HEX DIGIT. 24400014 TM DATUM,X'F0' 24500014 BC NONE,EXP4F ENOUGH ROOM NOW 24600014 SRDA NAME1,4 NO, SHIFT OUT ONE MORE DIGIT. 24700014 STM NAME1,NAME2,DATUM 24800014 MVI DATUM,X'50' SET CHARACTERISTIC OF 16 000A 24900015 BC ALWAYS,EXPSCN 25000014 EXP4F STM NAME1,NAME2,DATUM 25060014 MVI DATUM,X'4F' SET CHARACTERISTIC OF 15 000A 25130015 BC ALWAYS,EXPSCN 25200014 * 25300014 SNGL MVI NSHFT1+3,7 SET MODE TO REAL*4 25400014 OI SCANSW,NESWG 25500014 BC ALWAYS,EXPTST 25550014 EXP4E MVI DATUM,X'4E' SET CHARACTERISTIC OF 14 000A 25620015 EXPSCN TM SCANSW,NDEC 25700014 BC NONE,NEGSCL 25800014 AR DECCTR,NAME4 DECIMALS PLUS EXPONENT 25900014 BC ALWAYS,SCALIT 26000014 NEGSCL SR DECCTR,NAME4 DECIMALS MINUS EXPONENT 26100014 LTR DECCTR,DECCTR 26200014 BC ZPLUS,DECSET 26300014 LPR DECCTR,DECCTR GET ABSOLUTE VALUE 26400014 BC ALWAYS,SCALIT 26500014 DECSET OI SCANSW,NDEC SET FOR NEGATIVE SCALING 26600014 SCALIT CH DECCTR,C74 26700014 BC HIGH,POLTST MAXIMUM EXP., CHECK POLARITY 26800014 GETSCL SR DIGCTR,DIGCTR 26900014 D DIGCTR,C10 SEPARATE TENS AND UNITS 27000014 SLDA DIGCTR,2 27100014 STD FLOAT,FPSAV1 27200014 STD SCALE,FPSAV2 27300014 LD FLOAT,DATUM GET DATUM 27400014 SDR SCALE,SCALE 27500014 LE SCALE,ETABHX(DIGCTR) PICKUP 10 ** UNITS 27600014 LTR DECCTR,DECCTR 27700014 BC ZERO,CHKEXP 27800014 SLA DECCTR,1 27900014 MD SCALE,ETABHT(DECCTR) MULTIPLY BY 10 ** TENS 28000014 CHKEXP TM SCANSW,NDEC 28100014 BC ALL,DIVIDE BRANCH IF DECIMAL 28200014 ST NAME2,SVNAM2 TEST FOR UNDERFLOW AND OVERFLOW 36020 28210020 L INFO,VBLANK 28220020 USING BLANK,INFO 28230020 L NAME2,NPTR+184 28240020 ST NAME2,SVNPTR 28250020 L NAME2,=F'0' 28260020 ST NAME2,NPTR+184 28270020 MDR FLOAT,SCALE 36020 28280020 CLI NPTR+184,X'0C' 28290020 BC EQUAL,MAX 28300020 CLI NPTR+184,X'0D' 28310020 BC EQUAL,MIN 28320020 CONT1 L NAME2,SVNPTR 28330020 ST NAME2,NPTR+184 28340020 DROP INFO 28350020 L NAME2,SVNAM2 28360020 BC ALWAYS,TSTNEG 28400014 POLTST TM SCANSW,NDEC CHECK SIGN OF EXPONENT GREAT THAN 75 28420020 BC ALL,SCLMAX BRANCH IF NEGATIVE 36020 28440020 LD FLOAT,MAXM SET RESULT=LARGEST POSSIBLE NO 36020 28460020 BC ALWAYS,TSTNEG 36020 28480020 SCLMAX TM SCANSW,NESWG 36020 28500020 BC NONE,DOUPRE 36020 28520020 CH DECCTR,C85 36020 28540020 BC HIEQ,MINI 28560020 DOUPRE SH DECCTR,C20 REDUCE EXPONENT BY 19 36020 28580020 CH DECCTR,C74 36020 28600020 BC LOW,NOSCAL TEST FOR NUMBER IN RANGE 36020 28620020 MINI SDR FLOAT,FLOAT SET RESULT TO ZERO FOR UNDERFLOW 36020 28640020 BC ALWAYS,TSTNEG 36020 28660020 MAX LD FLOAT,MAXM 28680020 BC ALWAYS,CONT1 28700020 MIN SDR FLOAT,FLOAT 28720020 BC ALWAYS,CONT1 28740020 NOSCAL LD FLOAT,DATUM 36020 28760020 TM SCANSW,NDEC 28900014 BC NONE,POSSCL 29000014 DD FLOAT,TEN20 SCALE LOWER 29100014 STASHD STD FLOAT,DATUM 29200014 BC ALWAYS,GETSCL 29300014 POSSCL MD FLOAT,TEN20 SCALE HIGHER 29400014 BC ALWAYS,STASHD 29500014 DIVIDE DDR FLOAT,SCALE SCALE DOWN 29600014 TSTNEG TM SCANSW,NNEG 29700014 BC NONE,NOTNEG BRANCH IF POSITIVE 29800014 LNDR FLOAT,FLOAT 29900014 NOTNEG STD FLOAT,NDBLE STORE SIGNED DATUM 30000014 CLI NSHFT1+3,6 30100014 BC EQUAL,SETNM3 BRANCH IF REAL*8 30200014 TM SCANSW,NDSWG 30300014 BC NONE,SETNM4 BRANCH IF SINGLE 30400014 SETNM3 STD FLOAT,NAME+8 30500014 GETREG LD FLOAT,FPSAV1 30600014 LD SCALE,FPSAV2 30700014 MVI LENGTH+3,14 30800014 BC ALWAYS,DELSET 30900014 SETNM4 STE FLOAT,NAME+12 31000014 BC ALWAYS,GETREG 31100014 * 31200014 SNGLX CH EXPCTR,C3 31300014 BC LOW,SNGL 31400014 BC ALWAYS,ERROR9 31500014 DBLEX CH EXPCTR,C3 31600014 BC LOW,DBLE 31700014 ERROR9 MVI MSGNO+3,9 31800014 ERROUT MVI NERSW+3,6 31900014 MVI SWITCH,OFF 31950017 L 15,VERROR 32000014 BCR ALWAYS,15 32100014 ERROR8 MVI MSGNO+3,8 32200014 BC ALWAYS,ERROUT 32300014 * 32400014 INTG ST NAME4,NAME+12 SAVE CONVERTED DATUM 32500014 ST NAME4,NACCM 32600014 LTR NAME3,NAME3 32700014 BC NZERO,ERROR8 INTEGER OVERFLOW 32800014 LTR NAME4,NAME4 32900014 BC MINUS,ERROR8 33000014 TM SCANSW,TOBIG 33100014 BC ALL,ERROR8 33200014 MVI NSHFT1+3,5 SET MODE TO INTEGER*4 33300014 MVI NNT+3,1 33400014 CH RBEGPT,C7 33500014 BC LOEQ,EXIT MUST BE A LABEL 33600014 CLI NTYPEX+3,2 33700014 BC NOTEQ,DELSET 33800014 ST RBEGPT,NSCNPT SET NEW SCAN POINTER 33900014 BC ALWAYS,EXIT 34000014 * 34100014 SETDSG CH RBEGPT,C7 34200014 BC LOW,INTG MUST BE END OF LABEL 34300014 TM SCANSW,NESWG 34400014 BC ALL,ERR10 PREVIOUS E-CHAR 34500014 CLI 0(SOURCE),C'E' 34600014 BC NOTEQ,CHKDSW 34700014 OI SCANSW,NESWG SET SWITCH FOR SINGLE 34800014 BC ALWAYS,FRACT 34900014 CHKDSW TM SCANSW,NDSWG 35000014 BC ALL,ERR10 PREVIOUS D-CHAR 35100014 OI SCANSW,NDSWG SET SWITCH FOR DOUBLE 35200014 FRACT STM NAME3,NAME4,DATUM 35300014 CLI 1(SOURCE),C'+' 35400014 BC EQUAL,UPDATE SKIP PLUS SIGN 35500014 CLI 1(SOURCE),C'-' 35600014 BC NOTEQ,DECOFF 35700014 OI SCANSW,NDEC SET FOR NEGATIVE SCALING 35800014 UPDATE LA SOURCE,1(0,SOURCE) BUMP POINTERS 35900014 LA RBEGPT,1(0,RBEGPT) 36000014 DECOFF NI SCANSW,NPERFF RESET DECIMAL SWITCH 36100014 SR NAME3,NAME3 36200014 SR NAME4,NAME4 36300014 STM NAME3,NAME4,NDBLE SAVE DATUM, AND RETURN 36400014 BC ALWAYS,SCNRET TO SCAN FOR EXPONENT. 36500014 * 36600014 SETPSG CLI 3(SOURCE),C'.' 36700014 BC EQUAL,LOGSET POSSIBLE LOGICAL OPERATOR 36800014 CLI 4(SOURCE),C'.' 36900014 BC EQUAL,LOGSET POSSIBLE LOGICAL OPERATOR 37000014 CHKSWG TM SCANSW,NPERSG 37100014 BC ALL,ERR10 PREVIOUS PERIOD 37200014 TM SCANSW,NDSWG 37300014 BC ALL,ERR10 PREVIOUS D-CHAR 37400014 TM SCANSW,NESWG 37500014 BC ALL,ERR10 PREVIOUS E-CHAR 37600014 OI SCANSW,NPERSG SET DECIMAL SWITCH 37700014 BC ALWAYS,SCNRET 37800014 ERR10 MVI MSGNO+3,10 37900014 BC ALWAYS,ERROUT 38000014 * 38100014 LOGSET SR WORK,WORK PICKUP LOGICAL OPERATOR 38200014 IC WORK,1(0,SOURCE) 38300014 SLL WORK,8 38400014 IC WORK,2(0,SOURCE) 38500014 CLI 3(SOURCE),C'.' 38600014 BC EQUAL,LOGSCN 38700014 SLL WORK,8 38800014 IC WORK,3(0,SOURCE) 38900014 LOGSCN LA J,72 39000014 CHKLOG C WORK,NLOGTB(J) CHECK AGAINST TABLE 39100014 BC EQUAL,SETLSG BRANCH IF FOUND 39200014 SH J,C8 39300014 BC PLUS,CHKLOG 39400014 BC ALWAYS,CHKSWG 39500014 SETLSG OI SCANSW,LLOGSW SET LOGICAL SWITCH 39600014 BC ALWAYS,CNVRT 39700014 * 39800014 SETHSG LA SOURCE,1(0,SOURCE) BUMP POINTERS 39900014 LA RBEGPT,1(0,RBEGPT) 40000014 TM SCANSW,NDSWG 40100014 BC ALL,ERROR9 PREVIOUS D-CHAR 40200014 TM SCANSW,NESWG 40300014 BC ALL,ERROR9 PREVIOUS E-CHAR 40400014 TM SCANSW,NPERSG 40500014 BC ALL,ERROR9 PREVIOUS PERIOD 40600014 CH RBEGPT,C7 40700014 BC LOEQ,INTG MUST BE A LABEL 40800014 MVI NHRETN+3,1 40900014 ST NAME4,NACCM SAVE COUNT 41000014 ST RBEGPT,NBEGPT RESET BEGIN POINTER 41100014 BC ALWAYS,EXIT 41200014 * 41300014 SETRSG MVI NDOLRT+3,1 41400014 BC ALWAYS,CSORNX 41500014 EJECT 41600014 * 41700014 DELSET TM SCANSW,LLOGSW 41800014 BC NONE,DELSCN 41900014 SETPRD MVC NPRVDL+3(1),NDELM+3 SET PREVIOUS DELIMITER 42000014 MVC NDELM+3(1),0(SOURCE) AND NEW DELIMITER. 42100014 TM SCANSW,LLOGSW 42200014 BC ALL,SETBEG 42300014 LA SOURCE,1(0,SOURCE) 42400014 SETBEG LA RBEGPT,1(0,RBEGPT) 42500014 ST RBEGPT,NSCNPT SET NEW SCAN POINTER 42600014 BC ALWAYS,EXIT 42700014 * 42800014 DELSCN LA NAME1,NDLMTB 42900014 LA NAME2,12 43000014 CHKDEL CLC 0(1,SOURCE),0(NAME1) TEST FOR MATCHING DELIMITER 43100014 BC EQUAL,SETPRD BRANCH IF FOUND 43200014 LA NAME1,2(0,NAME1) 43300014 CLI 0(SOURCE),X'4F' 43400014 BC EQUAL,SETNMK BRANCH IF END MARK 43500014 BCT NAME2,CHKDEL 43600014 BC ALWAYS,ERROR9 43700014 SETNMK MVC NDELM+3(1),0(SOURCE) 43800014 ST RBEGPT,NSCNPT SET NEW SCAN POINTER 43900014 * 44000014 EXIT MVI IASTR+3,0 44100014 CLI NSHFT1+3,6 CHECK FOR REAL*8 44200014 BC NOTEQ,SET14 44300014 MVI LENGTH+3,15 44400014 BC ALWAYS,TSTCPX 44500014 SET14 MVI LENGTH+3,14 44600014 TSTCPX CLI NCPX+3,0 TEST FOR COMPLEX 44700014 BC EQUAL,CSORNX 44800014 ST RBEGPT,NBEGPT RESET BEGIN POINTER 44900014 CSORNX TM SWITCH,X'FF' 45000014 BC NONE,RETURN EXIT IF LITCON ONLY 45100014 * 45200014 MVI SWITCH,OFF RESET SWITCH 45300014 CLI NHRETN+3,1 45400014 BC EQUAL,ERRSET BRANCH IF CHAR H 45500014 CLI NDOLRT+3,1 45600014 BC EQUAL,ERR13 BRANCH IF AMPERSAND 45700014 L WORK,NCPX 45800014 S WORK,C1 45900014 BC ZERO,PART1 46000014 BC PLUS,PART2 46100014 CALSYM MVI NCPX+3,0 46200014 CLI NCPLX+3,0 46300014 BC EQUAL,SYMTLU 46400014 MVI NMNSW+3,0 46500014 MVI NCPLX+3,1 46600014 SYMTLU LA 15,IEKCS2 NUMBER NOT COMPLEX, 46700014 BC ALWAYS,34(0,15) LOOKUP IN DICTIONARY. 46800014 * 46900014 PART1 MVI NCPX+3,2 47000014 CLI NSHFT1+3,7 47100014 BC EQUAL,HALFS1 MODE IS REAL*4 47200014 CLI NSHFT1+3,6 47300014 BC NOTEQ,ERR12 MODE NOT REAL*8 47400014 HALFD1 MVC NDSAV(8),NAME+8 SAVE DOUBLE NUMBER 47500014 MVI NTYPE,2 47600014 MVI NSHFT1+3,0 47700014 BC ALWAYS,LITCON 47800014 HALFS1 MVC NRSAV(4),NAME+12 SAVE REAL NUMBER 47900014 LITCON MVI SWITCH,ON RECALL LITCON 48000014 BC ALWAYS,34(0,15) 48100014 * 48200014 PART2 CLI NSHFT1+3,7 48300014 BC EQUAL,HALFS2 MODE IS REAL*4 48400014 CLI NSHFT1+3,6 48500014 BC NOTEQ,ERR12 MODE NOT REAL*8 48600014 HALFD2 CLI NTYPE,2 48700014 BC NOTEQ,SANDD 48800014 MVC NAME(8),NDSAV SET FIRST DOUBLE HALF 48900014 DBLCOM MVI NSHFT1+3,8 SET MODE TO COMPLEX*16 49000014 MVI LENGTH+3,16 49100014 MVI NCPLX+3,2 49200014 BC ALWAYS,SETSWG 49300014 HALFS2 CLI NTYPE,2 49400014 BC EQUAL,DANDS 49500014 MVC NAME+4(4),NRSAV SET FIRST REAL HALF 49600014 MVI NSHFT1+3,9 SET MODE TO COMPLEX*8 49700014 MVI LENGTH+3,15 49800014 MVI NCPLX+3,1 49900014 SETSWG MVI NNT+3,0 50000014 BC ALWAYS,CALSYM LOOKUP NUMBER IN DICTIONARY 50100014 * 50200014 SANDD MVC NAME(4),NRSAV 50300014 SR WORK,WORK 50400014 ST WORK,NAME+4 50500014 ERRHAF MVI MSGNO+3,211 50600014 MVI NERSW+3,6 50700014 LR CALL,15 50800014 L 15,VERROR 50900014 BALR 14,15 51000014 LR 15,CALL 51100014 BC ALWAYS,DBLCOM 51200014 DANDS MVC NAME+8(4),NAME+12 51300014 SR WORK,WORK 51400014 ST WORK,NAME+12 51500014 MVC NAME(8),NDSAV 51600014 BC ALWAYS,ERRHAF 51700014 * 51800014 ERR12 MVI MSGNO+3,12 51900014 BC ALWAYS,ERRCAL 52000014 ERR13 MVI MSGNO+3,13 52100014 ERRCAL MVI NERSW+3,6 52200014 L 15,VERROR 52300014 BCR ALWAYS,15 52400014 ERRSET MVI NCPX+3,0 52500014 BC ALWAYS,RETURN 52600014 EJECT 52700014 USING *,15 SUBROUTINE SYMTLU 52800014 IEKCS2 BC ALWAYS,*+12 52900014 DC X'0700' 53000014 DC C'IEKCS2' 53100014 STM 14,12,12(13) SAVE REGISTERS 53200014 L PH10R,VPH10 53300014 USING PH10,PH10R 53400014 ST 13,SAVE+4 53500014 MVC 8(4,13),SAVADD 53600014 LA 13,SAVE POINT TO SAVE AREA 53700014 * 53800014 L INFO,VBLANK 53900014 USING BLANK,INFO 54000014 MVI NTRYMD+3,0 54100014 LM NAME1,NAME4,NAME PICKUP NAME 54200014 L J,LENGTH USE LENGTH AS INDEX 54300014 BCTR J,0 TO NPTR TABLE. 54400014 SLL J,3 54500014 L MIDPT,NPTR+4(J) 54600014 LTR CHAIN,MIDPT START CHAIN AT MIDPOINT 54700014 BC ZERO,ENTER 54800014 BAL CALL,SEARCH DO NAME COMPARE 54900014 BC HIGH,HISIDE 55000014 * 55100014 LOSIDE L CHAIN,8(0,CHAIN) PROCEED ON LOW CHAIN 55200014 LTR CHAIN,CHAIN 55300014 BC ZERO,LOEND 55400014 BAL CALL,SEARCH COMPARE AGAIN 55500014 BC LOW,LOSIDE 55600014 BAL CALL,SETUP SET ENTRY FOR INSERT 55700014 L LAST,0(0,CHAIN) 55800014 ST NEXT,8(0,LAST) 55900014 ST NEXT,0(0,CHAIN) CHAIN TO NEW HIGH 56000014 ST CHAIN,8(0,NEXT) 56100014 ST LAST,0(0,NEXT) 56200014 NEWLO LA CALL,LOSW-1 USE LENGTH AS INDEX 56300014 A CALL,LENGTH 56400014 XI 0(CALL),X'FF' EVERY OTHER LOW 56500014 BC NZERO,ENDUP 56600014 L MIDPT,8(0,MIDPT) MOVE MIDPOINT DOWN 56700014 BC ALWAYS,MIDDLE 56800014 * 56900014 HISIDE L CHAIN,0(0,CHAIN) PROCEED ON HIGH CHAIN 57000014 LTR CHAIN,CHAIN 57100014 BC ZERO,HIEND 57200014 BAL CALL,SEARCH COMPARE AGAIN 57300014 BC HIGH,HISIDE 57400014 BAL CALL,SETUP SET ENTRY FOR INSERT 57500014 L LAST,8(0,CHAIN) 57600014 ST NEXT,0(0,LAST) 57700014 ST NEXT,8(0,CHAIN) CHAIN TO NEW LOW 57800014 ST CHAIN,0(0,NEXT) 57900014 ST LAST,8(0,NEXT) 58000014 NEWHI LA CALL,HISW-1 USE LENGTH AS INDEX 58100014 A CALL,LENGTH 58200014 XI 0(CALL),X'FF' EVERY OTHER HIGH 58300014 BC NZERO,ENDUP 58400014 L MIDPT,0(0,MIDPT) MOVE MIDPOINT UP 58500014 BC ALWAYS,MIDDLE 58600014 * 58700014 LOEND BAL CALL,SETUP 58800014 ST NEXT,8(0,LAST) CHAIN TO LAST LOW 58900014 ST LAST,0(0,NEXT) 59000014 BC ALWAYS,NEWLO 59100014 HIEND BAL CALL,SETUP 59200014 ST NEXT,0(0,LAST) CHAIN TO LAST HIGH 59300014 ST LAST,8(0,NEXT) 59400014 BC ALWAYS,NEWHI 59500014 * 59600014 SEARCH LR LAST,CHAIN SAVE CHAIN 59700014 CLI LENGTH+3,7 59800014 BC HIEQ,NUMBER 59900014 CLC NAME+10(6),30(CHAIN) COMPARE 6 CHARACTERS 60000014 BCR NOTEQ,CALL 60100014 LR NEXT,CHAIN 60200014 BC ALWAYS,ENDUP 60300014 NUMBER TM NSHFT1+3,8 60400014 BC NONE,CKSIZE BRANCH IF NOT COMPLEX 60500014 CL NAME1,20(0,CHAIN) CHECK NAME1 60600014 BCR NOTEQ,CALL 60700014 CL NAME2,24(0,CHAIN) CHECK NAME2 60800014 BCR NOTEQ,CALL 60900014 BC ALWAYS,CKNAM3 61000014 CKSIZE CLI LENGTH+3,15 TEST FOR 8-BYTE CHAIN 61100014 BC LOW,CKNAM4 61200014 CKNAM3 CL NAME3,28(0,CHAIN) CHECK NAME3 61300014 BCR NOTEQ,CALL 61400014 CKNAM4 CL NAME4,32(0,CHAIN) CHECK NAME4 61500014 BCR NOTEQ,CALL 61600014 LR NEXT,CHAIN SET TO CURRENT ENTRY 61700014 SH CALL,C14 61800014 CR CHAIN,MIDPT 61900014 BC NOTEQ,TSTMOD 62000014 LA CALL,LOSIDE 62100014 TSTMOD CLC 13(1,CHAIN),NSHFT1+3 62200014 BC EQUAL,ENDUP 62300014 BCR ALWAYS,CALL 62400014 * 62500014 SETUP L NEXT,NPTR+228 GET NEXT ENTRY LOC 62600014 MVI NTRYMD+3,1 SET ENTRY MADE 62700014 LA WORK,36 62800014 TM NPTR+18,1 TEST FOR XREF 62840014 BC NONE,NOREF 62880014 LA WORK,40 APPEND EXTRA WORD 62920014 NOREF CLI LENGTH+3,7 62960014 BC LOW,SETSIZ 63000014 TM NSHFT1+3,8 63100014 BC NONE,SETSIZ 63200014 SLA WORK,1 63300014 SETSIZ STM 0,1,SAVEIT 63400014 AR WORK,NEXT 63500014 C WORK,NPTR+236 CHECK IF ROOM FOR NEW ENTRY 63600014 BC LOEQ,SETNXT 63700014 LR 0,15 63800014 LA 1,PARAM 63900014 L 15,VGTCOR 64000014 BALR 14,15 64100014 LR 15,0 64200014 LM 0,1,SAVEIT 64300014 L NEXT,NPTR+228 64400014 AR WORK,NEXT 64500014 SETNXT ST WORK,NPTR+228 64600014 STM NAME1,NAME4,20(NEXT) STORE NAME 64700014 CLI LENGTH+3,7 64800014 BC LOW,SETMOD BRANCH IF VARIABLE 64900014 MVI 15(NEXT),5 SET TYPE TO CONSTANT 65000014 SETMOD MVC 13(1,NEXT),NSHFT1+3 SET MODE FROM GETWD/LITCON 65100014 BCR ALWAYS,CALL 65200014 * 65300014 ENTER BAL CALL,SETUP SET ENTRY FOR INSERT 65400014 LR MIDPT,NEXT 65500014 MIDDLE ST MIDPT,NPTR+4(J) SET NEW MIDPOINT 65600014 ENDUP ST NEXT,IDCTPT 65700014 XC NAME(16),NAME CLEAR NAME 65800014 MVI NNT+3,0 65900014 MVI NCPLX+3,0 66000014 * 66100014 CLI 15(NEXT),4 66200014 BC EQUAL,REFBIT 66300014 CLI 15(NEXT),6 66400014 BC EQUAL,REFBIT 66500014 TM 4(NEXT),X'80' 66600014 BC ALL,USECHK BRANCH IF STRUCTURED 66700014 MVC VCHAR(1),NCARD+15 66800014 CLI VCHAR,51 66900014 BC HIGH,CNTACT 67000014 TR VCHAR(1),ACTVEC 67100014 TM VCHAR,X'FF' 67200014 BC NONE,USECHK NO ACTIVITY 67300014 * 67400014 CNTACT LA WORK,1 SET ADDEND TO ONE 67500014 L EXPCTR,IDOLEV 67600014 BCTR EXPCTR,0 COMPUTE DO LEVEL 67700014 A EXPCTR,NDOLEV 67800014 BC ZMINUS,NOBIAS 67900014 SLA WORK,1 BIAS ADDEND BY 2**(DO LEVEL) 68000014 BCT EXPCTR,*-4 68100014 NOBIAS AH WORK,6(0,NEXT) ADDEND + CURRENT ACTIVITY 68200014 C WORK,TWO15M 68300014 BC LOEQ,SETACT MAXIMUM COUNT IS 2**15-1 68400014 L WORK,TWO15M 68500014 SETACT STH WORK,6(0,NEXT) SET NEW ACTIVITY COUNT 68600014 * 68700014 USECHK CLI 15(NEXT),5 CHECK FOR CONSTANT 68800014 BC EQUAL,REFTST 68900014 CLI NCARD+15,56 ARITH STATEMENT 69000014 BC EQUAL,ARITH 69100014 CLI NCARD+15,1 ASSIGN 69200014 BC EQUAL,STRBIT 69300014 CLI NCARD+15,2 BACKSPACE 69400014 BC EQUAL,FTCBIT 69500014 CLI NCARD+15,8 CALL 69600014 BC EQUAL,STRFTC 69700014 CLI NCARD+15,18 DO 69800014 BC EQUAL,DOTST 69900014 CLI NCARD+15,21 ENDFILE 70000014 BC EQUAL,FTCBIT 70100014 CLI NCARD+15,27 GO TO 70200014 BC EQUAL,FTCBIT 70300014 CLI NCARD+15,42 REWIND 70400014 BC EQUAL,FTCBIT 70500014 CLI NCARD+15,43 RETURN 70600014 BC EQUAL,FTCBIT 70700014 CLI NCARD+15,44 READ 70800014 BC EQUAL,IOTST 70900014 CLI NCARD+15,51 WRITE 71000014 BC EQUAL,IOTST 71100014 CLI NCARD+15,12 71200014 BC NOTEQ,REFBIT NOT FIND 71300014 * 71400014 IOTST CLI IOSWG+3,0 71500014 BC NOTEQ,REFBIT BRANCH IF I/O LIST 71600014 FTCBIT OI 24(NEXT),X'40' SET FETCH BIT 71700014 BC ALWAYS,REFBIT 71800014 DOTST CLI NDELM+3,C'=' 71900014 BC NOTEQ,FTCBIT BRANCH IF RIGHT OF EQUALS 72000014 STRFTC OI 24(NEXT),X'C0' SET STORE AND FETCH BITS 72100014 BC ALWAYS,REFBIT 72200014 ARITH CLI NDELM+3,C'=' 72300014 BC NOTEQ,FTCBIT BRANCH IF RIGHT OF EQUALS 72400014 STRBIT OI 24(NEXT),X'80' SET STORE BIT 72500014 * 72600014 * 72700014 * ************************************ 72800014 * THE FOLLOWING SECTION OF CODE BUILDS 72900014 * XREF ENTRIES FOR SYMBOLS 73000014 * ************************************ 73100014 * 73200014 REFBIT TM NPTR+18,1 IS XREF REQUESTED 73300014 BZ REFBIT1 NO, BYPASS XREF 73400014 CLI NTYPEX,0 IS THIS SECOND TIME FOR TYPE 73500014 * STATEMENT INITIALIZING DATA 73600014 BC NOTEQ,REFBIT1 YES, BYPASS XREF 73700014 CLI 35(NEXT),X'7B' INTERNAL SYMBOL 73800014 BE REFBIT1 YES, BYPASS XREF 73900014 CLI 32(NEXT),X'4B' INTERNAL SYMBOL (.DAC) 73930021 BE REFBIT1 YES,BYPASS XREF 73960021 L XREF,VBLANK 74000016 L XREF,60(XREF) LGTH OF BLKSIZE OF SYSUT2 74100016 LA XREF2,4 74300014 SR XREF,XREF2 74400014 LH XREF2,NPTR+146 PICK UP PTR TO NEXT AVAIL. XREF ENT. 74500014 CR XREF2,XREF HAVE WE REACHED END OF XREF SPACE 74600014 BL OK IF NO, BRANCH 74700014 LR CALL,15 SAVE BASE 74800014 L 15,WRITE CALL XREFSP 74900014 BALR LINK,15 75000014 LR 15,CALL RESTORE BASE 75100014 SR XREF2,XREF2 75200014 OK L XREF,VADCON 75300014 LA XREF,4(XREF) 75400014 LH XREF1,28(0,NEXT) PICK UP PTR TO LAST ENTRY FOR SYMBOL 75500014 * IN XREF 75600014 LTR XREF1,XREF1 HAVE ANY ENTRIES BEEN MADE FOR SYMB. 75700014 BC NOTZERO,NOTFIRST IF YES, BRANCH 75800014 NEWBLK L WORK,36(0,NEXT) PICK UP DISK WRITE NO. AND PTR TO 77300014 * FIRST XREF ENTRY FROM DICT. ENTRY 77400014 ST WORK,0(XREF,XREF2) AND STORE IN XREF BUFFER 77500014 MVC 37(1,NEXT),NPTR+159 PUT NEW DISK WRITE NO. IN DICT. ENT. 77600014 LA XREF2,4(0,XREF2) INCREMENT PTR TO NEXT XREF LOC 77700014 STH XREF2,38(0,NEXT) PUT PTR TO ENTRY IN DICT 77800014 * ENTRY AS PTR TO CHAIN 77900014 B FIRSTISN 78000014 NOTFIRST CLC 37(1,NEXT),NPTR+159 ARE WE IN NEW BLOCK 78100014 BC NOTEQ,NEWBLK IF YES, BRANCH 78200014 STH XREF2,0(XREF,XREF1) PUT ENTRY IN CHAIN 78300014 FIRSTISN STH XREF2,28(0,NEXT) UPDATE PTR TO END OF CHAIN IN DICT. 78400014 L RISN,ISN PICK UP ISN 78500014 CLI IFTRLG+3,2 78600014 BC NOTEQ,STOREISN 78700014 BCTR RISN,0 IF YES, DECREMENT ISN BY 1 78800014 STOREISN STH RISN,2(XREF,XREF2) PUT ISN IN XREF ENTRY 78900014 SR RISN,RISN 79000014 STH RISN,0(XREF,XREF2) INSURE THAT PTR IN NEW XREF ENTRY=0 79100014 LA XREF2,4(0,XREF2) STEP PTR TO NEXT AVAILABLE XREF LOC 79200014 STH XREF2,NPTR+146 PUT PTR TO NEXT XREF LOC IN NPTR 79300014 * 79400014 * ************************************ 79500014 * 79600014 REFBIT1 MVC VCHAR(1),NCARD+15 79700014 CLI VCHAR,51 79800014 BC HIGH,BITON 79900014 TR VCHAR(1),REFVEC 80000014 TM VCHAR,X'FF' 80100014 BC NONE,RETURN NO REFERENCE 80200014 BITON OI 4(NEXT),64 SET REFERENCE BIT 80300014 RETURN L 13,4(0,13) 80400014 LM 14,12,12(13) RESTORE REGISTERS 80500014 MVI 12(13),X'FF' 80600014 BCR ALWAYS,14 RETURN 80700014 * 80800014 REFTST CLI NCARD+15,56 ARITH STATEMENT 80900014 BC EQUAL,BITON 81000014 CLI NCARD+15,8 CALL 81100014 BC EQUAL,BITON 81200014 CLI NCARD+15,13 DEFINE FILE 81300014 BC EQUAL,BITON 81400014 CLI NCARD+15,18 DO 81500014 BC EQUAL,BITON 81600014 CLI NCARD+15,31 LOGICAL IF 81700014 BC EQUAL,BITON 81800014 CLI NCARD+15,32 ARITHMETIC IF 81900014 BC EQUAL,BITON 82000014 CLI NCARD+15,43 RETURN 82100014 BC EQUAL,BITON 82200014 CLI IOSWG+3,1 I/O LIST 82300014 BC EQUAL,BITON 82400014 CLI NCARD+15,12 FIND 82450021 BC EQUAL,BITON 82460021 BC ALWAYS,RETURN 82500014 EJECT 82600014 * 82700014 * COMMON DEFINITIONS 82800014 * 82900014 BLANK EQU IEKAAA 83000014 NPTR EQU BLANK 83100014 PH10 EQU IEKCAA 83200014 NCARD EQU PH10 83300014 NCDIN EQU PH10+X'10' 83400014 NLOGTB EQU PH10+X'60C' 83500014 NDLMTB EQU PH10+X'65C' 83600014 ISN EQU PH10+X'6A0' 83700014 IDOLEV EQU PH10+X'6A4' 83800014 NAME EQU PH10+X'6A8' 83900014 NBEGPT EQU PH10+X'6B8' 84000014 NSCNPT EQU PH10+X'6BC' 84100014 LENGTH EQU PH10+X'6C0' 84200014 NPRVDL EQU PH10+X'6C4' 84300014 NDELM EQU PH10+X'6C8' 84400014 NNT EQU PH10+X'6D0' 84500014 NCPLX EQU PH10+X'6D8' 84600014 NACCM EQU PH10+X'6DC' 84700014 NACCSV EQU PH10+X'6E0' 84800014 NMNSW EQU PH10+X'6E4' 84900014 NCPX EQU PH10+X'6E8' 85000014 NSHFT1 EQU PH10+X'6EC' 85100014 IFTRLG EQU PH10+X'6FC' 85200014 IASTR EQU PH10+X'730' 85300014 NTYPEX EQU PH10+X'73C' 85400014 NDOLRT EQU PH10+X'748' 85500014 NHRETN EQU PH10+X'74C' 85600014 IOSWG EQU PH10+X'750' 85700014 NDOLEV EQU PH10+X'778' 85800014 NTRYMD EQU PH10+X'78C' 85900014 IDCTPT EQU PH10+X'790' 86000014 MSGNO EQU PH10+X'7A8' 86100014 NERSW EQU PH10+X'7AC' 86200014 * 86300014 * POWERS OF TEN IN FLOATING HEXADECIMAL 86400014 * 86500014 ETABHX DS 0D 86600014 DC X'41100000' 10**0 86700014 DC X'41A00000' 10**1 86800014 DC X'42640000' 10**2 86900014 DC X'433E8000' 10**3 87000014 DC X'44271000' 10**4 87100014 DC X'45186A00' 10**5 87200014 DC X'45F42400' 10**6 87300014 DC X'46989680' 10**7 87400014 ETABHT DS 0D 87500014 DC X'475F5E10' 10**8 87600014 DC X'483B9ACA' 10**9 87700014 DC X'492540BE40000000' 10**10 87800014 DC X'5156BC75E2D63100' 10**20 88000014 DC X'59C9F2C9CD04674F' 10**30 88100014 DC X'621D6329F1C35CA5' 10**40 88200014 DC X'6A446C3B15F99267' 10**50 88300014 DC X'729F4F2726179A23' 10**60 88400014 DC X'7B172EBAD6DDC73C' 10**70 88500014 TEN20 DC X'508AC7230489E800' 10**19 36020 88530020 C85 DC H'85' 36020 88560020 * 88600014 * CONSTANT AREA 88700014 * 88800014 VBLANK DC A(IEKAAA) 88900014 VPH10 DC A(IEKCAA) 89000014 VCLASS DC V(IEKDCL) 89100014 VERROR DC V(IEKCDP) 89200014 WRITE DC A(IEKXRS) 89300014 VADCON DC A(IEKAAD) 89400014 VGTCOR DC V(IEKAGC) 89500014 SAVE DS 18F 89600014 SAVADD DC A(SAVE) 89700014 FPSAV1 DS 1D 89800014 FPSAV2 DS 1D 89900014 NDBLE DS 1D 90000014 DATUM DS 1D 90100014 NRSAV DS 1F 90200014 NDSAV DS 2F 90300014 SVNAM2 DS 1F 90330020 SVNPTR DS 1F 90360020 DIGIT DC F'0' 90400014 SAVEIT DS 2F 90500014 PARAM DC A(TWO) 90600014 TWO DC F'2' 90700014 HIBYTE DC X'1FFFFFFF' 90800014 C1 DC F'1' 90900014 C10 DC F'10' 91000014 TWO15M DC F'32767' 91100014 C3 DC H'3' 91200014 C7 DC H'7' 91300014 C8 DC H'8' 91400014 C14 DC H'14' 91500014 C20 DC H'19' REDUCE EXPONENT BY 19 36020 91600020 C74 DC H'75' FIX FOR FORTH CHANGE H'74' TO H'75' 36020 91700020 C92 DC H'92' 91800014 MOVNAM MVC 0(1,TARGET),0(SOURCE) 91900014 SWITCH DC AL1(0) 92000014 SCANSW DC AL1(0) 92100014 NTYPE DC AL1(0) 92200014 LOSW DC XL16'00' FLIP-FLOP LOW 92300014 HISW DC XL16'00' FLIP-FLOP HIGH 92400014 VCHAR DC AL1(0) 92500014 DS 0D 36020 92530020 MAXM DC X'7FFFFFFFFFFFFFFF' MAX FLOAT POINT NO 36020 92560020 * 92600014 ACTVEC DC X'00FFFF',5X'00',X'FF000000',X'FF',5X'00',X'FF0000FF' 92700014 DC 5X'00',X'FF000000FFFF0000000000FFFFFF00FFFFFF000000FF' 92800016 DC X'0000FF' 92900014 * 93000014 REFVEC DC X'00FFFF00FF000000FF00FF00FFFF00FF0000',5X'FF',X'00FF00' 93100014 DC X'00FFFF0000FFFFFF00FFFF00',7X'FF',X'00FFFFFF0000FF' 93200014 MSGSWTCH DC X'00' 93250021 * 93300014 END 93400014 ./ ADD SSI=01000042,NAME=IEKCDO,SOURCE=0 C SUBROUTINE XDO 00100021 SUBROUTINE IEKCDO 00200014 C 453000,472000,486000,508000 12376 00250015 C3140514000,524000 16455 00270016 C2209450000,452100-452500,453300-453600 18856 00275017 C1480395500 1710100280017 C2830446000,445200-446600,508070-508210 21066 00290018 C0381343000,375500,388500,389100-389800,442000,446400,453100- 19345 00293018 C 453600,508020,508040 19345 00296018 C 092100-092500,105000-107000 23400 00298019 C 453700-453900 0000E 00299019 C9359375300-375600 31903 00299520 C 383100-383700,389520-389588 2004.03 00299921 C 453700-453900,453610-453690 LL43133 00329921 C 453040-453960 LL47423 00339921 C 472500 LL2108.03 00349921 C A375030-375240 LL51358 00354921 C A375247-375289 LL55878 00356921 C 00359921 C DICTIONARY LAYOUT 00400014 C 00500014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00600014 LOGICAL*1 BYA,BYB,BYC 00700014 INTEGER*2 DIS,MDD,TYP 00800014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00900014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01000014 * NAM1,NAM2,NAM3,NAM4 01100014 C 01200014 C 01300014 C INTERMEDIATE TEXT LAYOUT 01400014 C 01500014 LOGICAL * 1 ADJCD 01600014 INTEGER * 2 TMOD,TTYP 01700014 INTEGER TXTCHN,TPTR 01800014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 01900014 C 02000014 C 02100014 C LABEL LAYOUT 02200014 C 02300014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 02400014 LOGICAL*1 COMP,DN 02500014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 02600014 C 02700014 COMMON /IEKAAA/ NPTR (2,35) 02800014 COMMON /IEKAER/ NERTBL (2,50) 02900014 C 03000014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 03100014 INTEGER SLIMS 03200014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 03300014 *M2R3,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 03400014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 03500014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 03600014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 03700014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 03800014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 03900014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 04000014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 04100014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 04200014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 04300014 C 04400014 EQUIVALENCE (NPTR (1,9), NPUT) 04500014 DIMENSION NPRSAV(20), NSAVE(6) 04600014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC04700014 C C04800014 C XDO - IEKCDO C04900014 C C05000014 C FUNCTION - XDO TRANSLATES THE DO STATEMENT UP TO THE EQUAL SIGN. C05100014 C IT SETS A SWITCH SAYING THIS IS A DO LOOP. CHECKS SYNTAX C05200014 C AND ENSURES THAT THE STATEMENT NUMBER AND INDEX ARE IN C05300014 C THE DICTIONARY. C05400014 C C05500014 C CALLED BY - DSPTCH C05600014 C C05700014 C COMMON - BLANK, PH10 C05800014 C C05900014 C ERRORS - 133, 30, 134, 135 C06000014 C C06100014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC06200014 C 06300014 C BRANCH IF IMPLIED DO 06400014 IF (NCARD(4).NE.18) GO TO 1000 06500014 C SET EXECUTABLE STATEMENT 06600014 C SWITCH ON. 06700014 NEXCSG=1 06800014 C NXTRN IS SET TO 1 BY XCLASS 06900014 C IF THE STATEMENT IS LABELED. 07000014 C INDICATE THIS IS THE LABEL 07100014 C OF A DO. 07200014 IF(NXTRN .NE. 0) BYA (ILABPT) = BITON (BYA (ILABPT),5) 07300014 C IF THE PRESENT DO-STATEMENT IS 07400014 C NOT THE STATEMENT PORTION OF A 07500014 C LOGICAL-IF-STATEMENT, BRANCH TO 07600014 C CONTINUE PROCESSING. OTHERWISE, 07700014 C FALL THRU TO SET THE ERROR. 07800014 IF (IFTRLG.EQ.0) GO TO 2015 07900014 MSGNO=133 08000014 GOTO 5000 08100014 C FOLLOWING CALL TO GETWD ACCESSES08200014 C THE ELEMENT FOLLOWING THE 08300014 C KEYWORD DO. 08400014 C CALL GETWD 08500014 2015 CALL IEKCGW 08600014 C INSURE THAT IT IS A CONSTANT. 08700014 IF(NACCSV.EQ.1) GOTO 2020 08800014 MSGNO=30 08900014 GOTO 5000 09000014 C INCREMENT DO LEVEL. 09100014 2020 NDOLEV=NDOLEV+1 09200014 C 09210019 C SET A SWITCH INDICATING THE 09220019 C START OF A DO-LOOP 09230019 C 09240019 NBEGDO=1 09250019 C IF THE DO LEVEL EXCEEDS 25, 09300014 C BRANCH TO SET THE ERROR. 09400014 IF(NDOLEV.GT.25) GOTO 2045 09500014 C FOLLOWING CALL TO LABTLU HAS THE09600014 C STATEMENT NUMBER ENTRY FOR THE 09700014 C LABEL SPECIFIED TO END THE DO 09800014 C RANGE GENERATED. 09900014 C CALL LABTLU 10000014 CALL IEKCLT 10100014 C INSURE THAT THE LABEL WAS NOT 10200014 C PREVIOUSLY DEFINED. 10300014 IF (TBIT(BYA(ILABPT),0)) GO TO 2065 10400014 C SET THE BIT IN THE ENTRY FOR 10800014 C THE LABEL SPECIFIED TO END THE 10900014 C DO-LOOP INDICATING THAT IT IS 11000014 C REFERENCED. 11100014 C SET BIT INDICATING THAT THE 11200014 C LABEL IS THE OBJECT OF A 11300014 C TRANSFER. 11400014 BYA (ILABPT) = 65 11500014 C SET ADDRESS OF THE LABEL ENTRY 11600014 C INTO THE DO-PUSH-DOWN TABLE. 11700014 NDOPDN(1,NDOLEV) = ILABPT 11800014 C FOLLOWING CALL TO GETWD ACCESSES11900014 C THE DO-VARIABLE. 12000014 C CALL GETWD 12100014 CALL IEKCGW 12200014 C INSURE THAT IT IS A VARIABLE. 12300014 IF(NACCSV.EQ.2) GOTO 2050 12400014 2040 MSGNO = 134 12500014 GOTO 5000 12600014 2045 MSGNO = 136 12700014 GOTO 5000 12800014 C INSURE THAT AN EQUAL SIGN 12900014 C FOLLOWS THE DO-VARIABLE. 13000014 2050 IF(NDELM.NE.NEQ) GOTO 2060 13100014 C CALL COMSYM TO PACK THE VARIABLE13200014 C AND GENERATE / RETRIEVE ITS 13300014 C DICTIONARY ENTRY. 13400014 C CALL COMSYM 13500014 CALL IEKCS3 13600014 C INSURE THAT THE VARIABLE IS AN 13700014 C INTEGER. IF IT IS NOT, BRANCH TO13800014 C SET THE ERROR. 13900014 IF(MDD (IDCTPT) .GT. 5 .OR. TYP (IDCTPT) .GT. 1) GO TO 2040 14000014 C SET THE ADDRESS OF THE DO 14100014 C VARIABLE INTO THE DO-PUSH-DOWN 14200014 C TABLE. 14300014 NDOPDN (2,NDOLEV) = IDCTPT 14400014 NSAVE(1) = ILABPT 14500014 NSAVE(2) = IDCTPT 14600014 C FOLLOWING CALL TO CDOPAR HAS 14700014 C THE REMAINING PARAMETERS OF THE 14800014 C DO-STATEMENT PROCESSED. 14900014 C C15000014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC15100014 C C15200014 C FUNCTION - CDOPAR TRANSLATES THE INITIAL VALUE, FINAL VALUE AND C15300014 C INCREMENT OF BOTH A NORMAL AND IMPLIED DO STATEMENT. IT C15400014 C CHECKS SYNTAX AND PLACES THE PARAMETERS IN A PUSHDOWN C15500014 C TABLE FOR NESTED DO5S. C15600014 C C15700014 C ERRORS - 128, 135, 31, 15 C15800014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC15900014 C 16000014 C FOLLOWING CALL TO GETWD ACCESSES16100014 C THE INITIAL VALUE CONSTANT OR 16200014 C VARIABLE. 16300014 C CALL GETWD 16400014 300 CALL IEKCGW 16500014 C INSURE THAT THE ELEMENT ACCESSED16600014 C IS NOT A DELIMITER. 16700014 IF (LENGTH.NE.0) GO TO 3015 16800014 MSGNO = 31 16900014 GOTO 5000 17000014 C IF A COMMA DOES NOT FOLLOW THE 17100014 C INITIAL VALUE, BRANCH TO SET THE17200014 C ERROR. 17300014 3015 IF (NDELM.NE.NCOMA) GO TO 2060 17400014 C FOLLOWING CALL TO CSORN HAS THE 17500014 C DICTIONARY ENTRY FOR THE INITIAL17600014 C VALUE GENERATED. 17700014 C CALL CSORN 17800014 CALL IEKCCR 17900014 C IF IT IS NOT AN INTEGER, BRANCH 18000014 C TO SET THE ERROR. 18100014 IF(MDD (IDCTPT) .GT. 5 .OR. TYP (IDCTPT) .GT. 1 18200014 * .AND. TYP (IDCTPT) .NE. 5) GO TO 3020 18300014 C SET ADDRESS OF THE ENTRY FOR THE18400014 C INITIAL VALUE INTO THE NORMAL- 18500014 C DO-PUSH-DOWN TABLE. -NDOLEV 18600014 C CONTAINS THE LEVEL OF NESTED DOS18700014 NSAVE (6) = IDCTPT 18800014 C FOLLOWING CALL TO GETWD ACCESSES18900014 C THE TEST VALUE CONSTANT OR 19000014 C VARIABLE. 19100014 C CALL GETWD 19200014 CALL IEKCGW 19300014 C INSURE THAT THE ELEMENT ACCESSED19400014 C IS NOT A DELIMITER. 19500014 IF (LENGTH.NE.0) GO TO 3035 19600014 MSGNO=135 19700014 GOTO 5000 19800014 3020 MSGNO = 116 19900014 GOTO 5000 20000014 C FOLLOWING CALL TO CSORN HAS THE 20100014 C DICTIONARY ENTRY FOR THE TEST 20200014 C VALUE GENERATED. 20300014 C CALL CSORN 20400014 3035 CALL IEKCCR 20500014 C IF IT IS NOT AN INTEGER, BRANCH 20600014 C TO SET THE ERROR. 20700014 IF(MDD (IDCTPT) .GT. 5 .OR. TYP (IDCTPT) .GT. 1 20800014 * .AND. TYP (IDCTPT) .NE. 5) GO TO 3020 20900014 C SET ADDRESS OF THE ENTRY FOR THE21000014 C TEST VALUE INTO THE NORMAL-DO- 21100014 C PUSH-DOWN TABLE. 21200014 NSAVE (4) = IDCTPT 21300014 C FOLLOWING DETERMINES IF THE 21400014 C INCREMENT PARAMETER IS SPECIFIED.21500014 C IF DELIMITER IS AN END MARK, 21600014 C SIGNIFYING THE END OF A NORMAL- 21700014 C DO, BRANCH. 21800014 C IF DELIMITER IS A RIGHT PAREN, 21900014 C SIGNIFYING THE END OF AN IMPLIED22000014 C DO, BRANCH. 22100014 IF(NDELM.EQ.NRTPR.OR.NDELM.EQ.NGPMK) GOTO 3050 22200014 C IF A COMMA DOES NOT FOLLOW THE 22300014 C TEST VALUE, BRANCH TO SET THE 22400014 C ERROR. 22500014 IF (NDELM.NE.NCOMA) GO TO 2060 22600014 C FOLLOWING CALL TO GETWD ACCESSES22700014 C THE INCREMENT CONSTANT OR 22800014 C VARIABLE. 22900014 C CALL GETWD 23000014 CALL IEKCGW 23100014 C INSURE THAT THE ELEMENT ACCESSED23200014 C IS NOT A DELIMITER. 23300014 IF(LENGTH.NE.0) GOTO 3055 23400014 MSGNO=137 23500014 GOTO 5000 23600014 C THE INCREMENT IS NOT SPECIFIED. 23700014 C IT IS THEREFORE ASSUMED TO BE 1.23800014 C SET 1 AS THE ENTRY TO BE MADE 23900014 3050 NAME(4)=1 24000014 C SET A SWITCH INDICATING TO 24100014 C SYMTLU THAT THE ELEMENT TO BE 24200014 C ENTERED IS AN INTEGER. 24300014 NSHFT1 = 5 24400014 C INDICATE THAT ELEMENT IS A 24500014 C CONSTANT. 24600014 LENGTH=14 24700014 C FOLLOWING CALL TO SYMTLU HAS AN 24800014 C ENTRY FOR THE 1 GENERATED. 24900014 C CALL SYMTLU 25000014 CALL IEKCS2 25100014 GOTO 3060 25200014 C INCREMENT IS SPECIFIED. 25300014 C FOLLOWING CALL TO CSORN HAS THE 25400014 C DICTIONARY ENTRY FOR THE 25500014 C INCREMENT GENERATED. 25600014 C CALL CSORN 25700014 3055 CALL IEKCCR 25800014 C IF IT IS NOT AN INTEGER, BRANCH 25900014 C TO SET THE ERROR. 26000014 IF(MDD (IDCTPT) .GT. 5 .OR. TYP (IDCTPT) .GT. 1 26100014 * .AND. TYP (IDCTPT) .NE. 5) GO TO 3020 26200014 C SET ADDRESS OF THE ENTRY FOR THE26300014 C INCREMENT INTO THE NORMAL-DO- 26400014 C PUSH-DOWN TABLE. 26500014 3060 NSAVE (3) = IDCTPT 26600014 C INSURE THAT THE CLOSING 26700014 C DELIMITER IS CORRECT. 26800014 C IF IT IS AN END MARK, SIGNIFYING26900014 C THE END OF A NORMAL-DO, BRANCH. 27000014 C IF IT IS A RIGHT PAREN, 27100014 C SIGNIFYING THE END OF AN IMPLIED27200014 C DO, BRANCH. 27300014 IF(NDELM.EQ.NRTPR.OR.NDELM.EQ.NGPMK) GOTO 3080 27400014 2060 MSGNO = 101 27500014 GOTO 5000 27600014 2065 MSGNO = 138 27700014 GOTO 5000 27800014 C BRANCH IF NORMAL DO 27900014 3080 IF (IMDOSW.NE.1) GO TO 3084 28000014 DO 3083 I = 1,6 28100014 3083 IMPDOD(I,IDOLEV) = NSAVE(I) 28200014 C RETURN TO XIMPD 28300014 GO TO 1016 28400014 3084 DO 3081 I = 1,6 28500014 3081 NDOPDN(I,NDOLEV) = NSAVE(I) 28600014 C FOLLOWING BUILDS THE TEXT FOR 28700014 C THE DO-STATEMENT. 28800014 C SAVE THE ADDRESS OF THE DO 28900014 C VARIABLE ENTRY. 29000014 IDCTPT = NDOPDN (2,NDOLEV) 29100014 C SET THE ADJECTIVE CODE FOR A 29200014 C DO-STATEMENT INTO THE TEXT WORK 29300014 C AREA. 29400014 ADJCD (NPUT) = 240 29500014 C CALL PUTX TO GENERATE A TEXT 29600014 C ENTRY FOR THE ABOVE. 29700014 C CALL PUTX 29800014 CALL IEKCPX 29900014 C SAVE THE ADDRESS OF THE INITIAL 30000014 C VALUE ENTRY. 30100014 IDCTPT = NDOPDN (6,NDOLEV) 30200014 C SET THE ADJECTIVE CODE FOR AN 30300014 C EQUAL SIGN. 30400014 ADJCD (NPUT) = 8 30500014 C CALL PUTX TO GENERATE A TEXT 30600014 C ENTRY FOR THE ABOVE. 30700014 C CALL PUTX 30800014 CALL IEKCPX 30900014 C FOLLOWING CALL TO CLOSE HAS THE 31000014 C TEXT ENTRIES SIGNIFYING THE END 31100014 C OF INTERMEDIATE TEXT GENERATED. 31200014 C CALL CLOSE 31300014 NCLSTX = 1 31400014 C CALL PUTX 31500014 CALL IEKCPX 31600014 GOTO 9999 31700014 C C31800014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC31900014 C C32000014 C FUNCTION - XIMPD TRANSLATES IMPLIED DO LOOPS APPEARING IN C32100014 C I/O STATEMENTS. IT CHECKS SYNTAX AND GENERATES INTER- C32200014 C MEDIATE TEXT. C32300014 C C32400014 C ERRORS - 163, 176, 158 C32500014 C C32600014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC32700014 C C32800014 1000 NSUBC = 0 32900014 JSUB=0 33000014 IDOLEV=1 33100014 I1=1 33200014 NBGSV=NBEGPT 33300014 C INSERT PAREN TO PAREN TABLE 33400014 1005 NPRSAV(I1)=NBEGPT 33500014 I1=I1+1 33600014 C MATCH PAIRS OF PARENS AND 33700014 C SET DO LEVEL STARTING POINT. 33800014 C CALL GETWD 33900014 1010 CALL IEKCGW 34000014 IF (NDELM.NE.NRTPR) GO TO 1012 34100014 I1 = I1 - 1 34200014 IF (NCDIN(NSCNPT).GT.192) GO TO 1151 34300018 1012 IF (NDELM.EQ.NGPMK) GO TO 1020 34400014 IF(NDELM.EQ.NLFPR) GOTO 1005 34500014 IF (NDELM.NE.NEQ) GO TO 1010 34600014 C SET POINTER TO DO RANGE BY 34700014 C THE LAST OPEN PAREN PAIR. 34800014 NSCNSV = NSCNPT 34900014 IF (IDOLEV.EQ.21) GO TO 2045 35000014 C CALL CSORN 35100014 CALL IEKCCR 35200014 IMPDOD(1,IDOLEV)=NPRSAV(I1-1) 35300014 IF (MDD(IDCTPT).GT.5.OR.TYP(IDCTPT).GT.1) GO TO 3020 35400014 IMPDOD (2,IDOLEV) = IDCTPT 35500014 IMDOSW=1 35600014 DO 1014 I = 1, 6 35700014 1014 NSAVE(I) = IMPDOD(I,IDOLEV) 35800014 GOTO 300 35900014 C RETURN FROM CDOPAR 36000014 1016 IDOLEV=IDOLEV+1 36100014 NLEVEL=IDOLEV 36200014 NSCNPT=NSCNSV 36300014 GOTO 1010 36400014 C INSURE PAREN COUNT IS ZERO 36500014 1020 IF (I1.NE.1) GO TO 1025 36600014 IF (IDOLEV.EQ.1) GO TO 1035 36700014 C DEVELOP TEXT 36800014 NSCNPT = NBGSV 36900014 IF(NPRSAV(I1).LT.NSCNPT) NSCNPT=NPRSAV(I1) 37000014 LENGTH=0 37100014 1030 NL = IDOLEV 37200014 C CALL GETWD 37300014 1070 CALL IEKCGW 37400014 IF (LENGTH.NE.0) GO TO 1090 37500014 C 37503021 C CHECK FOR ILLEGAL DELIMETER FOLLOWING A RT 37506021 C PAREN WHEN WE ARE NOT WITHIN A SUBSCRIPT. LEGAL 37509021 C DELIMS ARE , ) OR ³ 37512021 C 37515021 IF(NSUBC .EQ. 0 .AND. NPRVDL .EQ. NRTPR .AND. 37518021 C (NDELM .NE. NCOMA .AND. NDELM .NE. NRTPR .AND. 37521021 C NDELM .NE. NGPMK))GO TO 1038 37524021 C 37524721 C CHECK FOR ILLEGAL DELIMITER FOLLOWING A LEFT 37525421 C PAREN WHEN WE ARE NOT WITHIN A SUBSCRIPT. ONLY 37526121 C LEGAL DELIMITER IS LEFT PAREN. 37526821 C 37527521 IF (NSUBC .EQ. 0 .AND. NPRVDL .EQ. NLFPR .AND. NDELM .NE. 37528221 * NLFPR) GO TO 2060 37528921 C CHECK I/O LIST FOR A COMMA FOLLOWED BY A MINUS SIGN. 37530020 IF(NPRVDL.EQ.NCOMA.AND.LENGTH.EQ.0.AND.NDELM.EQ.NMIN) GO TO 1038 37560020 IF (NDELM.EQ.NLFPR) GO TO 1040 37600014 IF (NDELM.EQ.NGPMK) GO TO 1165 37700014 IF(NDELM.EQ.NCOMA.AND.NPRVDL.NE.NRTPR) GOTO 1185 37800014 C ELIMINATE EXTRA RIGHT PARENS 37900014 IF(NDELM.EQ.NRTPR.AND.NPRVDL.EQ.NRTPR.AND.NSUBC.EQ.0) GOTO 1070 38000014 IF(NDELM.EQ.NPLUS.AND.NPRVDL.NE.NRTPR) GOTO 1070 38100014 IF(NDELM.EQ.NMIN.AND.NPRVDL.EQ.NLFPR) GOTO 1060 38200014 IF(ADJCD(LPUT).EQ.247 .AND. NDELM.EQ.NCOMA) ADJCD (NPUT) = 26 38300014 C 38310021 C DO WE HAVE EXPONENTIATION? 38350021 C 38360021 IF(NDELM .EQ. NASTR .AND. NPRVDL .EQ. NASTR) GO TO 1041 38370021 MTPSET = 1 38400014 GOTO 1115 38500014 1060 NXSMNG=1 38600014 GOTO 1070 38700014 1035 NSCNPT=NBGSV+1 38800014 IF(NCDIN(NSCNPT-1).EQ.NLFPR)GO TO 1036 38850018 GO TO 1030 38900014 1036 IF(NCDIN(NSCNPT).EQ.NLFPR)GO TO 1030 38910018 DO 1037 I=1,11 38920018 IF(NCDIN(NSCNPT).EQ.NDLMTB(1,I))GO TO 1038 38930018 1037 CONTINUE 38940018 GO TO 1030 38950018 C 38952021 C EXPONENTIATION. RESET TEXT ADJCD TO 14 38954021 C AND CONTINUE SCAN. 38956021 C 38958021 1041 ADJCD(NPUT)=14 38958421 GO TO 1070 38958821 1038 NBEGPT=NSCNPT 38960018 MSGNO=164 38970018 GO TO 5000 38980018 1040 DO1050 IDOLEV=1,NL 39000014 IF (IMPDOD(1,IDOLEV).EQ.NBEGPT) GO TO 1075 39100014 1050 CONTINUE 39200014 C ELIMINATE EXTRA LEFT PARENS 39300014 IF (NSUBC.EQ.0) GO TO 1080 39400014 NSUBC=NSUBC+1 39500014 MTPSET=1 39550017 GO TO 1115 39600014 1080 NDELM = NPRVDL 39700014 GO TO 1070 39800014 C SET NEW START DO LEVEL 39900014 C MOVE PUSHDOWN TABLE TO TEXT 40000014 C IN REVERSE ORDER. 40100014 1075 ISVDPT = IDCTPT 40200014 IDCTPT = IMPDOD (2,IDOLEV) 40300014 IF(ADJCD (LPUT) .EQ. 26) GO TO 1085 40400014 ADJCD (NPUT) = 26 40500014 MTPSET = 1 40600014 C CALL PUTX 40700014 CALL IEKCPX 40800014 C BEGIN DO INDEX 40900014 1085 ADJCD (NPUT) = 240 41000014 C CALL PUTX 41100014 CALL IEKCPX 41200014 C EQUALS START VALUE 41300014 ADJCD (NPUT) = 8 41400014 IDCTPT = IMPDOD (6,IDOLEV) 41500014 C CALL PUTX 41600014 CALL IEKCPX 41700014 C END MARK 0 41800014 ADJCD (NPUT) = 26 41900014 MTPSET = 1 42000014 C CALL PUTX 42100014 CALL IEKCPX 42200014 C GENERATE A LABEL AND PUT IT AWAY 42300014 C IN LABEL TABLE, PUSHDOWN 42400014 C TABLE, AND TEXT. 42500014 LBSWG=1 42600014 C CALL LABTLU 42700014 CALL IEKCLT 42800014 IMPDOD (5,IDOLEV) = ILABPT 42900014 ADJCD (NPUT) = 223 43000014 MTPSET = -1 43100014 C CALL PUTX 43200014 CALL IEKCPX 43300014 IDCTPT = ISVDPT 43400014 ADJCD (NPUT) = 247 43500014 GOTO 1070 43600014 C ELIMINATE EXTRA RIGHT PARENS 43700014 1086 IF(LENGTH .EQ. 0) MTPSET = 1 43800014 CALL IEKCGW 43900014 IF(LENGTH .NE. 0) GO TO 1180 44000014 IF(NDELM .EQ. NGPMK) GO TO 1165 44100014 IF(NDELM.NE.NCOMA)GO TO 13 44200018 CALL IEKCPX 44300014 ADJCD (NPUT) = 26 44400014 GO TO 1070 44500014 C BRANCH TO SET ERROR IF ILLEGAL 44520018 C DELIMITER ENCOUNTERED. 44540018 1090 IF(NSUBC.EQ.0.AND.NDELM.NE.NCOMA.AND.NDELM.NE.NLFPR.AND.NDELM.NE. 44560018 *NRTPR.AND.NDELM.NE.NGPMK.AND.NDELM.NE.NEQ)GO TO 13 44580018 IF(NSUBC.GT.0.AND.NDELM.NE.NCOMA.AND.NDELM.NE.NLFPR.AND.NDELM.NE. 44600018 *NRTPR.AND.NDELM.NE.NPLUS.AND.NDELM.NE.NMIN.AND.NDELM.NE.NASTR.AND.44620018 *NDELM.NE.NSLAS.AND.NDELM.NE.NEQ.AND.NDELM.NE.NPER)GO TO 13 44640018 IF(NDELM.EQ.NEQ)GO TO 1120 44660018 C CALL CSORN 44700014 CALL IEKCCR 44800014 IF(NDELM.NE.NLFPR) GOTO 1100 44900014 C BRANCH IF ARRAY 45000017 IF(LAND (TYP (IDCTPT),M2R3) .EQ. 2) GO TO 1098 45200014 C BRANCH IF IN PRINT,PUNCH,READ OR45210017 C WRITE. 45220017 IF(NCARD(4).EQ.39.OR.NCARD(4).EQ.40.OR.NCARD(4).EQ.44.OR.NCARD(4) 45230017 *.EQ.51) GO TO 1092 45240017 C BRANCH IF NOT STRUCTURED. 45250017 IF(.NOT.TBIT(BYA(IDCTPT),0)) GO TO 11801 45300015 C 45304021 C IF DICTIONARY ENTRY FOR THE VARIABLE WAS JUST 45308021 C CREATED AND IT IS IN A SUBSCRIPT FOLLOWED BY A 45312021 C PAREN , THEN RESET THE TYPE TO FUNCTION. 45316021 C 45320021 1092 IF ((TYP(IDCTPT) .EQ. 0 .OR. TYP(IDCTPT) .EQ. 1) .AND. 45324021 C NSUBC .GT. 0 .AND. IOSWG .EQ. 1 .AND. DIS(IDCTPT) .EQ. 45328021 C 2**(IDOLEV-1+NDOLEV)) TYP(IDCTPT)=4 45332021 C 45336021 C IF IT IS A FUNCTION OR AN ASF IN A SUBSCRIPT, IT IS 45340021 C GOOD. BRANCH TO CONTINUE. 45344021 C 45348021 IF(NSUBC .GT. 0 .AND. IOSWG .EQ. 1 .AND. (TYP(IDCTPT) .EQ. 4 45352021 C .OR. TYP(IDCTPT) .EQ. 12 .OR. TYP(IDCTPT) .EQ. 6 .OR. 45356021 C TYP(IDCTPT) .EQ. 14)) GO TO 1098 45360021 C 45364021 C ERRORS 45368021 C IF DICTIONARY ENTRY FOR VARIABLE WAS JUST CREATED 45372021 C (NOT PREVIOUSLY USED) TYPE IT AS EXTERNAL FUNCTION 45376021 C AND GENERATE ERROR.OTHERWISE JUST GENERATE ERROR. 45380021 C 45384021 IF(DIS(IDCTPT) .GT. 2**(IDOLEV-1+NDOLEV)) GO TO 167 45388021 TYP(IDCTPT)=4 45392021 GO TO 167 45396021 1098 JSUB = 1 45400014 1100 IF(NDELM.NE.NCOMA.AND.NDELM.NE.NGPMK.AND.NDELM.NE.NLFPR.AND.NDELM.45500014 * NE.NRTPR.OR.(NDELM.EQ.NRTPR.AND.NPRVDL.EQ.NCOMA.AND.NSUBC.NE. 45600014 * 0).OR.NPRVDL.NE.NCOMA.OR.NSUBC.GT.0) GO TO 1110 45700014 IF(ADJCD(LPUT).NE.247.AND.ADJCD(LPUT).NE.5) GO TO 1105 45800014 ADJCD (NPUT) = 26 45900014 MTPSET = 1 46000014 C CALL PUTX 46100014 CALL IEKCPX 46200014 1105 ADJCD (NPUT) = 247 46300014 1110 IF (NDELM.EQ.NGPMK) GO TO 1165 46400014 1115 IF(NDELM.EQ.NRTPR.AND.NSUBC.EQ.0) GOTO 1086 46500014 C CALL PUTX 46600014 CALL IEKCPX 46700014 IF(NDELM.EQ.NRTPR) NSUBC=NSUBC-1 46800014 IF(LENGTH .EQ. 0.AND.NDELM.EQ.NCOMA.AND.NSUBC.EQ.0) ADJCD(NPUT) 46900014 * = 247 47000014 IF(JSUB.EQ.0) GOTO 1070 47100014 ADJCD (NPUT) = 22 47200014 IF( TTYP(LPUT) .EQ. 4 .OR. TTYP(LPUT) .EQ. 6) ADJCD(NPUT)=15 47250021 NSUBC=NSUBC+1 47300014 JSUB=0 47400014 GOTO 1070 47500014 C GENERATE ENDO ARITH 47600014 C CALL CSORN 47700014 1120 CALL IEKCCR 47800014 IF(NPRVDL.NE.NCOMA) GOTO 1025 47900014 N=1 48000014 1125 IF(IMPDOD(2,N).EQ.IDCTPT .AND. IMPDOD(5,N).NE.0) GO TO 1130 48100014 N=N+1 48200014 IF (N.LE.NL) GO TO 1125 48300014 C UNDIMENSIONED LIST ARRAY 48400014 1180 MSGNO=163 48500014 GOTO 5000 48600014 11801 IBYA=BYA(IDCTPT) 48610015 IBYB=BYB(IDCTPT) 48620015 IF(LAND(IBYA,40).NE.0.OR.LAND(IBYB,17).NE.0) GO TO 167 48630015 TYP(IDCTPT)=4 48640015 GO TO 1098 48650015 1130 IF(ADJCD (LPUT) .EQ. 26) GO TO 1135 48700014 ADJCD (NPUT) = 26 48800014 MTPSET = 1 48900014 C CALL PUTX 49000014 CALL IEKCPX 49100014 C CALL GENDO 49200014 1135 NERSW = 4 49300014 IDOLEV = N 49400014 CALL IEKDCL 49500014 NERSW = 0 49600014 NLEVEL=NLEVEL-1 49700014 DO1145 I=1,6 49800014 1145 IMPDOD(I,N)=0 49900014 IF(NLEVEL.EQ.1) GOTO 1155 50000014 C CALL GETWD 50100014 1150 CALL IEKCGW 50200014 IF(LENGTH.NE.0) GOTO 1150 50300014 IF(NDELM.EQ.NRTPR) GOTO 1150 50400014 ADJCD (NPUT) = 247 50500014 IF(NDELM.EQ.NCOMA) GOTO 1070 50600014 1025 MSGNO=158 50700014 GOTO 5000 50800014 1151 NBEGPT=NSCNPT 50802018 LENGTH=0 50804018 13 NBEGPT=NBEGPT+LENGTH 50807018 MSGNO=13 50814018 GO TO 5000 50821018 167 MSGNO=167 50830015 GO TO 5000 50860015 1155 NPRCNT=0 50900014 C CALL GETWD 51000014 1160 CALL IEKCGW 51100014 IF(NDELM.EQ.NGPMK) GOTO 1025 51200014 IF(NDELM.NE.NRTPR) GOTO 1160 51300014 1164 IF(NCDIN(NSCNPT).NE.NGPMK) GO TO 1170 51400016 1165 IF(NDELM.EQ.NGPMK) NSCNPT=NSCNPT-1 51500014 IMDOSW=0 51600014 IF(ADJCD (NPUT) .EQ. 8) ADJCD (NPUT) = 26 51700014 IF (ADJCD(NPUT).NE.9) GO TO 9999 51800014 1185 MSGNO=160 51900014 GOTO 5000 52000014 C CALL GETWD 52100014 1170 CALL IEKCGW 52200014 IF(LENGTH.NE.0) GOTO 1175 52300014 IF(NDELM.EQ.NRTPR) GO TO 1164 52400016 ADJCD (NPUT) = 247 52500014 GOTO 1070 52600014 1175 MSGNO=176 52700014 C CALL ERROR 52800014 5000 NERSW = 6 52900014 CALL IEKCDP 53000014 9999 RETURN 53100014 END 53200014 ./ ADD SSI=01000042,NAME=IEKCDP,SOURCE=0 C SUBROUTINE DSPTCH 00100014 SUBROUTINE IEKCDP 00200014 C 502700 21507 00220018 C0184261000 16557 00250016 C0124169000-170000,502000,571000 15078 00270016 C1357685200-685600 16961 00280017 C2282134200-134800,571600-571700 19044 00290017 C2840134820-134920,168900-169500 000C 00295017 C3061087500,137300-137600,155500,167200-167600,173500,174200, 19469 00296017 C 502200 19469 00297017 C3134634500,638000,666100-666800 000C 00298017 C3230128200-128600,200100-200500,710000,709600-710200 20837 00299018 C 136600,652200-652800 23395 00299319 C 684100-684700 23391 00299619 C 502700 0000D 00299719 C 134100,134500-134600,134890-134900,178000-179000 23408 00299819 C 656200,657200 28140 00299919 C 075000,123500,633700-634000,684630-684660 000F 00349920 C 502100,614000,666820-667420,684770-685120 LL43501 00369921 C 077100-077600 LL48448 00379921 C A653200-653800,C655600 LL51359 00389921 C A502800 LL56189 00399921 C DICTIONARY LAYOUT 00400014 C 00500014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00600014 LOGICAL*1 BYA,BYB,BYC 00700014 INTEGER*2 DIS,MDD,TYP 00800014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00900014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01000014 * NAM1,NAM2,NAM3,NAM4 01100014 C 01200014 C 01300014 C LABEL LAYOUT 01400014 C 01500014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 01600014 LOGICAL*1 COMP,DN 01700014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 01800014 C 01900014 C 02000014 C INTERMEDIATE TEXT LAYOUT 02100014 C 02200014 LOGICAL * 1 ADJCD 02300014 INTEGER * 2 TMOD,TTYP 02400014 INTEGER TXTCHN,TPTR 02500014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 02600014 C 02700014 COMMON /IEKAAA/ NPTR (2,35) 02800014 COMMON /IEKAER/ NERTBL (2,50) 02900014 C 03000014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 03100014 INTEGER SLIMS 03200014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 03300014 *M2R3,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 03400014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 03500014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 03600014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 03700014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 03800014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 03900014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 04000014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 04100014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 04200014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 04300014 C 04400014 EQUIVALENCE (NPTR (1,9), NPUT) 04500014 DIMENSION IP10A (21) 04600014 EQUIVALENCE (IP10A (1),SLIMS (1,1)) 04700014 DIMENSION INIT10(66) 04800014 EQUIVALENCE (NAME(1),INIT10(1)) 04900014 C 05000014 DIMENSION NERR10(36) 05100014 EQUIVALENCE (NNT,NERR10(1)) 05200014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC05300014 C C05400014 C DSPTCH - IEKCDP C05500014 C C05600014 C C05700014 C FUNCTION - DSPTCH INITIALIZE PHASE 10 STATEMENT PROCESSING. IF A C05800014 C STATEMENT HAS A LABEL IT MAKES A DICTIONARY ENTRY. IT THEN C05900014 C PASSES CONTROL TO THE APPROPRIATE TRANSLATING ROUTINE C06000014 C DEPENDING ON THE CLASS CODE RETURN FROM GETCD. C06100014 C C06200014 C CALLED BY - XARITH, RTPRQT, GRPKEQ, PERLOG, MINSLS, COMAST, TXTBLD C06300014 C C06400014 C CALLS - XDO, XGO, XIF, PUTX, XDIM, XEND, XEXT, XFMT, CLOSE, ERROR, C06500014 C GETCD, GETWD, XASGN, XBLOK, XCONT, XDATA, XEQUI, XIMPC, XIOOP C06600014 C XPUSE, XRETN, XSTOP, XTYPE, LABTLU, COMPAT, SYMTLU, SYSDIR, C06700014 C XBCKRW, XCLASS, XCOMON, XNMLST, XSTRUC, XSUBPG C06800014 C C06900014 C COMMON - ERCOM, BLANK, PH10, P10A C07000014 C C07100014 C ERRORS - 36, 52 C07200014 C 07300014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC07400014 GO TO (1275,1045,1035,1010,1025,1270,1270),NERSW 07500020 ENTRY IEKCIN 07600014 IF( LAND(NPTR(2,11),32768) .NE. 0 ) CALL PHAZSS 07700014 C 07710021 C TURN OFF BIT 0 OF IPREDL WHICH IS USED TO 07720021 C INDICATE THAT CGC WAS ENTERED THIS COMPILATION. IT IS 07730021 C SET IN CGC 07740021 C 07750021 IPREDL=BITOFF(IPREDL,0) 07760021 IGOLAB = 0 07800014 IDPERR = 0 07900014 DO 100 M=1,8 08000014 100 NIMPCT(2,M) = 5 08100014 DO 200 M = 9, 14 08200014 200 NIMPCT(2,M) = 3 08300014 DO 300 M = 15, 26 08400014 300 NIMPCT(2,M) = 5 08500014 NCARD (4) = 0 08550014 NMODET (8) = 7 08600014 NGENLB = 100000 08700014 NLB=0 08750017 ISN = 1 08800014 IDOLEV = 1 08900014 DO 400 M=1,66 09000014 400 INIT10(M) = 0 09100014 IMPDOD(1,9) = 0 09200014 IMPDOD (6,20) = 0 09300014 DO 1000 J =1,20 09400014 DO 1000 I=1,3 09500014 1000 IASFTB(I,J) = 0 09600014 C INITIALIZE PUSHDOWN TABLE 09700014 NDOPDN(1,1)=0 09800014 C CALL GETCOR 09900014 CALL IEKAGC (0) 10000014 NPTR (2,28) = NPUT 10100014 LPUT = 0 10200014 DO 995 I = 1,26 10300014 995 IP10A (I) = 0 10400014 CALL IEKAGC (1) 10500014 C CALL CLOSE 10600014 NCLSTX = 1 10700014 C CALL PUTX 10800014 CALL IEKCPX 10900014 C GENERATE LABEL FOR ADCON 11000014 1005 LBSWG=1 11100014 C CALL LABTLU 11200014 CALL IEKCLT 11300014 MTPSET = -1 11400014 ADJCD (NPUT) = 223 11500014 IF (IGOLAB.EQ.1) GO TO 1039 11600014 C CALL PUTX 11700014 CALL IEKCPX 11800014 IF(NDATSG .NE. 0) TPTR (NDATSG) = ILABPT 11900014 NDATSG =0 12000014 IF(IFTRLG.EQ.2) GOTO 1030 12100014 ADJCD (LPUT) = 222 12200014 1010 NTST=0 12300014 NERSW = 0 12350020 1015 NXTRN=0 12400014 C SAVE PREVIOUS CLASS CODE 12500014 NPTR(1,2) = NCARD(4) 12600014 C CALL GETCD 12700014 1020 CALL IEKCGC 12800014 C BRANCH TO SET ERROR IF ENTRY IN MAIN 12820018 IF(NCARD(4).EQ.22.AND.NPTR(1,31).EQ.0.AND.NPTR(2,31).EQ.0) 12840018 * GO TO 203 12860018 IF (NEXCSG.EQ.1.AND.NPTR(1,2).NE.22) NSUBRG=0 12900014 C INITIALIZE FIRST SCAN 13000014 C SET CURRENT ISN 13100014 ISN = NCARD(2) 13200014 C CALL GETWD 13300014 CALL IEKCGW 13400014 NONEX=0 13410019 C BRANCH IF TYPE STATEMENT. 13420017 IF(NCARD(4).EQ.6.OR.NCARD(4).EQ.11.OR.NCARD(4).EQ.30 13440017 1.OR.NCARD(4).EQ.35.OR.NCARD(4).EQ.45 ) NONEX=1 13450019 IF( NONEX.EQ.1 ) GOTO 1035 13460019 C 13480017 C BRANCH IF SPECIFICATION,DEFINE FILE,DATA, 13482017 C EXTERNAL OR NAMELIST STATEMENT. 13484017 IF(NCARD(4).EQ.7.OR.NCARD(4).EQ.14.OR.NCARD(4).EQ.19.OR.NCARD(4) 13486017 1.EQ.13.OR.NCARD(4).EQ.17.OR.NCARD(4).EQ.20.OR.NCARD(4).EQ.36) 13488017 2 NONEX=1 13489019 IF( NONEX.EQ.1 ) GOTO 1030 13490019 C 13492017 IF ((NPTR(1,2).EQ.27.OR.NPTR(1,2).EQ.43).AND.IFTRLG.NE.2.AND. 13500014 *NCARD (3).EQ.0.AND.NCARD(4).NE.23.AND.ADJCD(NPUT).NE.223.AND. 13600014 *NCARD(4).NE.22.AND.ADJCD(LPUT).NE.223) GOTO 1038 13660019 IF(ADJCD(NPUT).EQ.223.AND.NPTR(1,2).EQ.27.AND.NCARD(4).EQ.25.AND. 13730017 *NLB.NE.1)NGENSV=ILABPT 13760017 C CHECK IT TRAILER SWITCH 13800014 1025 IF(IFTRLG.EQ.1) GOTO 1220 13900014 IF(IFTRLG.EQ.2) GOTO 1225 14000014 C INSURE LABEL FOLLOWS ARITH IF 14100014 IF(NPTR(1,2).EQ.32) GOTO 1225 14200014 C CHECK ENDO SWITCH 14300014 1030 IF(NDOSG.EQ.1.AND.IFTRLG.NE.2) GOTO 1230 14400014 C CHECK FOR PRESENCE OF LABEL 14500014 1035 IF (NCARD(3).EQ.0) GO TO 1041 14600014 NERSW=0 14700014 N = NCARD(4) 14800014 IF (N.GT.56) GO TO 1045 14900014 GO TO (1037,1037,1040,1040,1037,1040,1040,1037,1037,1040,1040, 15000014 *1037,1040,1040,1037,1040,1040,1037,1040,1040,1037,1040,1040, 15100014 *1040,1037,1037,1037,1040,1040,1040,1037,1037,1040,1040,1040, 15200014 *1040,1040,1037,1037,1037,1040,1037,1037,1037,1040,1040,1040), N 15300014 1037 CONTINUE 15400014 C SET UP FOR LABEL HANDLING 15500014 IF(NLB.EQ.1.AND.NCARD(4).NE.25)NLB=0 15550017 NDOLRT=NSCNPT 15600014 NSCNPT = 1 15700014 1240 NERSW = 8 15800014 GO TO 1265 15900014 1040 MSGNO = 225 16000014 GO TO 10399 16100014 1038 IGOLAB = 1 16200014 GO TO 1005 16300014 1039 IGOLAB = 0 16400014 MSGNO = 224 16500014 10399 IDPERR = 1 16600014 GO TO 1270 16700014 1048 ILABPT=NGENSV 16720017 NLB=0 16740017 GO TO 1049 16760017 C CLEAR POINTER TO BRANCH TABLE FALL THROUGH LABEL 16800014 1041 IF(NPTR(1,2).EQ.27 .AND.(NCARD(4).EQ.6.OR.NCARD(4).EQ.30 16860016 ..OR.NCARD(4).EQ.35.OR.NCARD(4).EQ.45.OR.NCARD(4).EQ.11.OR.NCARD(4)16890017 ..EQ.7.OR.NCARD(4).EQ.14.OR.NCARD(4).EQ.19.OR.NCARD(4).EQ.13.OR. 16920017 .NCARD(4).EQ.17.OR.NCARD(4).EQ.20.OR.NCARD(4).EQ.36)) GO TO 1042 16950017 NCOMEX = 0 16980016 1042 IMPDOD(6,20) = 0 17040016 C NO LABEL NEED GEN LABEL PUT AWAY FOR GO TO 17100014 IF(NPTR (1,2) .NE. 43 .AND.NPTR (1,2) .NE. 27) GO TO 1043 17200014 IF(ADJCD (NPUT) .NE. 223) GO TO 1043 17300014 IF(NLB.EQ.1.AND.NPTR(1,2).EQ.27)GO TO 1048 17350017 1049 MTPSET=-1 17420017 C CALL PUTX 17500014 CALL IEKCPX 17600014 1043 I = NCARD (4) 17700014 IF( NONEX.EQ.1 .OR. I.EQ.25 ) GOTO 1050 17800019 C IF STATEMENT IS NON EXECUTABLE SKIP LABEL PLUGGING FOR BEGIN DO 17900019 IF(NBEGDO.EQ.1) GOTO 1245 18000014 C SET UP FOR CLASS CODE SCAN 18100014 1045 I = NCARD(4) 18200014 C SET FOR KEYWORD ROUTINES 18300014 C BRANCH TO ROUTINES 18400014 1050 GOTO (1090,1095,1100,1105,1110,1115,1133,1105,1060,1105,1115,1200,18500014 *1176,1131,1060,1060,1140,1145,1132,1155,1095,1105,1159,1105,1165,118600014 *010,1170,1105,1178,1115,1185,1185,1105,1115,1115,1177,1010,1190,1218700014 *00,1200,1105,1095,1205,1200,1115,1105,1179,1210,1010,1010,1200,10618800014 *0,1060,1060,1010,1080,1055,1010,1060,1010,1075,1077), I 18900014 1055 MSGNO = 35 19000014 GO TO 1270 19100014 C ERROR CONDITIONS 19200014 1060 MSGNO=36 19300014 GOTO 1270 19400014 1075 MSGNO=52 19500014 GOTO 1270 19600014 1077 MSGNO = 6 19700014 GO TO 1270 19800014 60 MSGNO = 60 19900014 GO TO 1270 20000014 C RESTORE PREVIOUS CLASS CODE 20010018 203 NCARD(4)=NPTR(1,2) 20020018 ISN=NCARD(2) 20030018 MSGNO=203 20040018 GO TO 1270 20050018 C ARITHMETIC STATEMENT 20100014 C 20200014 C FOLLOWING CALL TO GETWD ACCESSES THE 20300014 C FIRST ELEMENT. 20400014 C 20500014 C CALL GETWD 20600014 1080 CALL IEKCGW 20700014 C 20800014 C IF THE ELEMENT ACCESSED IS A 20900014 C VARIABLE, BRANCH. 21000014 C 21100014 IF(NACCSV .EQ. 2) GO TO 10101 21200014 C 21300014 MSGNO = 34 21400014 C 21500014 GO TO 1270 21600014 C 21700014 C SET NEW DELIMITER TO AN EQUAL SIGN 21800014 C TO FORCE SETTING OF STORE BIT. 21900014 C 22000014 10101 ISVNDL = NDELM 22100014 C 22200014 NDELM = NEQ 22300014 C 22400014 CALL IEKCS3 22500014 C 22600014 NDELM = ISVNDL 22700014 C 22800014 C IF THE VARIABLE WAS NOT PREVIOUSLY 22900014 C USED AS A FUNCTION, BRANCH. 23000014 C 23100014 IF(TYP (IDCTPT) .LT. 4) GO TO 10151 23200014 C 23300014 167 MSGNO = 167 23400014 C 23500014 GO TO 1270 23600014 C 23700014 C IF THE VARIABLE IS NOT DELIMITED BY A23800014 C LEFT PAREN, BRANCH. 23900014 C 24000014 10151 IF(NDELM .NE. NLFPR) GO TO 30251 24100014 C 24200014 C IF THE VARIABLE IS DIMENSIONED OR IS 24300014 C STRUCTURED, BRANCH. 24400014 C 24500014 IF(LAND (TYP (IDCTPT),M2R3) .EQ. 2 .OR. TBIT (BYA (IDCTPT),0)) 24600014 * GO TO 30201 24700014 C 24800014 C VARIABLE IS FOLLOWED BY A LEFT PAREN,24900014 C AND IS NOT DIMENSIONED OR STRUCTURED.25000014 C A STATEMENT FUNCTION DEFINITION IS 25100014 C ASSUMED. 25200014 C 25300014 IF(NEXCSG.NE.1) GO TO 11761 25400014 MSGNO=147 25500014 GO TO 1270 25600014 C FOLLOWING ENTERS A CODE INTO THE25700014 C COMMUNICATION AREA WHICH 25800014 C INDICATES THAT AN ASF IS BEING 25900014 C HANDLED. 26000014 11761 NPTR (1,8) = 4 26100014 C INITIALIZE NPUTSV BEFORE 26120016 C STARTING ASF PROCESSING 26140016 NPUTSV=NPUT 26160016 C IF THE VARIABLE WAS NOT 26200014 C PREVIOUSLY USED, BRANCH. 26300014 IF(NTRYMD .EQ. 1) GO TO 11781 26400014 C IF THE VARIABLE WAS USED 26500014 C PREVIOUSLY, OTHER THAN 26600014 C BEING TYPED, BRANCH TO SET 26700014 C THE ERROR. 26800014 I=BYA(IDCTPT)-65 26900015 IF(I + BYB (IDCTPT) + BYC (IDCTPT) .GT. 0) GO TO 167 27000014 11781 CONTINUE 27100014 C INITIALIZE SEQUENCE NUMBER 27200014 NSSEQ=1 27300014 C SET TYPE OF THE FUNCTION NAME 27400014 C TO ASF 27500014 TYP (IDCTPT) = 6 27600014 C SAVE THE ADDRESS OF THE 27700014 C DICTIONARY ENTRY FOR THE 27800014 C FUNCTION NAME 27900014 KSV1 = IDCTPT 28000014 C FOLLOWING CALL TO GETWD ACCESSES28100014 C THE FIRST ENEXTN ARGUMENT 28200014 C CALL GETWD 28300014 20051 CALL IEKCGW 28400014 C FOLLOWING INSURES THAT THE 28500014 C ARGUMENT IS A VARIABLE. IF IT IS28600014 C A DELIMITER OR CONSTANT, THE 28700014 C APPROPRIATE ERROR MESSAGE NUMBER28800014 C IS SET, AND ERROR IS CALLED TO 28900014 C PROCESS THE ERROR 29000014 IF(NACCSV .EQ. 2) GO TO 20201 29100014 MSGNO = 143 29200014 GO TO 1270 29300014 C THE ARGUMENT IS A VARIABLE. 29400014 C THE FOLLOWING CALL TO COMPAT HAS29500014 C THE VARIABLE PACKED IN NAME 29600014 C CALL COMPAT 29700014 20201 CALL IEKCS1 29800014 C SET SEQUENCE NUMBER IN THE 29900014 C ASF TABLE 30000014 IASFTB(1,NSSEQ) = NSSEQ 30100017 C SET ARGUMENT NAME IN THE ASF 30200014 C TABLE 30300014 IASFTB(2,NSSEQ) = NAME(3) 30350017 IASFTB(3,NSSEQ)=NAME(4) 30400014 C FOLLOWING SETS A SWITCH ON TO 30500014 C INDICATE TO OTHER ROUTINES THAT 30600014 C AS ASF IS BEING PROCESSED 30700014 ISAVE2=1 30800014 C FOLLOWING COMPARES THE DELIMITER30900014 C FOLLOWING THE ARGUMENT TO A 31000014 C COMMA 31100014 IF (NDELM.NE.NCOMA) GO TO 20351 31200014 C DELIMITER IS A COMMA INDICATING 31300014 C THE PRESENCE OF ANOTHER ARGUMENT31400014 C INCREMENT SEQUENCE NUMBER 31500014 NSSEQ=NSSEQ+1 31600014 C FOLLOWING INSURES THAT THE 31700014 C NUMBER OF ARGUMENTS WILL NOT 31800014 C EXCEED 20, THE MAXIMUM ALLOWABLE31900014 C NUMBER. IF IT DOES, BRANCH TO 32000014 C RECORD THE ERROR. 32100014 C BRANCH TO PORCESS NEXT ARGUMENT 32200014 IF(NSSEQ .LT. 21) GO TO 20051 32300014 C STATEMENT CONTAINED MORE THAN 32400014 C 20 ARGUMENTS. 32500014 C SET ERROR MESSAGE NUMBER, CLEAR 32600014 C THE ASF TABLE, AND BRANCH TO 32700014 C CALL ERROR 32800014 20251 MSGNO = 144 32900014 DO 20301 I = 1,20 33000014 DO 20301 J = 1,3 33100014 20301 IASFTB (J,I) = 0 33200014 GO TO 1270 33300014 C DELIMITER FOLLOWING THE ARGUMENT33400014 C IS NOT A COMMA 33500014 C FOLLOWING INSURES THAT IT IS A 33600014 C RIGHT PAREN, THE ONLY OTHER 33700014 C VALID DELIMITER AT THIS POINT 33800014 20351 IF(NDELM .EQ. NRTPR) GO TO 20401 33900014 MSGNO = 145 34000014 GO TO 1270 34100014 C FOLLOWING CALL TO GETWD ACCESSES34200014 C THE ELEMENT FOLLOWING THE RIGHT 34300014 C PAREN.-- THIS ELEMENT MUST BE AN34400014 C EQUAL SIGN 34500014 C CALL GETWD 34600014 20401 CALL IEKCGW 34700014 C INSURE THE ELEMENT IS AN 34800014 C EQUAL SIGN DELIMITER. 34900014 IF(LENGTH .EQ. 0 .AND. NDELM .EQ. NEQ) GO TO 20421 35000014 MSGNO = 146 35100014 GO TO 1270 35200014 20421 NPUTSV = NPUT 35300014 NPUT = SLIMS (1,1) 35400014 C THE STATEMENT, UP TO THIS POINT 35500014 C IS SYNTACTICALLY CORRECT. 35600014 C SET AN OPENING PAREN FOR TEXT 35700014 20501 ADJCD (NPUT) = 25 35800014 C SET THE NUMBER OF ARGUMENTS INTO35900014 C THE DICTIONARY ENTRY FOR THE 36000014 C FUNCTION NAME 36100014 DIS (IDCTPT) = NSSEQ 36200014 10451 NERSW = 1 36300014 90000 CALL IEKCAR 36400014 C 36500014 C IF THE VARIABLE IS DELIMITED BY AN 36600014 C EQUAL SIGN, BRANCH. 36700014 C 36800014 30251 IF(NDELM .EQ. NEQ) GO TO 30301 36900014 C 37000014 53 MSGNO = 53 37100014 C 37200014 GO TO 1270 37300014 C 37400014 C SET SWITCH INDICATING THAT AN ARRAY 37500014 C APPEARS ON THE LEFT OF AN EQUAL SIGN.37600014 C 37700014 30201 NLFARY = 1 37800014 C 37900014 C SET ADJECTIVE CODE FOR AN ARITHMETIC 38000014 C STATEMENT. 38100014 C 38200014 30301 ADJCD (NPUT) = 241 38300014 C 38400014 C CALL PUTX 38500014 CALL IEKCPX 38600014 C 38700014 C SET EXECUTABLE STATEMENT SWITCH ON. 38800014 C 38900014 NEXCSG = 1 39000014 C 39100014 C IF THE DELIMITER IS NOT AN EQUAL 39200014 C SIGN, BRANCH. 39300014 C 39400014 IF(NDELM .NE. NEQ) GO TO 3060 39500014 C IF THE VARIABLE WAS STRUCTURED, 39600014 C BRANCH TO SET THE ERROR. 39700014 C 39800014 IF(TBIT (BYA (IDCTPT),0)) GO TO 60 39900014 C 40000014 C IF THE VARIABLE WAS NOT DIMENSIONED, 40100014 C BRANCH. 40200014 C 40300014 30351 IF(LAND (TYP (IDCTPT),M2R3) .NE. 2) GO TO 10451 40400014 NERSW = 3 40500014 GO TO 90000 40600014 C ASSIGN 40700014 1090 NERSW = 1 40800014 GOTO 1160 40900014 C BACKSPACE,REWIND,ENDFILE 41000014 1095 NERSW = 5 41100014 GOTO 1160 41200014 C BLOCK DATA 41300014 1100 IF (NCDIN(15).EQ.NGPMK) GO TO 2010 41400014 MSGNO = 117 41500014 GOTO 1270 41600014 C INSURE FIRST STATEMENT OF PROGRAM 41700014 2010 IF(ISN.EQ.2) GOTO 2015 41800014 MSGNO = 120 41900014 GOTO 1270 42000014 C SET SWITCH IN COMUN AREA 42100014 2015 NPTR(1,30) = 1 42200014 C GENERATE TEXT ITEMS 42300014 ADJCD (LPUT) = 193 42400014 TMOD (LPUT) = 0 42500014 TTYP (LPUT) = 0 42600014 TPTR (LPUT) = 0 42700014 GOTO 3033 42800014 C FUNCTION,CALL,ENTRY,SUBROUTINE 42900014 C CALL XSUBPG 43000014 1105 CALL IEKCSR 43100014 IF(NPRCNT .GT. 0) GO TO 10451 43200014 GOTO 1010 43300014 C CONTINUE 43400014 1110 M = NCARD(1) 43500014 IF (NCDIN(M).EQ.NGPMK) GO TO 3005 43600014 MSGNO = 207 43700014 IDPERR = 2 43800014 GO TO 1270 43900014 C TEST IF LABEL ON STATEMENT 44000014 3005 IF(NXTRN.NE.0) GOTO 3010 44100014 MSGNO = 208 44200014 IDPERR = 3 44300014 GO TO 1270 44400014 C CONTINUE AS NORMAL - WARNING ERROR 44500014 3010 ADJCD (NPUT) = 211 44600014 MTPSET = 1 44700014 C CALL PUTX 44800014 CALL IEKCPX 44900014 C CALL CLOSE 45000014 3033 NCLSTX = 1 45100014 C CALL PUTX 45200014 CALL IEKCPX 45300014 GOTO 1010 45400014 C COMPLEX,REAL,LOG,INT,ETC 45500014 C CALL XTYPE 45600014 1115 NERSW = 1 45700014 GO TO 11401 45800014 C DIMENSION 45900014 1131 NERSW = 1 46000014 GO TO 1130 46100014 C EQUIVALENCE 46200014 1132 NERSW = 2 46300014 GO TO 1130 46400014 C COMMON 46500014 1133 NERSW = 3 46600014 C CALL XSPECS 46700014 1130 CALL IEKCSP 46800014 GO TO 41010 46900014 C DATA 47000014 1140 NERSW = 2 47100014 C CALL XDATA 47200014 11401 CALL IEKCDT 47300014 GO TO 41010 47400014 C DO 47500014 C CALL XDO 47600014 1145 CALLIEKCDO 47700014 GOTO 1010 47800014 C EXTERNAL 47900014 C CALL GETWD 48000014 1155 CALL IEKCGW 48100014 C TEST IF ITEM NUMERIC OR ALPHA 48200014 IF(NACCSV.NE.2) GOTO 4035 48300014 C CALL COMSYM 48400014 CALL IEKCS3 48500014 C SET PROPER USAGE BITS 48600014 BYA (IDCTPT) = BITON (BYA (IDCTPT),6) 48800014 TYP (IDCTPT) = 4 48900014 C 48910014 C IF THE NAME WAS PASSED AS AN ARGUMENT48920014 C RESET THE TYPE TO DUMMY EXTERNAL 48930014 C FUNCTION. 48940014 C 48950014 IF(TBIT (BYB (IDCTPT),0)) TYP (IDCTPT) = 12 48960014 IF(NDELM.EQ.NCOMA) GOTO 1155 49000014 IF(NDELM .EQ. NGPMK) GO TO 41010 49100014 C ERROR INVALID DELIMITER 49200014 MSGNO = 91 49300014 GOTO 1270 49400014 C ERROR NON-ALPHA ITEM 49500014 4035 MSGNO = 90 49600014 GOTO 1270 49700014 C END 49800014 C RETURN TO SYS DIRECT 49900014 1159 NERSW = 7 50000014 C CALL XIOPST 50100014 1160 CALL IEKDIO 50200014 1011 CONTINUE 50210021 IF(NPTR(1,2).EQ.27.AND.NCARD(4).EQ.25.AND.ADJCD(NPUT).EQ.223)NLB=150220017 IF(NPTR(1,2).EQ.27.AND.NCARD(4).EQ.25)NCARD(4)=27 50250016 IF( NPTR(1,2).EQ.22 .AND. NCARD(4).EQ.25 ) NCARD(4)=22 50270019 IF(NPTR(1,2) .EQ. 43 .AND. NCARD(4) .EQ. 25)NCARD(4)=43 50280021 GO TO 1010 50300014 C FORMAT 50400014 1165 NERSW = 3 50500014 GOTO 1160 50600014 C GO TO 50700014 C CALL XGO 50800014 1170 CALL IEKCGO 50900014 IF (NDOSG.EQ.0.OR.NCARD(4).EQ.56) GO TO 1010 51000014 IF(NDOSG.EQ.1.AND.IFTRLG.EQ.0) GOTO 1235 51100014 GOTO 1010 51200014 C IF 51300014 1185 NEXCSG = 1 51400014 C INSURE LOG IF NOT TRAILER 51500014 IF (NCARD(4).EQ.31.AND.NPTR(1,2).EQ.31) GO TO 5030 51600014 IF(NCDIN (NCARD (1)) .EQ. NLFPR) GO TO 5005 51700014 C ERROR NO LEFT PAREN 51800014 MSGNO = 140 51900014 GOTO 1270 52000014 5005 NIF = NIF + 1 52100014 NPRCNT = 1 52200014 ADJCD (NPUT) = 244 52300014 IF(NCARD (4) .EQ. 32) ADJCD (NPUT) = 243 52400014 MTPSET = 1 52500014 C CALL PUTX 52600014 CALL IEKCPX 52700014 C TEST TO SEE IF TRAILER 52800014 IF(NIF.EQ.2) GOTO 5042 52900014 LIFTXL = LPUT 53000014 GO TO 10451 53100014 5030 MSGNO = 139 53200014 GOTO 1270 53300014 5042 LSTXX = LPUT 53400014 GO TO 10451 53500014 C DEFINE FILE 53600014 1176 NERSW = 4 53700014 GO TO 1180 53800014 C NAMELIST 53900014 1177 NERSW = 1 54000014 GOTO 1180 54100014 C IMPLICIT 54200014 1178 NERSW = 2 54300014 GOTO 1180 54400014 C STRUCTURE 54500014 1179 NERSW = 3 54600014 C INSURE THAT THE 'XL' PARAMETER HAS 54620015 C BEEN SPECIFIED 54640015 IF(.NOT. TBIT (NPTR (1,3),22)) GO TO 1060 54660015 C CALL XTNDED 54700014 1180 CALL IEKCTN 54800014 GO TO 41010 54900014 C PAUSE 55000014 1190 NERSW = 4 55100014 GOTO 1160 55200014 C I/O OPERATIONS 55300014 C CALL XIOOP 55400014 1200 CALL IEKCIO 55500014 IF(IOSWG.NE.1) GOTO 1010 55600014 GOTO 1260 55700014 C RETURN 55800014 1205 NERSW = 2 55900014 GOTO 1160 56000014 C STOP 56100014 1210 NERSW = 6 56200014 GOTO 1160 56300014 C 56400014 C SPECIFICATION STATEMENT COMPLETED. 56500014 C IF THE PREVIOUS STATEMENT WAS AN 56600014 C ENTRY STATEMENT, RESET PRESENT 56700014 C CLASS CODE TO ENTRY TO INSURE 56800014 C VALID LABEL PLUG (NSUBRG). 56900014 C 57000014 41010 IF(NPTR (1,2) .EQ. 22) NCARD (4) = 22 57100014 IF(NPTR(1,2).EQ.27)NCARD(4)=27 57150016 IF(NPTR(1,2).EQ.32)NCARD(4)=32 57160017 IF(NPTR(1,2).EQ.43)NCARD(4)=43 57170017 GO TO 1010 57200014 1220 IFTRLG = 2 57300014 IF (NCARD(4).EQ.27) GO TO 1030 57400014 GOTO 1005 57500014 1225 IF (NCARD(4) .EQ. 22) GO TO 1226 57560016 NERSW = 5 57620016 GOTO 1265 57700014 1226 CALL IEKCSR 57730016 GO TO 1010 57760016 1230 NERSW=6 57800014 GOTO 1265 57900014 1235 NERSW=7 58000014 GOTO 1265 58100014 1245 NERSW=3 58200014 GOTO 1265 58300014 3060 NERSW = 5 58400014 GO TO 90000 58500014 1260 NERSW=2 58600014 GO TO 90000 58700014 C CALL XCLASS 58800014 1265 CALL IEKDCL 58900014 GOTO (1275,1045,1035,1010,1025,1030),NERSW 59000014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC59100014 C C59200014 C ERROR - IEKCER C59300014 C C59400014 C FUNCTION - ERROR BUILDS ERROR TABLE ENTRIES AND ENTERS THEM IN C59500014 C THE ERROR TABLE FOR ANY SYNTAX ERRORS ENCOUNTERED BY PHASE10 C59600014 C C59700014 C STATUS - CHANGE LEVEL 0 C59800014 C C59900014 C CALLED BY - SYMTLU, XARITH, XCLASS, XCONT, XSTOP, RTPRQT, XPUSE, C60000014 C GRPKEQ, PERLOG, XDATA, LITCON, XGO, XEQUI, DSPTCH, XNMLST, C60100014 C CSORN, XDO, CDOPAR, XBCKRW, XEXT, XFMT, LABTLU, XIF, C60200014 C INTCON, PUTX, XIOOP, XRETN, XSUBPG, XBLOK, XIMPC, XTYPE C60300014 C XDIM, XCOMON, XASF, XASF2, XASGN, XSTRUC C60400014 C C60500014 C C60600014 C COMMON - BLANK, PH10, P10A, ERCOM C60700014 C C60800014 C C60900014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC61000014 C ERROR ROUTINE 61100014 C IF WARNING MESSAGE, BRANCH. 61200014 1270 IF(MSGNO .GT. 200) GO TO 6018 61300014 1273 JWARN=0 61400021 C IF THE SOURCE OPTION IS NOT 61500014 C SPECIFIED, BRANCH. 61600014 IF(.NOT. TBIT (NPTR (1,3),31)) GO TO 6000 61700014 ICHAR = NBEGPT + 1 - NCARD (1) 61800014 C IF THE STATEMENT IS A DO AND 61900014 C AN ELEMENT BEYOND END-OF-RANGE 62000014 C STATEMENT HAS BEEN ACCESSED, 62100014 C ADJUST CHARACTER COUNT. 62200014 IF (NCARD(4).EQ.18.AND.ICHAR.GT.1) ICHAR = ICHAR-1 62300014 C IF THE STATEMENT IS AN ASSIGN, 62400014 C ADJUST CHARACTER COUNT. 62500014 IF (NCARD(4).EQ.1) ICHAR = ICHAR-2 62600014 C IF THE CHARACTER COUNT IS 62700014 C NEGATIVE (NO ELEMENT HAS BEEN 62800014 C ACCESSED), SET ICHAR TO 62900014 C INDICATE THE FIRST CHARACTER. 63000014 IF (ICHAR.LT.0) ICHAR = 1 63100014 WRITE(6,301) ICHAR 63200014 301 FORMAT (' ERROR DETECTED - SCAN POINTER =',I4) 63300014 6000 IF( NERSW.NE.7 ) NDELM = NGPMK 63370020 IF(NDOSG.EQ.1.AND.NDOLEV.NE.0)GO TO 6017 63450017 C IF A STATEMENT FUNCTION IS IN 63500014 C ERROR, RESET THE TYPE OF THE 63600014 C S F NAME TO EXTERNAL. 63700014 6001 IF(ISAVE2 .EQ. 1) TYP (KSV1) = 4 63800017 IF(ISAVE2 .EQ. 1) NPUT = NPUTSV 63900014 DO 501 M=1,36 64000014 501 NERR10(M) = 0 64100014 C OBTAIN CLASS CODE. 64200014 NCC = NCARD(4) 64300014 C IF THE STATEMENT IN ERROR IS A 64400014 C FUNCTION STATEMENT, ZERO 64500014 C FUNCTION SUBPROGRAM SWITCH. 64600014 IF (NCC.EQ.4.OR.NCC.EQ.10.OR.NCC.EQ.24.OR.NCC.EQ.28.OR.NCC.EQ.33.O64700014 *R.NCC.EQ.41) NPTR(1,31)=0 64800014 C IF THE STATEMENT IS A SUBROUTINE64900014 C STATEMENT,ZERO SUBROUTINE SW. 65000014 IF (NCC.EQ.46) NPTR(2,31)=0 65100014 IF(NBEGDO .EQ. 0) GO TO 6010 65200014 C IF PRESENT FLAGGED STMT IS DATA,FORMAT, OR 65220019 C NAMELIST AND PREVIOUS STMT WAS A DO, LET 65240019 C NBEGDO=1 FOR LABEL PLUGGING ON FOLLOWING STMT. 65260019 IF(NCC.EQ.17.OR.NCC.EQ.25.OR.NCC.EQ.36) GOTO 6010 65280019 NBEGDO=0 65300014 C 65320021 C IF NDOLEV IS 26 DO NOT ATTEMPT TO ZERO OUT NDOPDN 65340021 C 65360021 IF(NDOLEV .EQ. 26) GO TO 6002 65380021 DO 6005 I = 1,6 65400014 6005 NDOPDN (I,NDOLEV) = 0 65500014 6002 IF (NDOLEV .GT. 1) NDOLEV=NDOLEV-1 65560021 C IF ERROR IN IMPLIED DO -- 65620019 6010 IF(IDOLEV.EQ.1)GOTO 6012 65640019 DO 6011 I=1,6 65660019 DO 6011 J=1,20 65680019 6011 IMPDOD(I,J)=0 65700019 6012 IDOLEV=1 65720019 NTAB=NPTR(1,8) 65800014 IF(NTAB .EQ. 0) GO TO 6020 65900014 IF(NTAB.GT.4) NTAB=NTAB-10 66000014 IF(LFPUTS (2,NTAB) .NE. 0) GO TO 6015 66100014 IF(NTAB.EQ.1) NPTR(2,27)=0 66200014 IF(NTAB.EQ.2) NPTR(2,32)=0 66300014 IF(NTAB.EQ.3) NPTR(1,32)=0 66400014 6015 NPTR (1,8) = 0 66500014 GO TO 6025 66600014 6017 NDOSAV=NDOLEV 66610017 DO 6016 I=1,NDOSAV 66620017 IF(NDOPDN(1,I).NE.LABSAV)GO TO 6016 66630017 NDOLEV=NDOLEV-1 66640017 DO 6021 J=1,6 66650017 6021 NDOPDN(J,I)=0 66660017 6016 CONTINUE 66670017 GO TO 6001 66680017 C 66682021 C IF IT IS ERROR 740(MISSING LEFT PAREN 66684021 C IN FORMAT STMT), DO NOT TREAT AS WARNING. BRANCH 66686021 C TO HANDLE AS ERROR. 66688021 C 66690021 6018 IF(MSGNO .EQ. 740 .AND. NDELM .EQ. NGPMK) GO TO 1273 66692021 JWARN=1 66742021 GO TO 6025 66800014 6020 LPUT = LASTEM 66900014 N = TXTCHN (LASTEM) 67000014 IF(MOD24 (N) .EQ. 0) GO TO 6025 67100014 IF(ADJCD (N) .EQ. 223 .OR. ADJCD (N) .EQ. 222) LPUT = MOD24 (N) 67200014 6025 NPTR (2,35) = 5 67300014 N=NPTR(2,22) 67400014 NPTR(2,22)=NPTR(2,22)+1 67500014 IF(N .GT. NPTR (1,12)) GO TO 6030 67600014 NERTBL(1,N)=MSGNO 67700014 NERTBL(2,N)=ISN 67800014 6030 IF(JWARN .EQ. 0) GO TO 6035 67900014 IF(IDPERR .EQ. 0) GO TO 9999 68000014 I = IDPERR 68100014 IDPERR = 0 68200014 IF(I - 2) 1041,3005,3010 68300014 6035 IF(MSGNO .EQ. 112) CALL IEKAA9 (99) 68400014 C ON RETURNING FROM DCL AFTER PROCESSING END 68410019 C DO OF INCORRECTLY NESTED DO LOOP,IF END 68420019 C CARD READ IN BUT END TXT NOT YET GENERATED 68430019 C BRANCH 68440019 1275 IF( NCARD(4).EQ.23 .AND. NERSW.EQ.1 68450019 1 .AND. ADJCD(NPUT).NE.249 ) GOTO 1035 68460019 IF( NERSW.EQ. 7 ) GO TO 9999 68465020 NERSW=0 68470019 C 68477021 C IF FORMAT ERROR, NO CALL TO IBERH NEEDED.GO 68484021 C TO GET NEXT CARD. 68491021 C 68498021 IF(MSGNO .EQ. 740) GO TO 1011 68505021 C 68512021 C IF PROCESSING END STATEMENT, 68520017 C EXIT GRACEFULLY. 68540017 IF(NCARD(4).EQ.23) GO TO 9999 68560017 C PLACE CALL TO IBERR IN TEXT 68600014 ADJCD (NPUT) = 246 68700014 IDCTPT = NPTR (1,25) + 288 68800014 BYA (IDCTPT) = 66 68900014 MTPSET=0 68950016 CALL IEKCPX 69000014 C CALL PUTX 69100014 C PLACE ISN IN DICTIONARY 69200014 NAME(4)=ISN 69300014 NSHFT1 = 5 69400014 LENGTH=14 69500014 C CALL SYMTLU 69600014 CALL IEKCS2 69700014 BYA (IDCTPT) = 64 69800014 C PLACE ISN TO TEXT 69900014 ADJCD (NPUT) = 15 70000014 C CALL PUTX 70100014 CALL IEKCPX 70200014 C SET CLOSING PAREN TO TEXT 70300014 ADJCD (NPUT) = 5 70400014 MTPSET = 1 70500014 C CALL PUTX 70600014 C CLOSE TEXT 70700014 9997 CALL IEKCPX 70800014 GO TO 3033 70900014 9999 IF(MSGNO.EQ.203) GO TO 1010 70960018 RETURN 71020018 END 71100014 ./ ADD SSI=01000042,NAME=IEKCDT,SOURCE=0 C SUBROUTINE XDATYP 00100014 C 179600 0000A 00150015 SUBROUTINE IEKCDT 00200014 C 449000,448600-449200 12267 00230015 C 571000 12267 00260015 C1490089500,436100-436600,437300,446080-446880,566300-566600, 19699 00270018 C1490568500,639600-640200 19699 00280018 C0381089500,436900,446190-446280,446560-446640,567300,570500 000D 00290018 C0800346300,346600,348000 21473 00295018 C 435200-435800 000D 00297018 C 566800 000D 00298018 C 435900,566900-567000 19699 00299018 C 377600-378200 24243 00299519 C 051200,322060-322160 20.1 34253 00304520 C 640000-646000 20.1 30405 00309620 C 350500,550500,578500 20.1 32766 00319720 C 446185-446210 20.1 0000G 00339720 C A550100-550400,D550500,A552200-552800,A639030-639060 LL48993 00345721 C D639100-639500,D639700,A639900 LL48993 00351721 C D446800,A446730-446800 LL52756 00355721 C A442090-442900,C443400,C640100 LL52780 00357721 C C437000,A446002-446056 LL54389 00358721 C A451200-451600,C597000 LL55883 00359221 C A435920-435980 LL52757 00359621 C 00359720 C DICTIONARY LAYOUT 00400014 C 00500014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00600020 LOGICAL*1 BYA,BYB,BYC 00700014 INTEGER*2 DIS,MDD,TYP 00800020 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00900014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01000014 * NAM1,NAM2,NAM3,NAM4 01100020 C 01200014 C 01300014 C 01400014 C DIMENSION ENTRY LAYOUT 01500014 C 01600014 INTEGER ASIZE,DIM1 01700014 INTEGER*2 ELGTH,NDIM 01800014 STRUCTURE // ASIZE,NDIM,ELGTH,DIM1 01900014 C 02000014 C INTERMEDIATE TEXT LAYOUT 02100014 C 02200014 LOGICAL * 1 ADJCD 02300014 INTEGER * 2 TMOD,TTYP 02400014 INTEGER TXTCHN,TPTR 02500014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 02600014 C 02700014 COMMON /IEKAAA/ NPTR (2,35) 02800014 COMMON /IEKAER/ NERTBL (2,50) 02900014 C 03000014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 03100014 INTEGER SLIMS 03200014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 03300014 *NBLK,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 03400014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 03500014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 03600014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 03700014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 03800014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 03900014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 04000014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 04100014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 04200014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 04300014 C 04400014 EQUIVALENCE (NPTR (1,9), NPUT) 04500014 INTEGER*2 NOPTS,NSTNS,NOPTM,NSTNM 04600014 DIMENSION NOPTS(4),NSTNS(4),NOPTM(4),NSTNM(4) 04700014 DATA NOPTS/2,8,16,1/,NSTNS/4,4,8,4/,NOPTM/4,6,8,2/,NSTNM/5,7,9,3/ 04800014 LOGICAL*1 NSIZE 04900014 DIMENSION NSIZE(8) 05000014 DATA NSIZE/1,4,2,4,8,4,16,8/ 05100014 DATA MASK3/Z0000FFFF/ 05120020 INTEGER*2 SMOD,STYP 05150016 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 05200014 C C 05300014 C THIS ROUTINE PROCESSES DATA AND TYPE STATEMENTS C 05400014 C C 05500014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 05600014 C 05700014 C IF THE STATEMENT IS THE TRAILER 05800014 C OF A LOGICAL IF STATEMENT, 05900014 C BRANCH TO SET THE ERROR. 06000014 C --NCDINE1,2N CONTAINS THE 06100014 C PREVIOUS CLASSIFICATION CODE. 06200014 C CLASS CODE--LOG.-IF 6 31. 06300014 IF(NPTR(1,2).EQ.31) GOTO 1005 06400014 C BRANCH IF DATA 06500014 IF (NERSW.EQ.2) GO TO 2000 06600014 C 06700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC06800014 C C 06900014 C C 07000014 C C07100014 C XTYPE - IEKDTP C07200014 C C07300014 C STATUS - CHANGE LEVEL 1 07400014 C C 07500014 C FUNCTION - XTYPE CHECKS THE TYPE STATEMENT FOR SYNTAX AND GENERATES C07600014 C THE NECESSARY TEXT AND INFORMATION TABLE ENTRIES. EINITIAL C07700014 C VALUES ARE TRANSLATED BY XDATA.N C07800014 C C07900014 C CALLED BY - DSPTCH C08000014 C C08100014 C CALLS - XDIM, CLOSE, ERROR, GETWD, XDATA, SYMTLU, COMPAT, INTCON C08200014 C C08300014 C COMMON - BLANK, PH10 C08400014 C C08500014 C ERRORS - 94, 95, 96, 92, 194, 93, 139 C08600014 C C08700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC08800014 C 08900014 NTDTSW=0 09000014 ITYP2=0 09100014 C REAL = 2 09200014 III = 2 09300014 C IF THE TYPE IS DOUBLE PRECISION,09400014 C BRANCH TO TREAT IT AS REAL * 8. 09500014 IF (NCARD(4).EQ.11) GO TO 1050 09600014 IF (NCARD(4).NE.6) GO TO 2015 09700014 C IF THE TYPE IS COMPLEX, SET THE 09800014 C CALL INDICATOR TO 1. 09900014 NPTR(1,23) = 1 10000014 C COMPLEX = 3 10100014 III = 3 10200014 GO TO 1020 10300014 C INTEGER = 1 10400014 2015 IF (NCARD(4).EQ.30) III = 1 10500014 C LOGICAL = 4 10600014 IF (NCARD(4).EQ.35) III = 4 10700014 C IF THE NEW DELIMITER IS NOT AN 10800014 C ASTERISK, INDICATING THE LENGTH 10900014 C SPECIFICATION IS OMITED, BRANCH.11000014 1020 IF (NDELM.NE.NASTR) GO TO 1055 11100014 C LENGTH IS SPECIFIED. 11200014 C FOLLOWING CALL TO GETWD ACCESSES11300014 C THE LENGTH SPECIFICATION. 11400014 C CALL GETWD 11500014 CALL IEKCGW 11600014 C IF IT IS NOT NUMERIC, BRANCH TO 11700014 C SET THE ERROR. 11800014 IF (NACCSV.NE.1) GO TO 1022 11900014 C SET SWITCH INDICATING THAT 12000014 C XTYPE IS THE CALLING ROUTINE. 12100014 NTYPEX=2 12200014 C CALL LITCON TO HAVE THE LENGTH 12300014 C SPECIFICATION CONVERTED TO ITS 12400014 C BINARY EQUIVALENT. 12500014 C -UPON RETURN, THE CONVERTED 12600014 C CONSTANT IS IN NACCM. 12700014 C CALL LITCON 12800014 CALL IEKCLC 12900014 C IF CONSTANT IS NOT AN INTEGER, 13000014 C ERROR. 13100014 IF (NNT.EQ.1) GO TO 1023 13200014 1022 MSGNO = 14 13300014 GO TO 1010 13400014 C RESET SWITCH 13500014 1023 NTYPEX = 0 13600014 C IF EITHER THE STANDARD OR 13700014 C OPTIONAL PERMISSIBLE LENGTH FOR 13800014 C ITS ASSOCIATED TYPE WAS NOT 13900014 C SPECIFIED, SET THE ERROR. 14000014 IF (NACCM.NE.NOPTS(III).AND.NACCM.NE.NSTNS(III)) GO TO 2025 14100014 ITYP2 = NACCM 14200014 GO TO 1055 14300014 2025 MSGNO = 95 14400014 GOTO 1010 14500014 C DOUBLE PRECISION WAS SPECIFIED. 14600014 C SET LENGTH SPECIFICATION TO 8. 14700014 1050 ITYP2=8 14800014 C SAVE THE POINTER TO THE VARIABLE14900014 C WHICH IS BEING TYPED. 15000014 1055 NBEGSV=NSCNPT 15100014 C FOLLOWING CALL TO GETWD ACCESSES15200014 C THE NAME. 15300014 C CALL GETWD 15400014 CALL IEKCGW 15500014 C IF THE ELEMENT ACCESSED IS NOT A15600014 C VARIABLE, BRANCH TO SET THE 15700014 C ERROR. 15800014 IF (NACCSV.NE.2) GO TO 2005 15900014 C FOLLOWING CALL TO COMSYM HAS THE16000014 C VARIABLE PACKED, ONE CHARACTER 16100014 C PER BYTE AND RIGHT JUSTIFIED, IN16200014 C NAME AND THE 16300014 C DICTIONARY ENTRY FOR THE 16400014 C VARIABLE GENERATED, OR RETRIEVED16500014 C CALL COMSYM 16600014 CALL IEKCS3 16700014 C IF NEW DICT ENTRY HAS JUST 16710016 C BEEN MADE - BRANCH 16720016 IF(NTRYMD.EQ.1) GO TO 1060 16730016 SMOD=MDD(IDCTPT) 16740016 STYP=TYP(IDCTPT) 16750016 C FOLLOWING HANDLES THE SETTING OF16800014 C THE MODE IN THE DICTIONARY ENTRY16900014 C FOR THE VARIABLE NAME. 17000014 C FIRST THE LENGTH FOLLOWING THE 17100014 C NAME IS 17200014 C CHECKED. IF SPECIFIED, IT IS 17300014 C USED. IF NOT, THE LENGTH 17400014 C FOLLOWING THE KEYWORD IS CHECKED17500014 C IF SPECIFIED, IT IS USED. IF NOT17600014 C THE STANDARD LENGTH FOR THE 17700014 C SPECIFIED TYPE IS USED. 17800014 1060 MDD(IDCTPT)=NSTNM(III) 17860016 C IF THE NEW DELIMITER IS AN 18000014 C ASTERISK, INDICATING THE LENGTH 18100014 C IS SPECIFIED, BRANCH. 18200014 IF (NDELM.EQ.NASTR) GO TO 1095 18300014 IF (ITYP2.EQ.0) GO TO 1100 18400014 ITYP3 = ITYP2 18500014 GO TO 1097 18600014 C LENGTH IS SPECIFIED. 18700014 C FOLLOWING CALL TO GETWD ACCESSES18800014 C THE LENGTH SPECIFICATION. 18900014 C CALL GETWD 19000014 1095 CALL IEKCGW 19100014 C IF IT IS NOT A CONSTANT BRANCH 19200014 C TO SET THE ERROR. 19300014 IF (NACCSV.NE.1) GO TO 1025 19400014 C CALL LITCON TO HAVE THE LENGTH 19500014 C SPECIFICATION CONVERTED TO ITS 19600014 C BINARY EQUIVALENT. 19700014 C -UPON RETURN, THE CONVERTED 19800014 C CONSTANT IS IN NACCM. 19900014 C CALL LITCON 20000014 CALL IEKCLC 20100014 C IF CONSTANT IS NOT AN INTEGER, 20200014 C BRANCH. 20300014 IF (NNT.NE.1) GO TO 1022 20400014 IF (NACCM.NE.NOPTS(III).AND.NACCM.NE.NSTNS(III)) GO TO 1025 20500014 C FOLLOWING SETS ITYP3 TO THE 20600014 C PERMISSIBLE LENGTH SPECIFIED. 20700014 ITYP3 = NACCM 20800014 1097 IF (ITYP3.EQ.NOPTS(III)) MDD(IDCTPT) = NOPTM(III) 20900014 C IF THE VARIABLE WAS PREVIOUSLY 21000014 C DIMENSIONED, BRANCH. 21100014 1100 IF (MOD24(PDI(IDCTPT)).NE.0) GO TO 1175 21200014 IF (TYP(IDCTPT).EQ.5) TYP(IDCTPT) = 0 21300014 C IF THE NEW DELIMITER IS NOT A 21400014 C LEFT PAREN, INDICATING THAT THE 21500014 C VARIABLE IS NOT DIMENSIONED, 21600014 C BRANCH. 21700014 IF (NDELM.NE.NLFPR) GO TO 2215 21800014 C SET SWITCH TO INDICATE TO XDIM 21900014 C THAT XTYPE IS THE CALLING 22000014 C ROUTINE. 22100014 NTYPEX=1 22200014 C SAVE THE ADDRESS OF THE 22300014 C VARIABLE'S ENTRY. 22400014 NSAVE = IDCTPT 22500014 C FOLLOWING CALL TO XDIM HAS THE 22600014 C SUBSCRIPTS HANDLED. 22700014 C CALL XDIM 22800014 NERSW = 0 22900014 CALL IEKCSP 23000014 C IF CALL BY VALUE BIT IS OFF, 23100014 C BRANCH. 23200014 IF (.NOT.TBIT(BYB(NSAVE),0)) GO TO 2170 23300014 C SET CALL BY VALUE BIT OFF. 23400014 BYB(NSAVE) = BITOFF(BYB(NSAVE),0) 23500014 C SET CALL BY NAME BIT ON. 23600014 BYB (NSAVE) = BITON (BYB (NSAVE),1) 23700014 C RESET SWITCH 23800014 2170 NTYPEX = 0 23900014 C ACCESS NEXT ELEMENT 24000014 C CALL GETWD 24100014 CALL IEKCGW 24200014 C BRANCH IF DELIMITER. 24300014 C OTHERWISE, SET THE ERROR. 24400014 IF(LENGTH.EQ.0) GO TO 1174 24500016 MSGNO=96 24600014 GOTO 1010 24700014 C RESET DICTIONARY POINTER 24720016 C BACK TO VARIABLE NAME 24740016 1174 IDCTPT=NSAVE 24760016 GO TO 2215 24780016 C IF THE VARIABLE IS A STMNT. 24800014 C FUNCTION NAME, BRANCH. 24900014 1175 IF (TYP(IDCTPT).EQ.6) GO TO 2215 25000014 C IF THE NEW DELIMITER IS A LEFT 25100014 C PAREN, INDICATING THAT THE 25200014 C VARIABLE IS BEING REDIMENSIONED,25300014 C SET THE ERROR. 25400014 IF (NDELM.NE.NLFPR) GO TO 1177 25500014 MSGNO = 202 25600014 C CALL ERROR 25700014 NERSW = 6 25800014 CALL IEKCDP 25900014 C SKIP DIMENSION INFORMATION 26000014 C CALL GETWD 26100014 1233 CALL IEKCGW 26200014 IF (NDELM.NE.NRTPR) GO TO 1233 26300014 C ACCESS NEXT ELEMENT 26400014 C CALL GETWD 26500014 CALL IEKCGW 26600014 C SAVE ADDRESS OF THE DIMENSION 26700014 C INFORMATION FOR THE VARIABLE. 26800014 1177 N = PDI (IDCTPT) 26900014 C SET LENGTH ACCORDING TO MODE 27000014 NM = NSIZE(MDD(IDCTPT)-1) 27100014 C IF PREVIOUS MODE EQUALS NEW 27200014 C MODE, BRANCH. 27300014 IF (ELGTH(N).EQ.NM) GO TO 2215 27400014 C IF THE ARRAY SIZE IS ZERO, 27500014 C INDICATING THAT THE ARRAY WAS 27600014 C DIMENSIONED USING 27700014 C ADJ. DIMENSIONS, BRANCH. 27800014 IF (ASIZE(N).EQ.0) GO TO 1185 27900014 C MODE HAS BEEN CHANGED. 28000014 C FOLLOWING RECOMPUTES THE ARRAY 28100014 C SIZE. 28200014 I = 3 28300014 K1 = ASIZE (N) 28400014 K2 = ELGTH (N) 28500014 ASIZE (N) = NM * K1 / K2 28600014 M = NDIM (N) 28700014 IF(M.EQ.1) GOTO 1185 28800014 C FOLLOWING RECOMPUTES THE 28900014 C DIMENSION FACTORS. 29000014 C SAVE DICTIONARY POINTER 29020016 C TO VARIABLE. 29040016 LDCTPT=IDCTPT 29060016 2180 ML = ASIZE(N+4*I-4) 29100014 NAME(3)=0 29200014 K4 = NAM4 (ML) 29300014 K5 = ELGTH (N) 29400014 NAME(4)=NM*K4/K5 29500014 LENGTH=14 29600014 NSHFT1 = 5 29700014 C CALL SYMTLU 29800014 CALL IEKCS2 29900014 C SET THE BIT INDICATING THAT THE 30000014 C CONSTANT IS REFERENCED. 30100014 BYA (IDCTPT) = BITON (BYA (IDCTPT),1) 30200014 ASIZE (N + 4 * I - 4) = IDCTPT 30300014 I=I+1 30400014 M=M-1 30500014 IF (M.GT.1) GO TO 2180 30600014 C RESET DICTIONARY POINTER 30620016 C FOR MULTIPLE DEFINITIONS CHECK. 30640016 IDCTPT=LDCTPT 30660016 C RESET THE NEW MODE. 30700014 1185 ELGTH (N) = NM 30800014 C IF NEW DICT ENTRY HAS JUST 30808016 C BEEN MADE - BRANCH 30816016 2215 IF(NTRYMD.EQ.1) GO TO 2217 30824016 C CHECK TYPING OF SUBROUTINE OR 30832016 C FUNCTION NAME 30840016 IF (NPTR(1,31) .NE. NPTR(2,31)) GO TO 2218 30848016 2216 IF((SMOD.NE.MDD(IDCTPT).OR.STYP.NE.TYP(IDCTPT)).AND. 30856016 .(TBIT(BYA(IDCTPT),7).OR.DIS(IDCTPT).GE.1) 30864016 ..AND..NOT.TBIT(BYA(IDCTPT),0)) GO TO 92 30872016 C SET SPECIFICATION BIT ON 30880016 2217 BYA(IDCTPT)=BITON(BYA(IDCTPT),7) 30888016 C IF THE NEW DELIMITER IS A COMMA,30900014 C INDICATING ANOTHER VARIABLE, 31000014 C BRANCH. 31100014 IF(NDELM.EQ.NCOMA) GO TO 1055 31200016 C IF THE NEW DELIMITER IS A SLASH,31300014 C INDICATING INITIAL DATA, BRANCH.31400014 IF (NDELM.EQ.NSLAS) GO TO 2195 31500014 C IF THE NEW DELIMITER IS NOT AN 31600014 C END MARK, THE ONLY OTHER VALID 31700014 C DELIMITER AT THIS POINT, BRANCH 31800014 C TO SET THE ERROR. 31900014 IF(NDELM.NE.NGPMK) GOTO 1225 32000014 IF(NTDTSW .NE. 0) GO TO 1220 32100014 GOTO 9999 32200014 2218 NAM3XX=LAND(NAM3(IDCTPT),MASK3) 32206020 IF(NPTR(1,10) .NE. NAM3XX .OR. NPTR(2,10) .NE. NAM4(IDCTPT)) 32212020 .GO TO 2216 32220016 C TYPING FUNCTION NAME 32230016 IF(NPTR(1,31).NE.0) GO TO 2217 32240016 C TYPING SUBROUTINE NAME - ERROR 32250016 GO TO 92 32260016 C FOLLOWING HAS INITIAL DATA 32300014 C VALUES PROCESSED BY XDATA. 32400014 2195 NSCNPT = NBEGSV 32500014 NTYPEX = 1 32600014 IF(NTDTSW.EQ.1) NTYPEX=2 32700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC32800014 C C32900014 C XDATA - IEKCDT C33000014 C C33100014 C FUNCTION - XDATA CHECKS SYNTAX AND GENERATES INFORMATION TABLE C33200014 C AND TEXT ENTRIES FOR THE DATA STATEMENT AND FOR DATA C33300014 C SPECIFICATIONS APPEARING IN TYPE STATEMENTS. ECOMPLEX C33400014 C LITERALS ARE TRANSLATED BY ARITH.N C33500014 C C33600014 C CALLED BY - DSPTCH, XTYPE C33700014 C C33800014 C CALLS - PUTX, CLOSE, CSORN, ERROR, GETWD, SYMTLU, INTCON C33900014 C C34000014 C COMMON - BLANK, PH10 C34100014 C C34200014 C ERRORS - 121, 122, 123, 124, 125, 127, 128, 129, 130, 132 C34300014 C C34400014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC34500014 C 34600014 C TEST IF ENOUGH SPACE FOR TEXT 34630018 2000 IF(SLIMS(1,1)+12.GT.SLIMS(2,1))CALL IEKAGC(1) 34660018 C TEST FOR PREVIOUS DATA TEXT 34700014 IF(NPTR (2,27) .EQ. 0) NPTR (2,27) = SLIMS (1,1) 34800018 1000 NCONT = 0 34900014 NZHXSW=0 35000014 NCPX = 0 35050020 IF (NTYPEX.NE.2) GO TO 2010 35100014 NTYPEX=1 35200014 ADJCD (SLIMS (1,1)) = 13 35300014 GOTO 1015 35400014 C SET DATA FOR TEXT 35500014 2010 NPTR(1,8) = 1 35600014 ADJCD (SLIMS (1,1)) = 205 35700014 TTYP (SLIMS (1,1)) = ISN 35800014 MTPSET = 1 35900014 C AND PUT AWAY 36000014 C CALL PUTX 36100014 CALL IEKCPX 36200014 ADJCD (SLIMS (1,1)) = 0 36300014 C GET VAR NAME 36400014 C CALL GETWD 36500014 1015 CALL IEKCGW 36600014 IF(NACCSV.EQ.2) GOTO 1030 36700014 MSGNO=121 36800014 GO TO 1025 36900014 C PUT VARIABLE TO DICT 37000014 C CALL COMSYM 37100014 1030 CALL IEKCS3 37200014 C SET BIT FOR USE IN DATA STMNT 37300014 BYB (IDCTPT) = BITON (BYB (IDCTPT),7) 37400014 C IF FROM XTYPE FORGET SUBSCRIPTS 37500014 IF(NTYPEX.NE.0) GOTO 1080 37600014 C SEE IF NON-ARRAY ITEM HAS SUBSC 37700014 IF( NDELM.EQ.NLFPR .AND. TYP(IDCTPT).NE.2 .AND. TYP(IDCTPT).NE.3 )37760019 1 GOTO 1045 37820019 C CALL PUTX 37900014 1035 CALL IEKCPX 38000014 IF (NDELM.EQ.NLFPR) GO TO 1070 38100014 C IF SLASH GO HANDLE CONSTANTS 38200014 IF(NDELM.EQ.NSLAS) GOTO 1165 38300014 IF (NDELM.EQ.NCOMA) GO TO 1015 38400014 92 MSGNO=92 38420016 SMOD=0 38440016 STYP=0 38460016 GO TO 1025 38480016 1068 MSGNO = 123 38500014 GO TO 1025 38600014 1045 MSGNO=122 38700014 GOTO 1025 38800014 C SET SUBSCRIPT PAREN FOR TEXT 38900014 1070 ADJCD (SLIMS (1,1)) = 22 39000014 C OBTAIN SUBSCRIPT 39100014 C CALL GETWD 39200014 1075 CALL IEKCGW 39300014 IF (NACCSV.EQ.1) GO TO 1090 39400014 1078 MSGNO = 124 39500014 GOTO 1025 39600014 C SKIP TO DATA PORTION 39700014 1080 IF(NDELM.EQ.NSLAS) GOTO 1035 39800014 IF (NDELM.EQ.NLFPR) NCONT = NCONT+1 39900014 IF(NDELM.EQ.NRTPR) NCONT=NCONT-1 40000014 IF(NDELM.NE.NCOMA) GOTO 1085 40100014 IF(NACCSV.EQ.2.AND.NCONT.EQ.0) GOTO 1015 40200014 IF(LENGTH.EQ.0.AND.NCONT.EQ.0) GOTO 1015 40300014 C CALL GETWD 40400014 1085 CALL IEKCGW 40500014 GOTO 1080 40600014 C CONVERT AND PUT SUBSC AWAY 40700014 C CALL CSORN 40800014 1090 CALL IEKCCR 40900014 C MAKE SURE IT IS INTGR CNST 41000014 IF(MDD (IDCTPT) .NE. 5) GO TO 1078 41100014 C CREATE TEXT FOR SUBSC 41200014 C CALL PUTX 41300014 CALL IEKCPX 41400014 C COMMA - GO LOOK FOR MORE SUBSC 41500014 IF (NDELM.EQ.NCOMA) GO TO 1075 41600014 C RTPR -END OF SUBSC. 41700014 IF(NDELM.EQ.NRTPR) GOTO 1105 41800014 MSGNO=125 41900014 GO TO 1025 42000014 C PUT CLOSING PAREN TO TEXT 42100014 1105 ADJCD (SLIMS (1,1)) = 5 42200014 MTPSET = 1 42300014 C CALL PUTX 42400014 CALL IEKCPX 42500014 C CALL GETWD 42600014 CALL IEKCGW 42700014 IF (LENGTH.NE.0) GO TO 1068 42800014 IF (NDELM.NE.NCOMA) GO TO 1145 42900014 ADJCD (SLIMS (1,1)) = 9 43000014 GOTO 1015 43100014 1145 IF (NDELM.NE.NSLAS) GO TO 1068 43200014 C START ON CONSTANT PORTION 43300014 C CALL GETWD 43400014 1165 CALL IEKCGW 43500014 C 43520018 C ERROR IF NO DATA CONSTANT BETWEEN SLASHES 43540018 C 43560018 IF(NPRVDL.EQ.NSLAS.AND.NDELM.EQ.NSLAS.AND.LENGTH.EQ.0) GOTO 129 43580018 IF(NPRVDL.EQ.NPER.AND.NDELM.EQ.NPER.AND.LENGTH.EQ.0) GOTO 132 43590018 C CHECK FOR SYNTAX ERROR OF DOUBLE COMMAS 43592021 C 43594021 IF(NPRVDL .EQ. NCOMA .AND. NDELM .EQ. NCOMA .AND. LENGTH .EQ. 0) 43596021 * GO TO 132 43598021 IF(NPRVDL .EQ. NSLAS) ADJCD (SLIMS (1,1)) = 13 43600014 IF(NCARD(4).EQ.6.AND.(NDELM.EQ.NASTR.AND.(NPRVDL.EQ.NSLAS.OR. 43610018 *NPRVDL.EQ.NCOMA).OR.NDELM.EQ.NLFPR.AND.(NPRVDL.EQ.NASTR.OR.NPRVDL 43620018 *.EQ.NCOMA.OR.NPRVDL.EQ.NSLAS)))GO TO 1166 43630018 C BRANCH IF IN TYPE STATEMENT 43650020 IF( NCARD(4).EQ.6 .OR. NCARD(4).EQ.11 .OR. NCARD(4).EQ.30 .OR. 43670020 * NCARD(4) .EQ. 45) GO TO 1173 43700021 1166 IF(LENGTH.EQ.0) GO TO 1315 43730018 C LENGTH NOT ZERO - TEST FOR ALPHA43800014 IF(NACCSV.EQ.2) GOTO 1240 43900014 C CALL LITCON 44000014 CALL IEKCLC 44100014 IF (NHRETN.EQ.1) GO TO 1190 44200014 C 44209021 C IF LEFT PAREN FOLLOWS NUMBER, ERROR 44218021 IF( NDELM .NE. NLFPR ) GO TO 1169 44227021 C 44236021 C IF DATA STMT - ISSUE 132 44245021 C 44254021 IF(NTYPEX .EQ. 0) GO TO 132 44263021 C 44272021 C TYPE STMT - ISSUE 93 44281021 GO TO 1226 44290021 1169 IF(NDELM .EQ. NASTR ) GO TO 1170 44340021 C CALL SYMTLU 44400014 CALL IEKCS2 44500014 GO TO 1289 44600014 C 44600221 C BEFORE CHECKING FOR INVALID DELEMETERS, CHECK FOR 44600421 C HOLLERITH FOLLOWING THE SLASH IN A TYPE STMT. 44600621 C IF IT IS HOLLERITH, ANY DELEMETER FOUND CAN BE 44600821 C VALID, SO SKIP TESTS AND GO TO PROCESS HOLLERITH. 44601021 C 44601221 1173 IF(NPRVDL .NE. NSLAS .OR. NACCSV .NE. 1) GO TO 1167 44601421 C 44601621 C PREV DEL IS SLASH AND WE HAVE SCANNED A NUMBER. TEST 44601821 C FOR HOLLERITH 44602021 C SAVE POINTERS IN CASE IT IS NOT HOLLERITH 44602221 C 44602421 NSV1=NBEGPT 44602621 NSV2=NSCNPT 44602821 NSV3=NDELM 44603021 NSV4=NPRVDL 44603221 CALL IEKCLC 44603421 C 44603621 C IF HOLLERITH GO TO PROCESS IT 44603821 C 44604021 IF(NHRETN .EQ. 1) GO TO 1190 44604221 C 44604421 C RESET POINTERS FOR SCANNING 44604621 C 44604821 NBEGPT=NSV1 44605021 NSCNPT=NSV2 44605221 NDELM=NSV3 44605421 NPRVDL=NSV4 44605621 C CHECK FOR INVALID DELIMITER IN 44608018 C INITIALIZATION VALUES. 44616018 1167 IF((NPRVDL.EQ.NASTR.OR.NPRVDL.EQ.NSLAS).AND.NDELM.EQ.NCOMA.AND. 44619018 *LENGTH.NE.0.AND.NCDIN(NSCNPT).NE.NSLAS)GO TO 1168 44622018 IF(NPRVDL.EQ.NASTR.AND.NDELM.EQ.NQUOT.AND.LENGTH.EQ.0)GO TO 1168 44625018 IF((((NPRVDL.EQ.NSLAS.AND.NDELM.NE.NASTR.AND.NDELM.NE.NQUOT.OR. 44628018 *NPRVDL.EQ.NASTR).AND.NDELM.NE.NPER.AND.NDELM.NE.NLFPR.AND.NDELM 44632018 *.NE.NMIN.AND.NDELM.NE.NPLUS).OR.(NPRVDL.EQ.NPER.AND.NDELM.NE.NPLUS44640018 *.AND.NDELM.NE.NMIN).OR.NPRVDL.EQ.NRTPR.AND.NCARD(4).NE.6) 44648018 *.AND.NDELM.NE.NSLAS)GO TO 1225 44656018 1168 IF(NCARD(4).EQ.6.AND.NPRVDL.EQ.NRTPR.AND.NDELM.EQ.NCOMA) 44664018 *ADJCD(SLIMS(1,1))=9 44672018 C 44673021 C IF COMPLEX AND JUST SCANNED CONSTANT PART 44674021 C AND HAVE RT PAREN FOLLOWED BY COMMA, THEN 44675021 C BRANCH TO SCAN AGAIN. OTHERWISE CHECK WHAT WAS 44676021 C JUST SCANNED. IT WAS NOT A COMPLEX CONSTANT. 44677021 C 44678021 IF(NCARD(4) .EQ. 6 .AND. NPRVDL .EQ. NRTPR .AND. 44679021 C NDELM .EQ. NCOMA ) GO TO 1165 44680021 GO TO 1166 44688018 C IF ITEM (NUMERIC) HAS ASTER, IT 44700014 C IS ASSUMED MULTIPLE. IT IS CONV 44800014 1170 IF(NCDIN(NBEGPT-1).NE.NCOMA.AND.NCDIN(NBEGPT-1).NE.NSLAS)GOTO 132 44860015 IF(NNT .EQ. 1) GO TO 1297 44920015 MSGNO = 14 45000014 GO TO 1025 45100014 C 45120021 C UPDATE DICTIONARY POINTER 45140021 1181 NPTR(2,29)=NPTR(2,29)+4 45160021 1180 MSGNO = 47 45200014 GO TO 1025 45300014 C HOLLERITH FIELD PROCESSING 45400014 1190 IHCT = NACCM 45500014 IF (IHCT.GT.255) GO TO 1180 45600014 NHRETN = 0 45700014 C NBEGPT WOULD BE POINTING TO THE 45800014 C FIRST CHAR OF HOLLERITH STRING, 45900014 C AND IHCT CONTAINS FIELD COUNT. 46000014 C OBTAIN FIRST DICT POINTER 46100014 1195 IF ((NPTR(2,29)+(((IHCT+3)/4)*4)+4).GT.NPTR(2,30)) CALL IEKAGC(2) 46200014 I = NPTR(2,29) 46300014 L = NPTR (2,29) 46400014 CHN(I) = IHCT 46500014 I = I + 4 46600014 NPTR(2,29) = I 46700014 C PACK HOLL, 4 BYTES PER WORD 46800014 1210 K = 1 46900014 1215 CHN(I) = LOR(CHN(I),NCDIN(NBEGPT)*2**(32-8*K)) 47000014 NBEGPT = NBEGPT+1 47100014 K = K + 1 47200014 IHCT = IHCT-1 47300014 IF (IHCT.EQ.0) GO TO 2220 47400014 IF (K.LE.4) GO TO 1215 47500014 I = I+4 47600014 GO TO 1210 47700014 2220 NPTR(2,29) = I + 4 47800014 C AND PUT AWAY 47900014 TMOD(SLIMS(1,1)) = 10 48000014 IF(NZHXSW .EQ. 1) TMOD (SLIMS (1,1)) = 12 48100014 TTYP (SLIMS (1,1)) = 5 48200014 TPTR (SLIMS (1,1)) = L 48300014 MTPSET = 1 48400014 NZHXSW=0 48500014 C RESET POINTERS FOR GETWD 48600014 NDELM=NCDIN(NBEGPT) 48700014 NBEGPT=NBEGPT+1 48800014 NSCNPT=NBEGPT 48900014 GO TO 1289 49000014 1240 NAME(4) = 0 49100014 IF (LENGTH.NE.1) GO TO 1270 49200014 C 280 MEANS NOT T OR F 49300014 IF(NCDIN(NBEGPT).EQ.NIMPCT(1,20)) GOTO 1245 49400014 C 290 IS TRUE (T) 49500014 IF(NCDIN(NBEGPT).EQ.NIMPCT(1,6)) GOTO 1255 49600014 C 300 IS FALSE (F) 49700014 129 MSGNO = 129 49800014 GOTO 1025 49900014 1245 NAME(4) = 1 50000014 1255 LENGTH = 14 50100014 NSHFT1 = 3 50200014 C CALL SYMTLU 50300014 CALL IEKCS2 50400014 GO TO 1289 50500014 C THIS IS TRUE,FALSE OR OCTAL 50600014 1270 IF(NCDIN(NBEGPT).EQ.NIMPCT(1,20).AND.LENGTH.EQ.4) GOTO 1245 50700014 IF(NCDIN(NBEGPT).EQ.NIMPCT(1,6).AND.LENGTH.EQ.5) GOTO 1255 50800014 C WORD TRUE AND WORD FALSE ARE 50900014 C HANDLED JUST SAME AS 51000014 C T AND F 51100014 C INITIAL O, ASSUME OCTAL. 51200014 IF(NCDIN(NBEGPT).EQ.NIMPCT(1,15)) GOTO 1280 51300014 C INITIAL Z, ASSUME HEX. 51400014 IF(NCDIN(NBEGPT).EQ.NIMPCT(1,26)) GOTO 1275 51500014 IF(LENGTH.EQ.0) GOTO 1290 51600014 GO TO 129 51700014 C SET UP TO HANDLE HEX AS HOLL. 51800014 1275 IHCT=LENGTH-1 51900014 NBEGPT=NBEGPT+1 52000014 NZHXSW=1 52100014 GOTO 1195 52200014 C BUILD TEXT ENTRY FOR 52300014 C ZEROS OF OCTAL ENTRY 52400014 1280 NAME(4) = 0 52500014 LENGTH=14 52600014 NSHFT1 = 5 52700014 C CALL SYMTLU 52800014 CALL IEKCS2 52900014 MSGNO = 209 53000014 C CALL ERROR 53100014 NERSW = 6 53200014 CALL IEKCDP 53300014 GO TO 1289 53400014 C AND PUT INTO TEXT AS IMMED 53500014 C DATA WITH F (15) MODE 53600014 1297 TPTR(SLIMS(1,1)) = NACCM 53700014 TMOD (SLIMS (1,1)) = 15 53800014 MTPSET = 1 53900014 C CALL PUTX 54000014 1289 CALL IEKCPX 54100014 1290 IF (NDELM.EQ.NSLAS) GOTO 1345 54200014 GOTO 1165 54300014 1315 IF(NPRVDL.EQ.NQUOT.AND.NDELM.EQ.NSLAS) ADJCD(SLIMS(1,1)) = 13 54400014 IF (NDELM.NE.NLFPR) GO TO 1325 54500014 C HERE IS WHERE COMPLEX CONSTANTS 54600014 C WILL FIT IN 54700014 NCPX=1 54800014 C CALL GETWD 54900014 CALL IEKCGW 55000014 C 55010021 C IF IT SCANNED A VARIABLE- ERROR 55020021 C 55030021 IF(NACCSV .EQ. 2) GO TO 1206 55040021 C CALL CSORN 55100014 1305 CALL IEKCCR 55200014 C 55220021 C IF CCR FOUND HOLLERITH FIELD - ERROR 55240021 C 55260021 IF (NHRETN .EQ. 1) GO TO 1206 55280021 GO TO 1289 55300014 1325 IF (NDELM.NE.NPER) GOTO 1330 55400014 C IF PERIOD, CHECK FOR T OR F 55500014 C NEITHER, ASSUME NUMERIC. 55600014 IF(NCDIN(NBEGPT+1).EQ.NIMPCT(1,20).OR.NCDIN(NBEGPT+1).EQ.NIMPCT(1,55700014 *6)) GOTO 1165 55800014 GOTO 1305 55900014 1330 IF (NDELM.NE.NMIN) GOTO 1335 56000014 C IF MINUS, SET SWITCH. 56100014 NXSMNG = 1 56200014 GOTO 1165 56300014 C PLUS IS IGNORED 56400014 1335 IF(NDELM.EQ.NPLUS) GOTO 1165 56500014 IF (NDELM.NE.NCOMA) GOTO 1340 56600014 IF(NCARD(4).EQ.6.OR.NCARD(4).EQ.11.OR.NCARD(4).EQ.30.OR. 56630018 * NCARD(4).EQ.45) GOTO 1337 56680018 IF(NCARD(4).EQ.35.AND.(NPRVDL.EQ.NSLAS.OR.NPRVDL.EQ.NCOMA)) 56690018 *GOTO 1225 56700018 1336 ADJCD (SLIMS (1,1)) = 9 56730018 GOTO 1165 56800014 1337 IF(NPRVDL.EQ.NSLAS.OR.NPRVDL.EQ.NCOMA)GO TO 1225 56850018 1340 IF (NDELM.EQ.NQUOT) GO TO 1350 56900014 IF (NDELM.EQ.NSLAS) GOTO 1345 57000014 IF(NPRVDL.EQ.NQUOT.AND.NDELM.EQ.NCOMA)GO TO 1336 57050018 132 MSGNO = 132 57100015 GOTO 1025 57200014 C RETURN TO XTYPE 57300014 1345 IF (NTYPEX.EQ.1) GO TO 3000 57400014 C CALL GETWD 57500014 CALL IEKCGW 57600014 IF (LENGTH.NE.0) GO TO 1068 57700014 NPRCNT = 0 57800014 NCPX = 0 57850020 IF (NDELM.EQ.NGPMK) GO TO 1220 57900014 1348 IF (NDELM.NE.NCOMA) GO TO 1068 58000014 ADJCD (SLIMS (1,1)) = 13 58100014 GOTO 1015 58200014 C PROCESS QUOTE LITERALS 58300014 1350 N = NBEGPT+1 58400014 M = NPTR(2,29) 58500014 I = M+4 58600014 NPTR(2,29) = I 58700014 IHCT = 0 58800014 1355 K=1 58900014 IF (NPTR(2,29).LE.NPTR(2,30)) GO TO 1365 59000014 CALL IEKAGC(2) 59100014 GO TO 1350 59200014 1365 IF (NCDIN(N).EQ.NQUOT) GO TO 1380 59300014 1370 CHN(I) = LOR(CHN(I),NCDIN(N)*2**(32-8*K)) 59400014 IHCT = IHCT+1 59500014 N=N+1 59600014 IF (IHCT .GT. 255) GO TO 1181 59700021 K = K+1 59800014 IF (K.LE.4) GO TO 1365 59900014 I = I+4 60000014 NPTR(2,29) = NPTR(2,29)+4 60100014 GOTO 1355 60200014 1380 N=N+1 60300014 IF (NCDIN (N).EQ.NQUOT) GOTO 1370 60400014 C END OF QUOTE LITERAL 60500014 IF (K.NE.1) NPTR(2,29) = NPTR(2,29) + 4 60600014 IF(IHCT .EQ. 0) GO TO 129 60650014 CHN(M) = IHCT 60700014 TMOD(SLIMS(1,1)) = 10 60800014 TTYP (SLIMS (1,1)) = 5 60900014 TPTR(SLIMS(1,1)) = M 61000014 MTPSET = 1 61100014 C CALL PUTX 61200014 CALL IEKCPX 61300014 NBEGPT=N 61400014 NSCNPT=N 61500014 GOTO 1165 61600014 1005 MSGNO=139 61700014 C CALL ERROR 61800014 1025 NERSW = 6 61900014 CALL IEKCDP 62000014 GO TO 9999 62100014 C TURN DATA SWITCH ON 62200014 3000 NTDTSW = 1 62300014 NTYPEX=0 62400014 C ACCESS NEXT ELEMENT 62500014 C CALL GETWD 62600014 CALL IEKCGW 62700014 C ERROR IF NOT A DELIMITER 62800014 IF(LENGTH.NE.0) GOTO 1205 62900014 C IF THE NEW DELIMITER IS A COMMA,63000014 C INDICATING ANOTHER VARIABLE, 63100014 C BRANCH. 63200014 IF(NDELM.EQ.NCOMA) GOTO 1055 63300014 C IF THE NEW DELIMITER IS AN 63400014 C END MARK, BRANCH TO CLOSE. 63500014 C OTHERWISE, SET THE ERROR. 63600014 IF(NDELM.EQ.NGPMK) GOTO 1220 63700014 1205 MSGNO=194 63800014 GOTO 1010 63900014 1206 MSGNO=12 63903021 GO TO 1010 63906021 1229 CONTINUE 63960020 1225 NBEGPT=NBEGPT+LENGTH 63990021 1226 MSGNO=93 64040021 GOTO 1010 64100014 C 64200014 2005 MSGNO = 94 64300014 C CALL ERROR 64400014 1010 NERSW = 6 64500014 CALL IEKCDP 64600014 C CALL CLOSE 64700014 1220 NCLSTX = 1 64800014 C CALL PUTX 64900014 CALL IEKCPX 65000014 9999 CONTINUE 65100014 RETURN 65200014 END 65300014 ./ ADD SSI=21410025,NAME=IEKCGC,SOURCE=0 IEKCGC START 0 SUBROUTINE GETCD 00100014 * 000A 00150015 *3471359000 16288 00160016 *3471289000,291000,296000,298000 16278 00170016 *3471398000,471000,697000 000B 00180016 *2180291498-291546 19331 00190017 * 424200-424600 000D 00195018 * 258600,260300,261200-261800 23481 00197018 * 107000,123000-127000,399300-399600 000D 00198019 * 180300-180600 20.1 38340 00199020 * 076600-077200 LL45081 00199521 * 077400-077600,644100-644900 LL48448 00199721 ENTRY IEKAREAD 00200014 EXTRN IBCOM# 00300014 EXTRN FIOCS# 00400014 EXTRN IEKAAA 00600014 EXTRN IEKCAA 00700014 * 00800014 R EQU 14 00900014 L EQU 15 01000014 REG0 EQU 0 01100014 REG1 EQU 1 01200014 REG2 EQU 2 01300014 I EQU 3 01400014 J EQU 4 01500014 K EQU 5 01600014 * 01700014 ISNN EQU 0 01800014 LENGTH EQU 1 01900014 COUNT EQU 2 02000014 PARCNT EQU 3 02100014 CONCNT EQU 4 02200014 INX EQU 5 02300014 OUTX EQU 6 02400014 CALL EQU 7 02500014 CARD EQU 8 02600014 LINE EQU 9 02700014 NEXT EQU 10 02800014 INFO EQU 11 02900014 PH10R EQU 12 03000014 * 03100014 EQUAL EQU 8 03200014 NOTEQ EQU 7 03300014 HIGH EQU 2 03400014 LOW EQU 4 03500014 HIEQ EQU 10 03600014 ZERO EQU 8 03700014 NZERO EQU 7 03800014 ZMINUS EQU 12 03900014 ALL EQU 1 04000014 NONE EQU 8 04100014 ALWAYS EQU 15 04200014 * 04300014 CLEAR EQU X'80' 04400014 FRSTON EQU X'80' 04500014 FRSTFF EQU X'7F' 04600014 IFTRON EQU X'40' 04700014 IFTRFF EQU X'BF' 04800014 ARTHON EQU X'20' 04900014 ARTHFF EQU X'DF' 05000014 PARSON EQU X'10' 05100014 PARSFF EQU X'EF' 05200014 FRMTON EQU X'08' 05300014 FRMTFF EQU X'F7' 05400014 LSPCON EQU X'04' 05500014 LSPCFF EQU X'FB' 05600014 CORCON EQU X'02' 05700014 CORCFF EQU X'FD' 05800014 LISTON EQU X'01' 05900014 LISTFF EQU X'FE' 06000014 EJECT 06100014 * 06200014 USING *,L 06300014 BC ALWAYS,*+12 06400014 DC X'0700' 06500014 DC C'IEKCGC' 06600014 STM 14,12,12(13) SAVE REGISTERS 06700014 L INFO,VBLANK 06800014 USING BLANK,INFO 06900014 L PH10R,VPH10 07000014 USING PH10,PH10R 07100014 * 07200014 * INITIALIZATION 07300014 * 07400014 TM SWITCH,FRSTON TEST FOR BEGIN PROGRAM 07500014 BC ALL,AFTER1 BRANCH IF NOT FIRST CARD 07600014 MVI SWITCH,FRSTON SET SWITCH FOR AFTER/CLEAR 07660021 * REMAINDER FOR MULTIPLE COMP. 07720021 OI IPREDL,X'80' SET BIT INDICATING CGC 07740021 * ENTERED THIS COMP 07760021 LA ISNN,2 07800014 STH ISNN,ISNN1 INITIALIZE ISN 07900014 L REG2,FIRST GET ADDRESS OF FIRST CARD 08000014 BAL CARD,MOVCRD 08100014 AFTER1 XC NCARD(16),NCARD ZERO NCARD AREA 08200014 TM SWITCH,IFTRON 08300014 BC ALL,IFRET BRANCH IF TRAILER 08400014 NI SWITCH,CLEAR CLEAR STATEMENT SWITCHES 08500014 LA CONCNT,20 SET MAXIMUM CONTINUE COUNT 08600014 * 08700014 L REG0,BLANKS BLANK OUT NCDIN 08800014 LA REG1,116 08900014 LA REG2,NCDIN 09000014 NCDBLK ST REG0,0(0,REG2) BLANK 4 BYTES 09100014 ST REG0,4(0,REG2) 4 MORE ... 09200014 ST REG0,8(0,REG2) 4 MORE ... 09300014 LA REG2,12(0,REG2) FOR A TOTAL OF 12 09400014 BCT REG1,NCDBLK TIMES 116 09500014 * 09600014 * LABEL CHECK 09700014 * 09800014 CLC INPUT(5),BLANKS 09900014 BC EQUAL,RESET BRANCH IF NO LABEL 10000014 LA REG0,5 10100014 LA INX,INPUT+4 10200014 LA REG1,MHOLD+4 10300014 LCHECK CLI 0(INX),C' ' 10400014 BC EQUAL,KEEPON ELIMINATE BLANKS 10500014 TM 0(INX),X'F0' 10600014 BC 14,BADLAB BRANCH ON NON-DIGIT 10700019 MVC 0(1,REG1),0(INX) 10800014 BCTR REG1,0 ENTER DIGIT 10900014 KEEPON BCTR INX,0 11000014 BCT REG0,LCHECK KEEP CHECKING 11100014 MVI NCARD+11,1 SET LABEL SWITCH ON 11200014 BC ALWAYS,RESET 11300014 BADLAB MVI NCARD+15,62 11400014 RESET BAL LINE,SYSPRT 11500014 BAL CALL,CHKEND TEST FOR END CARD 11600014 * 11700014 * CARD TRANSLATE 11800014 * 11900014 NI SWITCH,PARSFF CLEAR PAREN SWITCH 12000014 LA OUTX,NCDIN+5 SET TO START OF STATEMENT 12100014 SR PARCNT,PARCNT CLEAR PARENTHESIS COUNT 12200014 LA REG1,INPUT+6 SET TO START OF CARD 12500019 MVI INPUT+72,X'4F' INSERT STOPPER AT END OF CARD 12800014 GETCHR SR REG2,REG2 12900014 TRT 0(67,REG1),ICMTBL TRANSLATE CARD 13000014 CH REG2,LIMIT 13100014 BC HIEQ,ERROR ILLEGAL FORTRAN CHARACTER 13200014 BC ALWAYS,BRTBL(REG2) 13300014 BRTBL BC ALWAYS,READ2 IGNORE BLANK CARDS 13400014 BC ALWAYS,ERROR ILLEGAL FORTRAN CHARACTER 13500014 BC ALWAYS,ALPHA LETTERS AND DIGITS 13600014 BC ALWAYS,LFPAR LEFT PARENTHESIS 13700014 BC ALWAYS,RTPAR RIGHT PARENTHESIS 13800014 BC ALWAYS,EQUALS EQUALS SIGN 13900014 BC ALWAYS,COMMA COMMA 14000014 BC ALWAYS,SLASH SLASH OR ASTERISK 14100014 BC ALWAYS,QUOTE QUOTE OR COMM. AT 14200014 BC ALWAYS,ENDMRK END OF CARD 14300014 BC ALWAYS,AMPER AMPERSAND 14400014 BC ALWAYS,DOLLAR DOLLAR SIGN 14500014 LIMIT DC AL2(*-BRTBL) 14600014 * 14700014 * END CARD CHECK 14800014 * 14900014 CHKEND SR REG0,REG0 15000014 LA REG1,3 15100014 LA REG2,66 SCAN COLUMNS 7 THRU 72 15200014 LA INX,INPUT+6 15300014 ENDCHK CLI 0(INX),C' ' 15400014 BC NOTEQ,GETEND 15500014 NXTCHR LA INX,1(0,INX) 15600014 BCT REG2,ENDCHK 15700014 BCR ALWAYS,CALL NOT END, TRANSLATE. 15800014 GETEND SLA REG0,8 15900014 IC REG0,0(0,INX) PICKUP NON-BLANKS 16000014 BCT REG1,NXTCHR FOR A TOTAL OF 3. 16100014 C REG0,ZEND 16200014 BCR NOTEQ,CALL BRANCH IF NOT END CARD 16300014 BLKBMP LA INX,1(0,INX) 16400014 BCT REG2,BLKTST REST OF CARD MUST BE BLANK 16500014 MVI LSTCD,1 SET LAST CARD SWITCH 16600014 NI SWITCH,FRSTFF SET SWITCH FOR FIRST 16700014 BCR ALWAYS,CALL 16800014 BLKTST CLI 0(INX),C' ' 16900014 BC EQUAL,BLKBMP 17000014 BCR ALWAYS,CALL 17100014 EJECT 17200014 * 17300014 * LETTERS AND DIGITS 17400014 * 17500014 ALPHA MVC 0(1,OUTX),0(REG1) MOVE INPUT CHAR. TO BUFFER 17600014 BUFBMP LA OUTX,1(0,OUTX) 17700014 INPBMP LA REG1,1(0,REG1) 17800014 C REG1,ENDADD 17900014 BC LOW,GETCHR 18000014 CLI LSTCD,1 18030020 BE CLASS 18060020 BAL NEXT,READ2 18100014 BC ALWAYS,GETCHR GET NEXT CHARACTER 18200014 * 18300014 * NON-FORTRAN CHARACTER 18400014 * 18500014 ERROR MVI 0(OUTX),C'@' 18560014 BC ALWAYS,BUFBMP 18620014 * 18700014 * LEFT PARENTHESIS 18800014 * 18900014 LFPAR MVI 0(OUTX),C'(' SET EBCDIC CHAR. 19000014 LA PARCNT,1(0,PARCNT) BUMP PARENTHESIS COUNT 19100014 CLI NCDIN+5,C'F' 19200014 BC NOTEQ,CKHOLL 19300014 CLC NCDIN+5(6),FARMOT CHECK FOR FORMAT 19400014 BC NOTEQ,CKHOLL 19500014 OI SWITCH,FRMTON SET SWITCH FOR FORMAT 19600014 CKHOLL LA OUTX,1(0,OUTX) 19700014 LA REG1,1(0,REG1) 19800014 C REG1,ENDADD 19900014 BC LOW,CALLIT 20000014 BAL NEXT,READ2 20100014 CALLIT BAL CALL,EBCDIC 20200014 BC ALWAYS,GETCHR 20300014 * 20400014 * RIGHT PARENTHESIS 20500014 * 20600014 RTPAR MVI 0(OUTX),C')' SET EBCDIC CHAR. 20700014 BCT PARCNT,CKHOLL DECREMENT COUNT 20800014 TM SWITCH,PARSON COUNT IS ZERO, 20900014 BC ALL,BUFBMP TEST PAREN SWITCH. 21000014 OI SWITCH,PARSON NOT ON, SET ON. 21100014 LA OUTX,1(0,OUTX) 21200014 ST OUTX,IFADD SAVE BUFFER LOC 21300014 BC ALWAYS,INPBMP 21400014 * 21500014 * EQUALS OR POUND 21600014 * 21700014 EQUALS MVI 0(OUTX),C'=' SET EBCDIC CHAR. 21800014 LTR PARCNT,PARCNT 21900014 BC ZERO,SETARN BRANCH IF COUNT ZERO 22000014 NI SWITCH,ARTHFF SET ARITH SWITCH OFF 22100014 BC ALWAYS,BUFBMP 22200014 SETARN OI SWITCH,ARTHON SET ARITH SWITCH ON 22300014 BC ALWAYS,BUFBMP 22400014 * 22500014 * COMMA 22600014 * 22700014 COMMA MVI 0(OUTX),C',' SET EBCDIC CHAR. 22800014 LTR PARCNT,PARCNT 22900014 BC NZERO,CKHOLL BRANCH IF COUNT NON-ZERO 23000014 NI SWITCH,ARTHFF SET ARITH SWITCH OFF 23100014 BC ALWAYS,CKHOLL 23200014 * 23300014 * SLASH OR ASTERISK 23400014 * 23500014 SLASH MVC 0(1,OUTX),0(REG1) MOVE INPUT CHAR. TO BUFFER 23600014 CLI 0(REG1),C'/' SLASH OR ASTERISK 23700014 BC EQUAL,CKHOLL BRANCH IF SLASH 23800014 LR REG2,OUTX 23900014 BCTR REG2,0 BACKUP IN BUFFER 24000014 CLI 0(REG2),C'A' 24100014 BC LOW,CKHOLL 24200014 CLI 0(REG2),C'Z' 24300014 BC HIGH,CKHOLL 24400014 OI SWITCH,LSPCON SET LENGTH INDICATOR 24500014 BC ALWAYS,CKHOLL FOR LETTERS. 24600014 * 24700014 * QUOTE OR COMM. AT 24800014 * 24900014 QUOTE TM OPTION,X'02' 25000014 BC ALL,CHECKQ BRANCH IF BCD OPTION 25100014 CLI 0(REG1),C'''' NOT EBCDIC QUOTE, 25200014 BC NOTEQ,ERROR MUST BE INVALID. 25300014 CHECKQ TM SWITCH,FRMTON 25400014 BC ALL,SETQ BRANCH IF WITHIN FORMAT 25500014 BCTR OUTX,0 25600014 CLI 0(OUTX),193 QUOTE LITERALS IN CALL 25700014 LA OUTX,1(0,OUTX) STATEMENTS WILL BE 25800014 BC LOW,DADOL PRECEDED BY A DELIMETER 25860018 LTR PARCNT,PARCNT TRY TO CATCH PAUSE LITERALS000A 25930015 BC ZERO,SETQ 000A 25960015 EBCQOT MVI 0(OUTX),C'''' SET EBCDIC CHAR. 26030018 BC ALWAYS,BUFBMP 26100014 DADOL BCTR OUTX,0 DATA SET REFERENCE NUMBER MAY 26120018 CLI 0(OUTX),91 HAVE $ AS VALID LAST CHAR IN 26140018 LA OUTX,1(0,OUTX) THE INTEGER VARIABLE. DO NOT 26160018 BC EQUAL,EBCQOT BRANCH TO SETQ. 26180018 SETQ MVC SAVEQ(1),0(REG1) 26200014 EBCDQ MVI 0(OUTX),C'''' SET EBCDIC QUOTE 26300014 QBUMP LA OUTX,1(0,OUTX) 26400014 LA REG1,1(0,REG1) 26500014 C REG1,ENDADD 26600014 BC LOW,QTEST 26700014 BAL NEXT,READ2 26800014 QTEST CLC 0(1,REG1),SAVEQ 26900014 BC EQUAL,DQUOTE QUOTE COMPARE 27000014 MVC 0(1,OUTX),0(REG1) MOVE INPUT CHAR. TO BUFFER 27100014 BC ALWAYS,QBUMP 27200014 DQUOTE MVI 0(OUTX),C'''' SET EBCDIC QUOTE 27300014 LA OUTX,1(0,OUTX) 27400014 LA REG1,1(0,REG1) 27500014 C REG1,ENDADD 27600014 BC LOW,Q2TEST 27700014 BAL NEXT,READ2 27800014 Q2TEST CLC 0(1,REG1),SAVEQ 27900014 BC EQUAL,EBCDQ DOUBLE QUOTE 28000014 TM SWITCH,FRMTON 28100014 BC NONE,GETCHR NOT FORMAT, BRANCH. 28200014 BAL CALL,EBCDIC 28300014 BC ALWAYS,GETCHR 28400014 * 28500014 * AMPERSAND 28600014 * 28700014 AMPER TM OPTION,X'02' 28800014 BC NONE,EBAMP 28900016 MVI 0(OUTX),C'+' 29000014 BC ALWAYS,BUFBMP 29100014 EBAMP BCTR OUTX,0 CHECK CHAR BEFORE 29107016 CLI 0(OUTX),C',' MUST BE BEGINNING OF 29114016 BE CKCALL ARG IN CALL 29121016 CLI 0(OUTX),C'(' 29128016 BNE PLUS 29135016 CKCALL CLC ITBLE+53(4),NCDIN+5 29142016 BE BUMP 29149016 CLC NCDIN+5(3),IFLP 29149817 BNE PLUS 29150617 TM SWITCH,PARSON 29151417 BC NONE,PLUS 29152217 L REG2,IFADD 29153017 CLC ITBLE+53(4),0(REG2) 29153817 BE BUMP 29154617 PLUS LA OUTX,1(OUTX) 29156016 MVI 0(OUTX),C'+' 29163016 BC ALWAYS,BUFBMP 29170016 BUMP LA OUTX,1(OUTX) 29177016 BC ALWAYS,BUFBMP 29184016 * 29200014 * DOLLAR SIGN 29300014 * 29400014 DOLLAR TM OPTION,X'02' 29500014 BC NONE,ALPHA BRANCH IF EBCDIC 29600014 BCTR OUTX,0 29610016 CLI 0(OUTX),C',' 29620016 BE CHCALL 29630016 CLI 0(OUTX),C'(' 29640016 BNE BUMERR 29650016 CHCALL CLC ITBLE+53(4),NCDIN+5 29660016 BC EQUAL,GOON 29661016 CLC NCDIN+5(3),IFLP 29662016 BNE BUMERR 29663016 TM SWITCH,PARSON 29664016 BC NONE,BUMERR 29665016 L REG2,IFADD 29666016 CLC ITBLE+53(4),0(REG2) 29667016 BNE BUMERR 29670016 GOON LA OUTX,1(OUTX) 29680016 MVI 0(OUTX),X'50' 29700014 BC ALWAYS,BUFBMP 29800014 BUMERR LA OUTX,1(OUTX) 29830016 BC ALWAYS,ERROR 29860016 * 29900014 * HOLLERITH ROUTINE 30000014 * 30100014 EBCDIC SR COUNT,COUNT CLEAR COUNT 30200014 SR REG0,REG0 AND CHARACTER REGISTER. 30300014 SKPBLK MVC 0(1,OUTX),0(REG1) MOVE INPUT CHAR. TO BUFFER 30400014 CLI 0(REG1),C' ' 30500014 BC NOTEQ,NONBLK 30600014 BUMPR1 LA REG1,1(0,REG1) 30700014 C REG1,ENDADD 30800014 BC LOW,SKPBLK 30900014 BAL NEXT,READ2 31000014 BC ALWAYS,SKPBLK 31100014 NONBLK TM 0(REG1),X'F0' 31200014 BC ALL,GETDIG BRANCH IF DIGIT 31300014 CLI 0(REG1),C'H' 31400014 BC EQUAL,CHARH BRANCH IF 'H' 31500014 TM SWITCH,FRMTON 31600014 BC NONE,HOUT BRANCH NOT FORMAT 31700014 CLI 0(REG1),C'/' 31800014 BC EQUAL,MOVCHR SLASH OR 'X' MAY BE 31900014 CLI 0(REG1),C'X' FOLLOWED BY LITERAL. 32000014 BC NOTEQ,HOUT 32100014 MOVCHR MVC 0(1,OUTX),0(REG1) 32200014 LA OUTX,1(0,OUTX) 32300014 SR COUNT,COUNT CLEAR COUNT 32400014 SR REG0,REG0 AND CHARACTER REGISTER. 32500014 BC ALWAYS,BUMPR1 KEEP CHECKING 32600014 * 32700014 GETDIG ST COUNT,NUMBER 32800014 SLL COUNT,2 N*4 32900014 A COUNT,NUMBER +N 33000014 SLL COUNT,1 *2 33100014 NI 0(REG1),X'0F' 33200014 IC REG0,0(0,REG1) 33300014 AR COUNT,REG0 ADD IN NEW DIGIT 33400014 LA OUTX,1(0,OUTX) 33500014 BC ALWAYS,BUMPR1 33600014 * 33700014 CHARH TM SWITCH,LSPCON 33800014 BC ALL,HOUT BRANCH IF LENGTH SPEC 33900014 LA OUTX,1(0,OUTX) 34000014 LA REG1,1(0,REG1) 34100014 C REG1,ENDADD 34200014 BC LOW,TESTC 34300014 BAL NEXT,READ2 34400014 TESTC LTR COUNT,COUNT 34500014 BC ZMINUS,HOUT BRANCH ON BAD COUNT 34600014 ST COUNT,NUMBER SAVE COUNT 34700014 LA REG0,0(COUNT,REG1) 34800014 C REG0,ENDADD CHECK FOR OVERFLOW 34900014 BC LOW,MOVEH 35000014 L COUNT,ENDADD 35100014 SR COUNT,REG1 COMPUTE CHARACTERS REMAINING 35200014 BCTR COUNT,0 35300014 EX COUNT,MOVE MOVE REST OF CARD 35400014 LA COUNT,1(0,COUNT) 35500014 AR OUTX,COUNT BUMP NCDIN POINTER 35600014 BAL NEXT,READ2 35700014 S COUNT,NUMBER 35800014 LCR COUNT,COUNT GET REMAINING COUNT 35900014 BC ZERO,EBCDIC 35950016 BC ALWAYS,TESTC 36000014 MOVEH BCTR COUNT,0 36100014 EX COUNT,MOVE 36200014 LA COUNT,1(0,COUNT) 36300014 AR OUTX,COUNT BUMP NCDIN POINTER 36400014 AR REG1,COUNT BUMP INPUT POINTER 36500014 TM SWITCH,FRMTON 36600014 BC ALL,EBCDIC BRANCH IF FORMAT 36700014 HOUT NI SWITCH,LSPCFF CLEAR LENGTH INDICATOR, 36800014 BCR ALWAYS,CALL AND RETURN. 36900014 * 37000014 * END OF INPUT CARD 37100014 * 37200014 ENDMRK C REG1,ENDADD 37300014 BC LOW,ERROR NOT AT COLUMN 73 37400014 CLI LSTCD,1 37500014 BC EQUAL,CLASS LAST CARD HAS BEEN READ 37600014 BAL NEXT,READ2 37700014 BC ALWAYS,GETCHR 37800014 READ2 BAL CARD,SYSCRD 37900014 CLI INPUT+5,C' ' 38000014 BC EQUAL,CLASS BRANCH IF NOT CONTINUE 38100014 CLI INPUT+5,C'0' 38200014 BC EQUAL,CLASS BRANCH IF NOT CONTINUE 38300014 OI SWITCH,CORCON 38400014 BAL LINE,SYSPRT 38500014 BCT CONCNT,CTRANS 38600014 MVI NCARD+15,57 TOO MANY CONTINUE CARDS 38700014 BC ALWAYS,READ2 CONTINUE READING 38800014 CTRANS CLI NCARD+15,57 38900014 BC EQUAL,READ2 TOO MANY CONTINUE CARDS 39000014 LA REG1,INPUT+6 SET TO START OF CARD 39100014 MVI INPUT+72,X'4F' INSERT STOPPER AT END OF CARD 39200014 BCR ALWAYS,NEXT 39300014 EJECT 39400014 * 39500014 * CLASSIFICATION 39600014 * 39700014 CLASS MVI 0(OUTX),X'4F' SET END MARK IN BUFFER 39800014 ST OUTX,FMTSAV 000B 39850016 LA K,6 POINT PAST LABEL 39900014 CLI NCARD+15,62 39930019 BC EQUAL,BUILD BAD LABEL 39960019 CLI NCARD+15,57 40000014 BC EQUAL,BUILD TOO MANY CONTINUE CARDS 40100014 LTR PARCNT,PARCNT 40200014 BC ZERO,PARBAL 40300014 MVI NCARD+15,61 UNBALANCED PARENS 40400014 BC ALWAYS,BUILD 40500014 PARBAL LA OUTX,NCDIN+5 40600014 MVC ITYPRG(1),0(OUTX) SAVE INITIAL CHARACTER 40700014 CLC 0(3,OUTX),IFLP 40800014 BC EQUAL,CHKIF BRANCH ON IF( 40900014 CLASIF TM SWITCH,ARTHON 41000014 BC ALL,ARITH BRANCH IF ARITH 41100014 LA J,IPTR 41200014 TSTCHR CLC 0(1,J),ITYPRG 41300014 BC EQUAL,FOUND CHARACTER FOUND 41400014 CLI 0(J),C'Z' 41500014 BC EQUAL,NOCLAS NO MATCH IN TABLE 41600014 LA J,4(0,J) 41700014 BC ALWAYS,TSTCHR KEEP TESTING 41800014 * 41900014 ARITH MVI NCARD+15,56 SET CLASS TO ARITH 42000014 BUILD LH ISNN,ISNN1 42100014 STH ISNN,NCARD+6 SET CURRENT ISN 42200014 AH ISNN,ONE 42300014 STH ISNN,ISNN1 UPDATE ISN 42400014 L ISNN,280(0,INFO) 42420018 AH ISNN,ONE 42440018 ST ISNN,280(0,INFO) 42460018 MVC NCDIN(5),MHOLD SET LABEL 42500014 MVI MHOLD,C'0' 42600014 MVC MHOLD+1(4),MHOLD CLEAR LABEL AREA 42700014 ST K,NCARD SET NCDIN POINTER 42800014 L REG0,PHASE 42900014 N REG0,TRACE 43000014 BC ZERO,EXIT BRANCH IF NO TRACE 43100014 CNOP 0,4 43200014 L L,VIBCOM 43300014 BAL R,4(0,L) CALL IBCOM 43400014 DC F'6' 43500014 DC A(FMT) 43600014 BAL R,12(0,L) 43700014 DC A(NCARD) NCARD(4) 43800014 DC X'04000004' 43900014 BAL R,12(0,L) 44000014 DC A(NCDIN) NCDIN(1400) 44100014 DC X'6400000E' 44200014 BAL R,16(0,L) 44300014 EXIT LM 14,12,12(13) RESTORE REGISTERS 44400014 MVI 12(13),X'FF' 44500014 BCR ALWAYS,14 RETURN TO CALLER 44600014 * 44700014 FOUND LA I,ITBLE 44800014 SR COUNT,COUNT PICKUP NUMBER OF 44900014 IC COUNT,1(0,J) POSSIBLE KEYWORDS. 45000014 AH I,2(0,J) ADD DISPLACEMENT 45100014 SR LENGTH,LENGTH OF KEYWORD FROM 45200014 SEEKON IC LENGTH,0(0,I) START OF ITBLE. 45300014 STC LENGTH,SEEK+1 SET LENGTH OF KEYWORD 45400014 LA LENGTH,3(0,LENGTH) 45500014 SEEK CLC 1(0,I),0(OUTX) CHECK FOR KEYWORD 45600014 BC EQUAL,ATKEY BRANCH IF FOUND 45700014 AR I,LENGTH 45800014 BCT COUNT,SEEKON 45900014 NOCLAS MVI NCARD+15,59 NOT CLASSIFIABLE 46000014 BC ALWAYS,BUILD 46100014 * 46200014 ATKEY BCTR LENGTH,0 46300014 BCTR LENGTH,0 46400014 AR I,LENGTH 46500014 MVC NCARD+15(1),1(I) SET CLASS CODE 46600014 CLI 1(I),18 46700014 BC EQUAL,CHKDO BRANCH ON DO 46800014 CLI 1(I),1 46900014 BC EQUAL,CHKAS BRANCH ON ASSIGN 47000014 AR K,LENGTH POINT PAST KEYWORD 47100014 CLI 1(I),25 000B 47110016 BC NOTEQ,BUILD BRANCH IF NOT FORMAT 000B 47120016 L ISNN,FMTSAV 000B 47130016 LA LENGTH,NCDIN+10 000B 47140016 SR ISNN,LENGTH 000B 47150016 ST ISNN,NCARD+8 AND STORE IN NCARD(3). 000B 47160016 BC ALWAYS,BUILD 47200014 * 47300014 * DO ROUTINE 47400014 * 47500014 CHKDO MVC 0(2,OUTX),BLANKS BLANK OUT 'DO' 47600014 LA K,1(0,K) SHIFT POINTER 47700014 MOVEL1 MVC 1(1,OUTX),2(OUTX) SHIFT LABEL LEFT 47800014 CLI 1(OUTX),C'9' 47900014 BC HIGH,DOBLK STOP ON NON-NUMERIC 48000014 CLI 1(OUTX),C'0' 48100014 BC LOW,DOBLK STOP ON NON-NUMERIC 48200014 LA OUTX,1(0,OUTX) 48300014 BC ALWAYS,MOVEL1 48400014 DOBLK MVI 1(OUTX),C'*' END LABEL WITH ASTERISK 48500014 BC ALWAYS,BUILD 48600014 * 48700014 * ASSIGN ROUTINE 48800014 * 48900014 CHKAS MVC 0(6,OUTX),BLANKS BLANK OUT ASSIGN 49000014 LA OUTX,4(0,OUTX) 49100014 MOVEL2 CLI 2(OUTX),C'9' 49200014 BC HIGH,STARAS STOP ON NON-NUMERIC 49300014 CLI 2(OUTX),C'0' 49400014 BC LOW,STARAS STOP ON NON-NUMERIC 49500014 MVC 0(1,OUTX),2(OUTX) SHIFT LABEL LEFT 49600014 LA OUTX,1(0,OUTX) 49700014 BC ALWAYS,MOVEL2 49800014 STARAS CLC 2(2,OUTX),CTO 49900014 BC NOTEQ,NOCLAS BRANCH IF NOT 'TO' 50000014 MVI 0(OUTX),C'*' 50100014 MVC 1(2,OUTX),2(OUTX) BOUND 'TO' WITH ASTERISKS 50200014 MVI 3(OUTX),C'*' 50300014 LA K,4(0,K) SHIFT POINTER 50400014 BC ALWAYS,BUILD 50500014 * 50600014 * IF ROUTINE 50700014 * 50800014 CHKIF L OUTX,IFADD 50900014 MVI NCARD+15,31 ASSUME LOGICAL IF 51000014 CLI 0(OUTX),C'9' 51100014 BC HIGH,EQTST BRANCH IF NOT DIGIT 51200014 CLI 0(OUTX),C'0' 51300014 BC LOW,EQTST BRANCH IF NOT DIGIT 51400014 MVI NCARD+15,32 SET TO ARITH IF 51500014 IFPTR LA K,2(0,K) POINT PAST IF 51600014 BC ALWAYS,BUILD 51700014 EQTST CLI 0(OUTX),C'=' 51800014 BC EQUAL,ARITH EQUAL SIGN MEANS ARITH 51900014 MVC ITYPRG(1),0(OUTX) SAVE CHARACTER AFTER 52000014 MVI 0(OUTX),X'4F' RIGHT PAREN, AND PLUG. 52100014 OI SWITCH,IFTRON SET SWITCH FOR IF TRAILER 52200014 BC ALWAYS,IFPTR 52300014 * 52400014 IFRET NI SWITCH,IFTRFF CLEAR TRAILER SWITCH 52500014 L OUTX,IFADD 52600014 LA K,NCDIN-1 ADJUST NCDIN POINTER 52700014 SR K,OUTX TO TRAILER. 52800014 LCR K,K 52900014 MVC 0(1,OUTX),ITYPRG RESTORE CHARACTER 53000014 CLC 0(3,OUTX),IFLP 53100014 BC NOTEQ,CLASIF 53200014 LA J,3(0,OUTX) 53300014 LA PARCNT,1 53400014 RTPAR2 CLI 0(J),C')' SEARCH FOR RIGHT PAREN 53500014 BC EQUAL,UNBUMP 53600014 CLI 0(J),C'(' 53700014 BC EQUAL,BMPCNT 53800014 CLI 0(J),X'4F' IF END MARK, GIVE UP. 53900014 BC EQUAL,NEWADD 54000014 BUMPJ LA J,1(0,J) 54100014 BC ALWAYS,RTPAR2 54200014 BMPCNT LA PARCNT,1(0,PARCNT) 54300014 BC ALWAYS,BUMPJ 54400014 UNBUMP BCT PARCNT,BUMPJ 54500014 LA J,1(0,J) 54600014 NEWADD ST J,IFADD SAVE BUFFER LOC 54700014 BC ALWAYS,CHKIF 54800014 EJECT 54900014 * 55000014 * READ A CARD 55100014 * 55200014 SYSCRD STM 1,2,SAVE1 TEMPORARY SAVE 55300014 CARDIN LA REG1,RUNIT 55400014 LR REG2,L 55500014 L L,VFIOCS 55600014 BALR R,L READ A CARD 55700014 LR L,REG2 55800014 L REG2,0(0,REG1) GET BUFFER ADDRESS 55900014 MOVCRD MVC INPUT(80),0(REG2) MOVE ENTIRE CARD 56000014 CLI INPUT,C'C' 56100014 BC NOTEQ,CRDOUT NOT COMMENT CARD 56200014 OI SWITCH,CORCON 56300014 BAL LINE,SYSPRT PRINT COMMENT, 56400014 BC ALWAYS,CARDIN AND READ AGAIN. 56500014 CRDOUT SR REG2,REG2 56600014 TRT INPUT(72),ICMTBL 56700014 LTR REG2,REG2 56800014 BC ZERO,CARDIN SKIP BLANK CARDS 56900014 LM 1,2,SAVE1 57000014 BCR ALWAYS,CARD 57100014 * 57200014 * PRINT A LINE 57300014 * 57400014 SYSPRT TM OPTION,X'41' 57500014 BCR NONE,LINE NO SOURCE OR EDIT 57600014 STM 0,4,SAVE2 TEMPORARY SAVE 57700014 LA REG1,WUNIT 57800014 OI SWITCH,LISTON SET SOURCE SWITCH 57900014 TM OPTION,X'01' 58000014 BC ALL,GETLIN BRANCH TO SET UP SOURCE LISTING 58100014 EDOPT LA REG1,DUNIT 58200014 NI SWITCH,LISTFF RESET SWITCH FOR EDIT 58300014 GETLIN LR REG2,L 58400014 L L,VFIOCS 58500014 BALR R,L LOCATE A BUFFER 58600014 LR L,REG2 58700014 L REG2,0(0,REG1) GET BUFFER ADDRESS 58800014 MVC 17(81,REG2),INPUT 58900014 TM SWITCH,CORCON 59000014 BC ALL,PRINT COMMENT OR CONTINUE 59100014 TM SWITCH,LISTON 59200014 BC ALL,WRTOUT BRANCH IF NOT IN EDIT STEP 59300014 * 59400014 LH REG0,CLASCD 59500014 TM IPREDL+3,X'01' 59600014 BC NONE,SETCLS 59700014 MVI IPREDL+3,X'00' 59800014 AH REG0,ONEH 59900014 SETCLS STH REG0,TEMP 60000014 MVC 98(2,REG2),TEMP SET CLASS CODE 60100014 CLI IFTRLG,2 60200014 BC NOTEQ,NOTLOG BRANCH IF NO TRAILER 60300014 MVI 99(REG2),31 60400014 NOTLOG L REG0,NGENLB 60500014 BCTR REG0,0 60600014 L I,NDOLEV 60700014 LTR I,I 60800014 BC ZERO,ONELEV 60900014 BC ALWAYS,TSTLEV 61000014 LEVTST LR J,I 61100014 BCTR J,0 61200014 MH J,TWENT4 61300014 L REG1,NDOPDN(J) 61400014 C REG1,LABSAV 61500014 BC NOTEQ,ONELEV 61600014 AH REG0,ONE 61700014 TSTLEV BCT I,LEVTST 61800014 ONELEV ST REG0,TEMP 61900014 MVC 100(4,REG2),TEMP SET LAST GENERATED LABEL 62000014 MVI 104(REG2),X'F0' 62100014 MVN 104(1,REG2),NDOSG+3 SET END-DO INDICATOR 62200014 * 62300014 WRTOUT MVC 4(3,REG2),CISN 62400014 LH REG0,ISNN1 62500014 CVD REG0,PACK CONVERT CURRENT ISN, 62600014 UNPK 8(4,REG2),PACK+5(3) AND PLACE IN LINE. 62700014 OI 11(REG2),X'F0' 62800014 PRINT TM SWITCH,LISTON 62900014 BC NONE,PROUT 63000014 TM OPTION,X'40' TEST FOR EDIT 63100014 BC ALL,EDOPT 63200014 PROUT NI SWITCH,CORCFF RESET SWITCH 63300014 LM 0,4,SAVE2 63400014 BCR ALWAYS,LINE 63500014 * 63600014 * FLUSH INPUT 63700014 * 63800014 USING *,L 63900014 IEKAREAD STM 14,12,12(13) SAVE REGISTERS 64000014 L INFO,VBLANK 64100014 L PH10R,VPH10 64200014 L L,VGETCD ESTABLISH ADDRESSABILITY 64300014 USING IEKCGC,L 64400014 TM IPREDL,X'80' TEST IF CGC ENTERED 64410021 * THIS COMP 64420021 BC ALL,SKIPIT IF SO GO TO PRINT OUT CARD 64430021 * IF CGC NOT YET ENTERED THEN 64440021 * THE CARD WILL STILL BE IN 64450021 * THE FIOCS BUFFER 64460021 L REG2,FIRST GET ADDRESS OF CARD 64470021 BAL CARD,MOVCRD MOVE CRD TO INPUT BUFFER IN 64480021 * PHASE 10 TO BE PRINTED OUT 64490021 BC ALWAYS,SKIPIT PRINT CURRENT CARD 64500014 REREAD BAL CARD,SYSCRD 64600014 SKIPIT OI SWITCH,CORCON TREAT CARD AS COMMENT 64700014 BAL LINE,SYSPRT 64800014 CLI INPUT+5,C' ' 64900014 BC EQUAL,TSTEND BRANCH IF NOT CONTINUE 65000014 CLI INPUT+5,C'0' 65100014 BC NOTEQ,REREAD CONTINUE CARD, READ AGAIN. 65200014 TSTEND BAL CALL,CHKEND TEST FOR END CARD 65300014 CLI LSTCD,1 65400014 BC NOTEQ,REREAD NOT END, KEEP READING. 65500014 LM 14,12,12(13) RESTORE REGISTERS 65600014 MVI 12(13),X'FF' 65700014 BCR ALWAYS,R RETURN 65800014 EJECT 65900014 * 66000014 * COMMON DEFINITIONS 66100014 * 66200014 BLANK EQU IEKAAA 66300014 CLASCD EQU BLANK+10 66400014 OPTION EQU BLANK+19 66500014 PHASE EQU BLANK+80 66600014 TRACE EQU BLANK+84 66700014 LSTCD EQU BLANK+99 66800014 FIRST EQU BLANK+100 66900014 PH10 EQU IEKCAA 67000014 NCARD EQU PH10 67100014 NCDIN EQU PH10+X'10' 67200014 NGENLB EQU PH10+X'69C' 67300014 IFTRLG EQU PH10+X'6FC' 67400014 NDOSG EQU PH10+X'700' 67500014 IPREDL EQU PH10+X'72C' 67600014 NDOLEV EQU PH10+X'778' 67700014 LABSAV EQU PH10+X'784' 67800014 NDOPDN EQU PH10+X'AF0' 67900014 * 68000014 * STORAGE AND SWITCHES 68100014 * 68200014 SAVE1 DS 2F 68300014 SAVE2 DS 5F 68400014 RUNIT DC X'02050050' 68500014 WUNIT DC X'03060069' 68600014 DUNIT DC X'03080069' 68700014 VGETCD DC A(IEKCGC) 68800014 VIBCOM DC A(IBCOM#) 68900014 VFIOCS DC A(FIOCS#) 69000014 VBLANK DC A(IEKAAA) 69100014 VPH10 DC A(IEKCAA) 69200014 * 69300014 TEMP DS 1F 69400014 ZEND DC X'00C5D5C4' 69500014 ENDADD DC A(INPUT+72) END OF CARD 69600014 IFADD DS 1F LOCATION OF IF TRAILER 69700014 FMTSAV DS 1F END OF STATEMENT POINTER 000B 69750016 NUMBER DC F'0' H-COUNT STORAGE 69800014 BLANKS DC CL6' ' 69900014 ISNN1 DC H'0' TEMPORARY ISN 70000014 ONE DC H'1' 70100014 TWENT4 DC H'24' 70200014 ONEH DC H'100' 70300014 MOVE MVC 0(1,OUTX),0(REG1) INPUT TO NCDIN 70400014 IFLP DC C'IF(' 70500014 CTO DC C'TO' 70600014 CISN DC C'ISN' 70700014 MHOLD DC C'00000' 70800014 SAVEQ DC AL1(0) EBCDIC OR BCD QUOTE 70900014 ITYPRG DC AL1(0) FIRST CHARACTER OF STATEMENT 71000014 SWITCH DC AL1(0) 71100014 PACK DS 1D 71200014 INPUT DC CL81' ' 71300014 FMT DC X'021A014006041004180314641E040C14641E1C145C22' 71400014 EJECT 71500014 * 71600014 * TRANSLATE AND TEST TABLE FOR INPUT 71700014 * 71800014 ICMTBL DS 0F 71900014 DC 64X'04' 72000014 DC X'00' BLANK 72100014 DC 8X'04' 72200014 DC X'08' PERIOD 72300014 DC X'04' 72400014 DC X'08' PERIOD 72500014 DC X'10' RIGHT PAREN - BCD 72600014 DC X'0C' LEFT PAREN - EBCDIC 72700014 DC X'08' PLUS SIGN 72800014 DC X'24' ENDMARK 72900014 DC X'28' AMPERSAND 73000014 DC 10X'04' 73100014 DC X'2C' DOLLAR SIGN 73200014 DC X'1C' ASTERISK 73300014 DC X'10' RIGHT PAREN - EBCDIC 73400014 DC 2X'04' 73500014 DC X'08' MINUS SIGN 73600014 DC X'1C' SLASH 73700014 DC 7X'04' 73800014 DC X'18' COMMA 73900014 DC X'04' 74000014 DC X'18' COMMA 74100014 DC X'0C' LEFT PAREN - BCD 74200014 DC 14X'04' 74300014 DC X'14' EQUALS SIGN - BCD 74400014 DC X'20' COMMERCIAL AT 74500014 DC X'20' QUOTE 74600014 DC X'14' EQUALS SIGN - EBCDIC 74700014 DC 66X'04' 74800014 DC 9X'08' A - I 74900014 DC 7X'04' 75000014 DC 9X'08' J - R 75100014 DC 8X'04' 75200014 DC 8X'08' S - Z 75300014 DC 6X'04' 75400014 DC 10X'08' 0 - 9 75500014 DC 6X'04' 75600014 EJECT 75700014 * 75800014 * IPTR TABLE FIRST FIELD IS ALPHABETIC INITIAL LETTER OF KEYWORD, 75900014 * SECOND FIELD REFERS TO HOW MANY KEYWORDS BEGIN WITH THIS LETTER, 76000014 * THIRD FIELD IS DISPLACEMENT FROM BEGINNING OF ITBLE FOR A 76100014 * GROUP OF KEYWORDS BEGINNING WITH THAT LETTER. 76200014 * 76300014 IPTR DS 0H 76400014 DC C'A',X'02' 76500014 DC AL2(CA-ITBLE) 76600014 DC C'B',X'02' 76700014 DC AL2(CB-ITBLE) 76800014 DC C'C',X'05' 76900014 DC AL2(CC-ITBLE) 77000014 DC C'D',X'08' 77100014 DC AL2(CD-ITBLE) 77200014 DC C'E',X'05' 77300014 DC AL2(CE-ITBLE) 77400014 DC C'F',X'03' 77500014 DC AL2(CF-ITBLE) 77600014 DC C'G',X'01' 77700014 DC AL2(CG-ITBLE) 77800014 DC C'I',X'03' 77900014 DC AL2(CI-ITBLE) 78000014 DC C'L',X'02' 78100014 DC AL2(CL-ITBLE) 78200014 DC C'M',X'01' 78300014 DC AL2(CM-ITBLE) 78400014 DC C'N',X'02' 78500014 DC AL2(CN-ITBLE) 78600014 DC C'P',X'03' 78700014 DC AL2(CP-ITBLE) 78800014 DC C'R',X'05' 78900014 DC AL2(CR-ITBLE) 79000014 DC C'S',X'03' 79100014 DC AL2(CS-ITBLE) 79200014 DC C'T',X'02' 79300014 DC AL2(CT-ITBLE) 79400014 DC C'W',X'01' 79500014 DC AL2(CW-ITBLE) 79600014 DC C'Z' 79700014 EJECT 79800014 * 79900014 * THIS IS A TABLE OF ALL CURRENT KEYWORDS,FIRST FIELD REFERS TO NUMBER 80000014 * OF SQUEEZED KEYWORD CHARACTERS,SECOND FIELD IS KEYWORD,THIRD FIELD 80100014 * IS CLASSIFICATION CODE. 80200014 * 80300014 ITBLE EQU * 80400014 CA DC AL1(5) 80500014 DC C'ASSIGN' 80600014 DC AL1(1) 80700014 DC AL1(1) 80800014 DC C'AT' 80900014 DC AL1(9) 81000014 CB DC AL1(8) 81100014 DC C'BACKSPACE' 81200014 DC AL1(2) 81300014 DC AL1(8) 81400014 DC C'BLOCKDATA' 81500014 DC AL1(3) 81600014 CC DC AL1(7) 81700014 DC C'CONTINUE' 81800014 DC AL1(5) 81900014 DC AL1(5) 82000014 DC C'COMMON' 82100014 DC AL1(7) 82200014 DC AL1(3) 82300014 DC C'CALL' 82400014 DC AL1(8) 82500014 DC AL1(14) 82600014 DC C'COMPLEXFUNCTION' 82700014 DC AL1(4) 82800014 DC AL1(6) 82900014 DC C'COMPLEX' 83000014 DC AL1(6) 83100014 CD DC AL1(8) 83200014 DC C'DIMENSION' 83300014 DC AL1(14) 83400014 DC AL1(3) 83500014 DC C'DATA' 83600014 DC AL1(17) 83700014 DC AL1(22) 83800014 DC C'DOUBLEPRECISIONFUNCTION' 83900014 DC AL1(10) 84000014 DC AL1(14) 84100014 DC C'DOUBLEPRECISION' 84200014 DC AL1(11) 84300014 DC AL1(1) 84400014 DC C'DO' 84500014 DC AL1(18) 84600014 DC AL1(9) 84700014 DC C'DEFINEFILE' 84800014 DC AL1(13) 84900014 DC AL1(6) 85000014 DC C'DISPLAY' 85100014 DC AL1(15) 85200014 DC AL1(4) 85300014 DC C'DEBUG' 85400014 DC AL1(16) 85500014 CE DC AL1(10) 85600014 DC C'EQUIVALENCE' 85700014 DC AL1(19) 85800014 DC AL1(6) 85900014 DC C'ENDFILE' 86000014 DC AL1(21) 86100014 DC AL1(3) 86200014 DC X'C5D5C44F' 86300014 DC AL1(23) 86400014 DC AL1(4) 86500014 DC C'ENTRY' 86600014 DC AL1(22) 86700014 DC AL1(7) 86800014 DC C'EXTERNAL' 86900014 DC AL1(20) 87000014 CF DC AL1(5) 87100014 FARMOT DC C'FORMAT' 87200014 DC AL1(25) 87300014 DC AL1(7) 87400014 DC C'FUNCTION' 87500014 DC AL1(24) 87600014 DC AL1(3) 87700014 DC C'FIND' 87800014 DC AL1(12) 87900014 CG DC AL1(3) 88000014 DC C'GOTO' 88100014 DC AL1(27) 88200014 CI DC AL1(7) 88300014 DC C'IMPLICIT' 88400014 DC AL1(29) 88500014 DC AL1(14) 88600014 DC C'INTEGERFUNCTION' 88700014 DC AL1(28) 88800014 DC AL1(6) 88900014 DC C'INTEGER' 89000014 DC AL1(30) 89100014 CL DC AL1(14) 89200014 DC C'LOGICALFUNCTION' 89300014 DC AL1(33) 89400014 DC AL1(6) 89500014 DC C'LOGICAL' 89600014 DC AL1(35) 89700014 CM DC AL1(3) 89800014 DC C'MOVE' 89900014 DC AL1(34) 90000014 CN DC AL1(7) 90100014 DC C'NAMELIST' 90200014 DC AL1(36) 90300014 DC AL1(5) 90400014 DC C'NORMAL' 90500014 DC AL1(37) 90600014 CP DC AL1(4) 90700014 DC C'PAUSE' 90800014 DC AL1(38) 90900014 DC AL1(4) 91000014 DC C'PRINT' 91100014 DC AL1(39) 91200014 DC AL1(4) 91300014 DC C'PUNCH' 91400014 DC AL1(40) 91500014 CR DC AL1(3) 91600014 DC C'READ' 91700014 DC AL1(44) 91800014 DC AL1(5) 91900014 DC C'RETURN' 92000014 DC AL1(43) 92100014 DC AL1(5) 92200014 DC C'REWIND' 92300014 DC AL1(42) 92400014 DC AL1(11) 92500014 DC C'REALFUNCTION' 92600014 DC AL1(41) 92700014 DC AL1(3) 92800014 DC C'REAL' 92900014 DC AL1(45) 93000014 CS DC AL1(3) 93100014 DC C'STOP' 93200014 DC AL1(48) 93300014 DC AL1(9) 93400014 DC C'SUBROUTINE' 93500014 DC AL1(46) 93600014 DC AL1(8) 93700014 DC C'STRUCTURE' 93800014 DC AL1(47) 93900014 CT DC AL1(7) 94000014 DC C'TRACEOFF' 94100014 DC AL1(49) 94200014 DC AL1(6) 94300014 DC C'TRACEON' 94400014 DC AL1(50) 94500014 CW DC AL1(4) 94600014 DC C'WRITE' 94700014 DC AL1(51) 94800014 * 94900014 END 95000014 ./ ADD SSI=01010870,NAME=IEKCGO,SOURCE=0 C SUBROUTINE XGO 00100014 SUBROUTINE IEKCGO 00200014 C1740480200-480800,485500 18826 00230017 C2830480800 19469 00260017 C 111000 21444 00280018 C 00300014 C DICTIONARY LAYOUT 00400014 C 00500014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00600014 LOGICAL*1 BYA,BYB,BYC 00700014 INTEGER*2 DIS,MDD,TYP 00800014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00900014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01000014 * NAM1,NAM2,NAM3,NAM4 01100014 C 01200014 C 01300014 C LABEL LAYOUT 01400014 C 01500014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 01600014 LOGICAL*1 COMP,DN 01700014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 01800014 C 01900014 C 02000014 C INTERMEDIATE TEXT LAYOUT 02100014 C 02200014 LOGICAL * 1 ADJCD 02300014 INTEGER * 2 TMOD,TTYP 02400014 INTEGER TXTCHN,TPTR 02500014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 02600014 C 02700014 C 02800014 C BRANCH TABLE LAYOUT 02900014 C 03000014 LOGICAL * 1 IND 03100014 INTEGER CHN,PTRSN,RELOC 03200014 STRUCTURE // IND // CHN,PTRSN,RELOC 03300014 C 03400014 COMMON /IEKAAA/ NPTR (2,35) 03500014 COMMON /IEKAER/ NERTBL (2,50) 03600014 C 03700014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 03800014 INTEGER SLIMS 03900014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 04000014 *NBLK,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 04100014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 04200014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 04300014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 04400014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 04500014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 04600014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 04700014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 04800014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 04900014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 05000014 C 05100014 EQUIVALENCE (NPTR (1,9), NPUT) 05200014 LOGICAL * 1 INDSV 05300014 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC05400014 C C 05500014 C XGO - IEKCGO C 05600014 C C 05700014 C FUNCTION - XGO CHECKS SYNTAX AND GENERATES TEXT FOR THE UNCONDI- C 05800014 C TIONAL, ASSIGNED AND COMPUTED GO TO STATEMENTS. C 05900014 C C 06000014 C CALLED BY - DSPTCH C 06100014 C C 06200014 C CALLS - PUTX, CLOSE, ERROR, GETWD, LABTLU, COMPAT, SYMTLU C 06300014 C C 06400014 C COMMON - BLANK, PH10 C 06500014 C C 06600014 C ERRORS - 16, 17, 18, 19, 20, 21, 22 C 06700014 C C 06800014 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC06900014 C UNCONDITIONAL GO TO 07000014 C PROCESSING OF THE UNCONDITIONAL 07100014 C GO TO INCLUDES HAVING THE TEXT 07200014 C ENTRIES FOR THE STATEMENT 07300014 C GENERATED AND HAVING THE 07400014 C STATEMENT NUMBER ENTRY FOR THE 07500014 C REFERENCED LABEL GENERATED. 07600014 C COMPUTED GO TO 07700014 C PROCESSING OF THE COMPUTED GO TO07800014 C INCLUDES HAVING THE TEXT ENTRIES07900014 C FOR THE STATEMENT GENERATED, 08000014 C HAVING THE STATEMENT NUMBER AND 08100014 C DICTIONARY ENTRIES FOR THE 08200014 C LABELS AND VARIABLE GENERATED, 08300014 C AND HAVING THE INITIAL AND 08400014 C STANDARD BRANCH TABLE ENTRIES 08500014 C GENERATED. 08600014 C ASSIGNED GO TO 08700014 C PROCESSING OF THE ASSIGNED GO TO08800014 C INCLUDES HAVING THE TEXT ENTRIES08900014 C FOR THE STATEMENT GENERATED AND 09000014 C HAVING THE DICTIONARY AND 09100014 C STATEMENT NUMBER ENTRIES FOR THE09200014 C VARIABLE AND LABELS GENERATED. 09300014 C 09400014 C 09500014 C 09600014 C 09700014 I=0 09800014 NXG=0 09900014 C SET EXECUTABLE STATEMENT 10000014 C SWITCH ON 10100014 NEXCSG=1 10200014 C FOLLOWING COMPARES THE ELEMENT 10300014 C FOLLOWING THE KEYWORDS GO TO 10400014 C TO A LEFT PAREN, WHICH INDICATES10500014 C A COMPUTED GO TO. IF EQUAL, THE 10600014 C BRANCH OCCURS. 10700014 IF(NDELM.EQ.NLFPR) GOTO 1180 10800014 C IF A DELIMITER FOLLOWS THE 10900014 C KEYWORD, BRANCH TO SET THE ERROR11000014 IF(NCDIN(NCARD(1)).LT.193.AND.NCDIN(NCARD(1)).NE.91) GOTO 1030 11100018 C FOLLOWING TESTS TO DETERMINE IF 11200014 C THE STATEMENT HAS A SOURCE LABEL11300014 C IF IT DOES, NXTRN WILL HAVE BEEN11400014 C SET TO 1 BY XCLASS. 11500014 IF(NXTRN .EQ. 1) BYA (ILABPT) = BITON (BYA (ILABPT),5) 11600014 C FOLLOWING CALL TO GETWD ACCESSES11700014 C THE FIRST ELEMENT FOLLOWING THE 11800014 C KEYWORDS GO TO. 11900014 C CALL GETWD 12000014 CALL IEKCGW 12100014 C FOLLOWING TESTS IF THIS ELEMENT 12200014 C IS A DELIMITER. IF IT IS, BRANCH12300014 C TO SET THE ERROR MESSAGE NUMBER.12400014 IF(LENGTH.EQ.0) GOTO 1030 12500014 C FOLLOWING TESTS IF THIS ELEMENT 12600014 C IS A VARIABLE, INDICATING AN 12700014 C ASSIGNED GO TO. IF IT IS, THE 12800014 C BRANCH OCCURS. 12900014 IF(NACCSV.EQ.2) GOTO 1180 13000014 C ELEMENT IS A CONSTANT, 13100014 C INDICATING AN UNCONDITIONAL 13200014 C GO TO STATEMENT. 13300014 C FOLLOWING CALL TO LABTLU HAS 13400014 C THE STATEMENT NUMBER ENTRY FOR 13500014 C THE LABEL GENERATED. 13600014 C CALL LABTLU 13700014 CALL IEKCLT 13800014 IF (TBIT(BYA(ILABPT),4)) GO TO 1197 13900014 C SET THE BIT IN THE ENTRY 14000014 C INDICATING THAT THE STATEMENT 14100014 C NUMBER IS REFERENCED. 14200014 BYA (ILABPT) = BITON (BYA (ILABPT),1) 14300014 C SET THE BIT IN THE ENTRY 14400014 C INDICATING THAT THE STATEMENT 14500014 C NUMBER IS THE OBJECT OF A 14600014 C TRANSFER. 14700014 BYA (ILABPT) = BITON (BYA (ILABPT),7) 14800014 C FOLLOWING BUILDS THE TEXT ENTRY 14900014 C FOR THE UNCONDITIONAL GO TO. 15000014 C SET ADJECTIVE CODE. 15100014 ADJCD(NPUT) = 71 15200014 MTPSET = -1 15300014 C FOLLOWING DETERMINES IF THE 15400014 C PREVIOUS STATEMENT WAS AN 15500014 C LOGICAL IF STATEMENT. IF IT 15600014 C WAS, THE BRANCH OCCURS. 15700014 IF (NPTR(1,2).NE.31) GO TO 1015 15800014 C PREVIOUS STATEMENT WAS A 15900014 C LOGICAL IF STATEMENT. 16000014 C FOLLOWING SETS THE ADDRESS OF 16100014 C THE STATEMENT NUMBER ENTRY INTO 16200014 C THE TEXT ENTRY OF THE LOGICAL 16300014 C IF STATEMENT, NDATSG CONTAINING 16400014 C THE ADDRESS OF THIS ENTRY. THIS 16500014 C STATEMENT NUMBER WILL BE USED 16600014 C AS THE TRUE BRANCH FOR THE 16700014 C LOGICAL IF STATEMENT. 16800014 C 16900014 C INSURE NDATSG WAS SET BEFORE 17000014 C STORING. (IT WILL BE 0 IF THE 17100014 C IF WAS IN ERROR). 17200014 C 17300014 1035 IF(NDATSG .NE. 0) TPTR (NDATSG) = ILABPT 17400014 C ZERO LOCATION CONTAINING IF 17500014 C STATEMENT ADDRESS. 17600014 NDATSG=0 17700014 C FOLLOWING CALL TO PUTX HAS THE 17800014 C TEXT ENTRY FOR THE UNCONDITIONAL17900014 C GO TO GENERATED. 18000014 C CALL PUTX 18100014 1015 CALL IEKCPX 18200014 C FOLLOWING CALL TO CLOSE HAS THE 18300014 C TEXT ENTRY SIGNIFYING THE END OF18400014 C INTERMEDIATE TEXT GENERATED. 18500014 C CALL CLOSE 18600014 NCLSTX = 1 18700014 CALL IEKCPX 18800014 C FOLLOWING INSURES THAT THE END 18900014 C MARK FOLLOWS THE LABEL. IF IT 19000014 C DOES, THE BRANCH OCCURS. 19100014 IF (NDELM.EQ.NGPMK) GO TO 9999 19200014 C END MARK DOES NOT FOLLOW LABEL. 19300014 1030 MSGNO=16 19400014 C BRANCH TO SET ERROR MESSAGE 19500014 C NUMBER. 19600014 GO TO 1200 19700014 C FOLLOWING DETERMINES IF THE 19800014 C COMPUTED OR ASSIGNED GO TO IS 19900014 C THE STATEMENT PORTION OF A 20000014 C LOGICAL-IF-STATEMENT. IF IT IS 20100014 C NOT, THE BRANCH OCCURS. 20200014 1180 IF (IFTRLG.EQ.0) GO TO 1190 20300014 C SET SWITCH INDICATING THAT THE 20400014 C GENERATED LABEL IS FOR THE IF 20500014 C STATEMENT. 20600014 NXG=1 20700014 C BRANCH TO HAVE A LABEL GENERATED20800014 GOTO 1140 20900014 C GO TO IS PART OF A LOGICAL-IF- 21000014 C STATEMENT. 21100014 C SET THE ADDRESS OF THE 21200014 C STATEMENT NUMBER ENTRY FOR THE 21300014 C GENERATED LABEL AS THE FALL- 21400014 C THROUGH LABEL IN THE TEXT ENTRY 21500014 C OF THE IF-STATEMENT. ENDATSG 21600014 C CONTAINS THE ADDRESS OF THIS 21700014 C ENTRYN. 21800014 1185 TPTR (NDATSG) = ILABPT 21900014 NXG=0 22000014 C FOLLOWING CALL TO PUTX HAS THE 22100014 C TEXT ENTRY FOR THE GENERATED 22200014 C LABEL GENERATED. 22300014 MTPSET = -1 22400014 C CALL PUTX 22500014 CALL IEKCPX 22600014 NDATSG=0 22700014 C TEST IF GO TO STATEMENT IS A 22800014 C COMPUTED GO TO. IF IT IS, BRANCH22900014 1190 IF (NDELM.NE.NLFPR) GO TO 1145 23000014 C FOLLOWING HANDLES PROCESSING OF 23100014 C THE COMPUTED GO TO STATEMENT. 23200014 C SET ADJECTIVE CODE FOR COMPUTED 23300014 C GO TO INTO THE TEXT WORK AREA. 23400014 1040 ADJCD (NPUT) = 250 23500014 MTPSET = 1 23600014 C FOLLWOING CALL TO PUTX HAS THE 23700014 C TEXT ENTRY FOR THE ABOVE 23800014 C GENERATED. 23900014 C CALL PUTX 24000014 CALL IEKCPX 24100014 C SAVE THE ADDRESS OF THIS ENTRY. 24200014 ISAVE1 = LPUT 24300014 C 24400014 C SET COMPUTED GO TO INDICATOR FOR 24500014 C IEKCGC (EDIT OPTION USAGE). 24600014 C 24700014 IPREDL = 1 24800014 C SET ADJECTIVE CODE FOR COMPUTED 24900014 C GO TO LOAD INTO THE TEXT WORK 25000014 C AREA. 25100014 ADJCD (NPUT) = 88 25200014 C SET MODE FIELD TO 255 FOR USE BY25300014 C LATER PHASES. 25400014 TMOD (NPUT) = 255 25500014 C CALL PUTX TO HAVE THE TEXT ENTRY25600014 C FOR THE ABOVE GENERATED. 25700014 MTPSET = 1 25800014 C CALL PUTX 25900014 CALL IEKCPX 26000014 C SAVE THE ADDRESS OF THIS ENTRY. 26100014 ISAVE = LPUT 26200014 C 26210014 C INSURE SUFFICIENT DICTIONARY SPACE. 26220014 C 26230014 IF(NPTR (2,29) + 16 .GT. NPTR (2,30)) CALL IEKAGC (2) 26240014 C 26250014 C FOLLOWING TESTS THE LOCATION IN 26300014 C THE COMMUNICATION AREA WHICH 26400014 C HOLDS THE ADDRESS OF THE 26500014 C COMPUTED GO TO BRANCH TABLE. 26600014 C IF IT IS NOT EQUAL TO 0, THIS 26700014 C INDICATES THAT THE TABLE HAS 26800014 C BEEN STARTED AND THE BRANCH 26900014 C OCCURS. 27000014 IF (NPTR(1,29).NE.0) GO TO 1065 27100014 C TABLE HAS NOT BEEN STARTED. 27200014 C FOLLOWING MAKES THE INITIAL 27300014 C ENTRY. 27400014 C SET ADDRESS OF NEXT AVAILABLE 27500014 C DICTIONARY LOCATION AS POINTER 27600014 C TO BRANCH TABLE. 27700014 NPTR(1,29)=NPTR(2,29) 27800014 C SAVE THIS ADDRESS. 27900014 I=NPTR(1,29) 28000014 C INCREMENT POINTER TO NEXT 28100014 C AVAILABLE DICTIONARY LOCATION. 28200014 1055 NPTR (2,29) = NPTR (2,29) + 16 28300014 C SAVE ADDRESS OF THE NEW ENTRY. 28600014 LAADR = I 28700014 C SET FIELD 1 OF THE NEW ENTRY 28800014 C TO 53, INDICATING THAT THIS IS A28900014 C INITIAL BRANCH ENTRY. 29000014 IND (I) = 53 29100014 C SAVE ADDRESS OF THE NEW ENTRY. 29200014 NCOMEX=I 29300014 C UPDATE LOCATION OF LAST ENTRY. 29400014 RELOC (NPTR (1,29)) = I 29500014 C FOLLOWING CONTINUES THE SETTING 29600014 C OF TEXT FOR THE COMPUTED GO TO. 29700014 C SET ADDRESS OF INITIAL BRANCH 29800014 C TABLE ENTRY INTO THE TEXT WORK 29900014 C AREA. 30000014 TPTR (NPUT) = LAADR 30100014 C SET ADJECTIVE CODE FIELD TO ZERO30200014 ADJCD (NPUT)= 0 30300014 C FOLLOWING CALL TO PUTX HAS THE 30400014 C TEXT ENTRY FOR THE ABOVE 30500014 C GENERATED. 30600014 MTPSET = 1 30700014 C CALL PUTX 30800014 CALL IEKCPX 30900014 C FOLLWOING INITIALIZES A VARIABLE31000014 C WHICH IS TO SERVE AS A COUNTER 31100014 C FOR THE NUMBER OF STATEMENT 31200014 C NUMBERS IN THE STATEMENT. 31300014 NACT1=0 31400014 C FOLLOWING CALL TO GETWD ACCESSES31500014 C THE FIRST (NEXT) STATEMENT 31600014 C NUMBER. 31700014 C CALL GETWD 31800014 1085 CALL IEKCGW 31900014 C INSURE IT IS A CONSTANT. 32000014 C IF IT IS, BRANCH TO CONTINUE 32100014 C PROCESSING. OTHERWISE, FALL THRU32200014 C TO SET THE ERROR MESSAGE NUMBER.32300014 IF(NACCSV.EQ.1) GOTO 1095 32400014 1090 MSGNO=17 32500014 GO TO 1200 32600014 C PREVIOUS INITIAL BRANCH TABLE 32700014 C ENTRY HAS BEEN MADE. 32800014 1065 I = NPTR (2,29) 32900014 C CHAIN NEW ENTRY TO THE LAST. 33000014 CHN (RELOC (NPTR (1,29))) = I 33100014 GOTO 1055 33200014 C FOLLOWING CALL TO LABTLU HAS 33300014 C THE STATEMENT NUMBER ENTRY FOR 33400014 C THE LABEL GENERATED. 33500014 1095 CALL IEKCLT 33600014 C CALL LABTLU 33700014 IF (TBIT(BYA(ILABPT),4)) GO TO 1197 33800014 C SET THE BIT IN THE STATEMENT 33900014 C NUMBER ENTRY INDICATING THAT THE34000014 C LABEL IS THE OBJECT OF A 34100014 C TRANSFER. 34200014 BYA (ILABPT) = BITON (BYA (ILABPT),7) 34300014 C INCREMENT STATEMENT NUMBER 34400014 C COUNTER. 34500014 NACT1=NACT1+1 34600014 C SET THE BIT IN THE STATEMENT 34700014 C NUMBER ENTRY INDICATING THAT THE34800014 C LABEL IS USED IN A COMPUTED GO 34900014 C TO STATEMENT. 35000014 BYB (ILABPT) = BITON (BYB (ILABPT),7) 35100014 C 35110014 C INSURE SUFFICIENT DICTIONARY SPACE. 35120014 C 35130014 IF(NPTR (2,29) + 16 .GT. NPTR (2,30)) CALL IEKAGC (2) 35140014 C 35150014 C SET CHAIN ADDRESS INTO INITIAL 35200014 C (PREVIOUS STANDARD) BRANCH TABLE35300014 C ENTRY. 35400014 INDSV = IND (LAADR) 35500014 CHN (LAADR) = NPTR (2,29) 35600014 IND (LAADR) = INDSV 35700014 C SAVE ADDRESS OF THE NEXT 35800014 C AVAILABLE DICTIONARY LOCATION. 35900014 LAADR=NPTR(2,29) 36000014 I=NPTR(2,29) 36100014 C UPDATE LOCATION OF LAST ENTRY. 36200014 RELOC (NPTR (1,29)) = I 36300014 C INCREMENT POINTER TO THE NEXT 36400014 C AVAILABLE DICTIONARY LOCATION. 36500014 NPTR (2,29) = NPTR (2,29) + 16 36600014 C SET ADDRESS OF STATEMENT NUMBER 36900014 C ENTRY INTO STANDARD BRANCH 37000014 C TABLE ENTRY. 37100014 PTRSN (I) = ILABPT 37200014 C FOLLOWING TESTS THE DELIMITER 37300014 C FOLLOWING THE STATEMENT NUMBER 37400014 C JUST PROCESSED. 37500014 C IF THE DELIMITER IS A COMMA, 37600014 C INDICATING THE PRESENCE OF 37700014 C ANOTHER STATEMENT NUMBER, BRANCH37800014 C BACK TO ACCESS THE STATEMENT 37900014 C NUMBER. 38000014 IF(NDELM.EQ.NCOMA) GOTO 1085 38100014 C IF THE DELIMITER IS NOT A 38200014 C RIGHT PAREN, THE ONLY VALID 38300014 C DELIMITERS AT THIS POINT. BRANCH38400014 C TO SET ERROR MESSAGE NUMBER. 38500014 IF(NDELM.NE.NRTPR) GOTO 1090 38600014 C END OF THE STATEMENT NUMBERS IS 38700014 C REACHED. 38800014 C FOLLOWING CALL TO GETWD ACCESSES38900014 C THE ELEMENT FOLLOWING THE RIGHT 39000014 C PAREN. 39100014 C CALL GETWD 39200014 CALL IEKCGW 39300014 C THE ELEMENT MUST BE A COMMA IF 39400014 C THE STATEMENT IS SYNTACTICALLY 39500014 C CORRECT. IF IT IS NOT,FALL 39600014 C THRU TO 39700014 C SET THE ERROR MESSAGE NUMBER. 39800014 IF(LENGTH.EQ.0.AND.NDELM.EQ.NCOMA) GOTO 1110 39900014 MSGNO = 205 40000014 C CALL ERROR 40100014 NERSW = 6 40200014 CALL IEKCDP 40300014 GOTO 1115 40400014 C FOLLOWING CALL TO GETWD ACCESSES40500014 C THE ELEMENT FOLLOWING THE COMMA.40600014 C IT MUST BE AN INTEGER VARIABLE 40700014 C IF THE STATEMENT IS CORRECT. 40800014 C CALL GETWD 40900014 1110 CALL IEKCGW 41000014 C INSURE IT IS A VARIABLE. 41100014 1115 IF (NACCSV.NE.2) GO TO 1120 41200014 C FOLLOWING CALL TO COMSYM HAS THE41300014 C VARIABLE PACKED, ONE CHARACTER 41400014 C PER BYTE, AND 41500014 C THE DICTIONARY ENTRY FOR THE 41600014 C VARIABLE GENERATED, OR RETRIEVED41700014 C CALL COMSYM 41800014 CALL IEKCS3 41900014 C FOLLOWING INSURES THAT THE 42000014 C VARIABLE IS AN INTEGER. IF IT 42100014 C IS, CONTINUE 42200014 C PROCESSING. OTHERWISE, BRANCH 42300014 C TO SET THE ERROR MESSAGE NUMBER.42400014 IF(MDD (IDCTPT) .LE. 5) GO TO 1130 42500014 1120 MSGNO=21 42600014 GO TO 1200 42700014 C ADD THE NUMBER OF STATEMENT 43100014 C NUMBERS REFERENCED IN THIS 43200014 C ENTRY (+4 FOR FALL-THRU). 43300014 1130 NPTR (2,18) = NPTR (2,18) + 4 * NACT1 + 4 43400014 C SET THE ADDRESS OF THE VARIABLE 43500014 C INTO THE TEXT ENTRY OF THE 43600014 C COMPUTED GO TO LOAD (ADJ. CODE =43700014 C 88). 43800014 TPTR (ISAVE) = IDCTPT 43900014 C SET THE MODE OF THE VARIABLE 44000014 C INTO THE SAME TEXT ENTRY. 44100014 TMOD (ISAVE) = MDD (IDCTPT) 44200014 C SET THE SAME INFORMATION INTO 44300014 C THE TEXT ENTRY OF THE COMPUTED 44400014 C GO TO STATEMENT (ADJ. CODE =250)44500014 TPTR (ISAVE1) = IDCTPT 44600014 TMOD (ISAVE1) = MDD (IDCTPT) 44700014 C ZERO LOCATION HOLDING THE 44800014 C ADDRESS OF THE TEXT ENTRY FOR 44900014 C THE COMPUTED GO TO LOAD. 45000014 TMOD (NPUT) = 254 45100014 TPTR(NPUT) = NACT1 * 4 45200014 ADJCD (NPUT) = 65 45300014 ISAVE=0 45400014 MTPSET = 1 45500014 C CALL PUTX 45600014 CALL IEKCPX 45700014 C FOLLOWING INSURES THAT THE NEW 45800014 C DELIMITER IS THE END MARK. IF IT45900014 C IS NOT, BRANCH TO RECORD THE 46000014 C ERROR. 46100014 IF(NDELM.NE.NGPMK) GOTO 1030 46200014 C FOLLOWING CALL TO CLOSE HAS THE 46300014 C TEXT ENTRY SIGNIFYING THE END OF46400014 C INTERMEDIATE TEXT GENERATED. 46500014 C CALL CLOSE 46600014 NCLSTX = 1 46700014 C CALL PUTX 46800014 CALL IEKCPX 46900014 C FOLLOWING SETS LBSWG ON, 47000014 C INDICATING TO LABTLU THAT THE 47100014 C STATEMENT NUMBER TO BE ENTERED 47200014 C IS A GENERATED LABEL. 47300014 1140 LBSWG = 1 47400014 C FOLLOWING CALL TO LABTLU HAS THE47500014 C STATEMENT NUMBER ENTRY FOR THE 47600014 C GENERATED LABEL GENERATED. 47700014 C CALL LABTLU 47800014 CALL IEKCLT 47900014 ADJCD (NPUT) = 223 48000014 C 48020017 C TEST FOR ASSIGNED GO TO STATEMENT 48040017 C 48060017 IF(NACCSV.EQ.2.AND.NXG.EQ.1)GO TO 1141 48080017 C SET THE BIT IN THE STATEMENT 48100014 C NUMBER ENTRY INDICATING THAT THE48200014 C LABEL IS USED IN A COMPUTED 48300014 C GO TO STATEMENT. 48400014 BYB (ILABPT) = BITON (BYB (ILABPT),7) 48500014 1141 CONTINUE 48550017 C TEST IF THE GENERATED LABEL IS 48600014 C FOR A LOGICAL-IF-STATEMENT. IF 48700014 C IT IS, THE BRANCH OCCURS. 48800014 IF(NXG.EQ.1) GOTO 1185 48900014 C GO TO IS NOT PART OF THE IF 49000014 C STATEMENT. 49100014 C SET THE ADDRESS OF THE STATEMENT49200014 C NUMBER ENTRY FOR THE GENERATED 49300014 C LABEL AS THE FALL-THROUGH LABEL 49400014 C IN THE TEXT ENTRY OF THE 49500014 C COMPUTED GO TO (ADJ.CODE = 250) 49600014 PTRSN (NCOMEX) = ILABPT 49700014 C BRANCH TO END ROUTINE. 49800014 GO TO 9999 49900014 C FOLLOWING OPERATION HANDLES THE 50000014 C ASSIGNED GO TO STATEMENT. 50100014 C INSURE THAT A COMMA FOLLOWS 50200014 C THE VARIABLE. 50300014 1145 IF(NDELM.NE.NCOMA) GOTO 1195 50400014 C FOLLOWING CALL TO COMSYM HAS THE50500014 C THE VARIABLE PACKED, ONE 50600014 C CHARACTER PER BYTE, AND THE 50700014 C DICTIONARY ENTRY FOR THE 50800014 C VARIABLE GENERATED, OR RETRIEVED50900014 C CALL COMSYM 51000014 CALL IEKCS3 51100014 C FOLLOWING INSURES THAT THE 51200014 C VARIABLE IS AN INTEGER. IF IT 51300014 C IS, BRANCH TO CONTINUE 51400014 C PROCESSING. OTHERWISE, FALL THRU51500014 C TO SET THE ERROR MESSAGE NUMBER.51600014 IF(MDD (IDCTPT) .LE. 5) GO TO 1150 51700014 MSGNO=22 51800014 GO TO 1200 51900014 C SET ADJECTIVE CODE FOR THE 52000014 C ASSIGNED GO TO IN THE TEXT WORK 52100014 C AREA. 52200014 1150 ADJCD (NPUT) = 71 52300014 C FOLLOWING CALL TO PUTX HAS THE 52400014 C ABOVE TEXT ENTRY GENERATED. 52500014 C CALL PUTX 52600014 CALL IEKCPX 52700014 C FOLLOWING CALL TO GETWD ACCESSES52800014 C THE ELEMENT FOLLOWING THE COMMA.52900014 C CALL GETWD 53000014 CALL IEKCGW 53100014 C INSURE THAT A LEFT PAREN 53200014 C IMMEDIATELY FOLLOWS THE COMMA. 53300014 C IF IT DOES, BRANCH TO CONTINUE 53400014 C PROCESSING. 53500014 IF(LENGTH.EQ.0.AND.NDELM.EQ.NLFPR) GOTO 1160 53600014 MSGNO=19 53700014 GO TO 1200 53800014 C INSURE THAT A COMMA DELIMITS 53900014 C THE STATEMENT NUMBER. IF IT 54000014 C DOES NOT, BRANCH TO SET THE 54100014 C ERROR. 54200014 1155 IF(NDELM.NE.NCOMA) GOTO 1090 54300014 C 54400014 C SET ADJECTIVE CODE FOR ASSIGN 54500014 C LABEL. 54600014 1160 ADJCD (NPUT) = 232 54700014 C FOLLOWING CALL TO GETWD ACCESSES54800014 C THE NEXT ELEMENT. 54900014 C CALL GETWD 55000014 CALL IEKCGW 55100014 C IF THE ELEMENT IS NOT A 55200014 C CONSTANT, BRANCH TO SET THE 55300014 C ERROR. 55400014 IF(NACCSV.NE.1) GOTO 1090 55500014 C FOLLOWING CALL TO LABTLU HAS A 55600014 C STATEMENT NUMBER ENTRY FOR THE 55700014 C LABEL GENERATED. 55800014 C CALL LABTLU 55900014 CALL IEKCLT 56000014 IF(TBIT (BYA (ILABPT),4)) GO TO 1197 56100014 C SET THE BIT IN THE STATEMENT 56200014 C NUMBER ENTRY INDICATING THAT THE56300014 C LABEL IS THE OBJECT OF A 56400014 C TRANSFER. 56500014 BYA (ILABPT) = BITON (BYA (ILABPT),7) 56600014 MTPSET = -1 56700014 C FOLLOWING CALL TO PUTX HAS THE 56800014 C TEXT ENTRY FOR THE ABOVE LABEL 56900014 C DEFINITION GENERATED. 57000014 C CALL PUTX 57100014 CALL IEKCPX 57200014 C IF THE NEW DELIMITER IS NOT A 57300014 C RIGHT PAREN, INDICATING THAT 57400014 C THE END OF THE STMNT. HAS NOT 57500014 C BEEN REACHED, BRANCH BACK TO 57600014 C CONTINUE PROCESSING. 57700014 IF(NDELM.NE.NRTPR) GOTO 1155 57800014 C INSURE THAT THE END MARK 57900014 C IMMEDIATELY FOLLOWS THE RIGHT 58000014 C PAREN. 58100014 C IF IT DOES, BRANCH TO CLOSE TEXT58200014 C OTHERWISE FALL THRU AND BRANCH 58300014 C TO SET THE ERROR. 58400014 IF (NCDIN(NSCNPT).EQ.NGPMK) GO TO 1175 58500014 MSGNO = 205 58600014 C CALL ERROR 58700014 NERSW = 6 58800014 CALL IEKCDP 58900014 C CALL CLOSE 59000014 1175 NCLSTX = 1 59100014 CALL IEKCPX 59200014 GO TO 9999 59300014 1170 MSGNO=112 59400014 GO TO 1200 59500014 1195 MSGNO=20 59600014 GO TO 1200 59700014 1197 MSGNO = 192 59800014 C CALL ERROR 59900014 1200 NERSW = 6 60000014 CALL IEKCDP 60100014 9999 CONTINUE 60200014 RETURN 60300014 END 60400014 ./ ADD SSI=00010823,NAME=IEKCGW,SOURCE=0 IEKCGW START 0 SUBROUTINE GETWD 00600014 EXTRN IEKCAA 01200014 * 01800014 R EQU 14 02400014 L EQU 15 03000014 DLMADD EQU 1 03600014 DLMCHR EQU 2 04200014 INDEX EQU 3 04800014 MODEX EQU 4 05400014 PH10R EQU 12 06000014 * 06600014 EQUAL EQU 8 07200014 NOTEQ EQU 7 07800014 HIGH EQU 2 08400014 ZERO EQU 8 09000014 ALL EQU 1 09600014 ALWAYS EQU 15 10200014 EJECT 10800014 USING *,L 11400014 BC ALWAYS,*+12 12000014 DC X'0700' 12600014 DC C'IEKCGW' 13200014 STM 14,12,12(13) SAVE REGISTERS 13800014 L PH10R,VPH10 14400014 USING PH10,PH10R 15000014 CLI NTST+3,0 15600014 BC EQUAL,BEGIN BRANCH AT START OF CARD 16200014 IC DLMCHR,NDELM+3 16800014 STC DLMCHR,NPRVDL+3 SET PREVIOUS DELIMITER 17400014 L INDEX,NSCNPT 18000014 * 18600014 SETBEG ST INDEX,NBEGPT SET BEGIN POINTER 19200014 LA DLMADD,NCDIN-1(INDEX) 19800014 LR INDEX,DLMADD SAVE START OF SCAN 20400014 SR DLMCHR,DLMCHR 21000014 SCAN TRT 0(256,DLMADD),TRTAB SCAN FOR DELIMITER 21600014 LTR DLMCHR,DLMCHR 22200014 BC ZERO,UPTRT 22800014 CLI NTST+3,0 23400014 BC EQUAL,SETINT BRANCH IF FIRST CARD 24000014 * 24600014 SETDLM STC DLMCHR,NDELM+3 SET NEW DELIMITER 25200014 SR DLMADD,INDEX 25800014 ST DLMADD,LENGTH COMPUTE LENGTH 26400014 A DLMADD,NSCNPT 27000014 LA DLMADD,1(0,DLMADD) 27600014 ST DLMADD,NSCNPT RESET SCAN POINTER 28200014 CLI 0(INDEX),C'$' 28800014 BC EQUAL,DOLSGN BRANCH ON DOLLAR SIGN 29400014 TM 0(INDEX),X'F0' 30000014 BC ALL,NUMBER BRANCH ON DIGIT 30600014 TM 0(INDEX),X'C0' 31200014 BC ALL,LETTER BRANCH ON LETTER 31800014 MVI NACCSV+3,0 SET CODE = 0 (DELIMITER) 32400014 BC ALWAYS,ROUT 33000014 * 33600014 BEGIN L INDEX,NCARD 34200014 ST INDEX,NSCNPT GET INITIAL SCAN POINTER 34800014 BC ALWAYS,SETBEG 35400014 * 36000014 UPTRT LA DLMADD,256(0,DLMADD) KEEP SCANNING 36600014 BC ALWAYS,SCAN 37200014 * 37800014 SETINT MVI NTST+3,1 RESET SWITCH 38400014 CR DLMADD,INDEX 39000014 BC NOTEQ,ROUT NOT INITIAL DELIMITER 39600014 MVC VCHAR(1),NCARD+15 40200014 CLI VCHAR,51 40800014 BC HIGH,ERROR 41400014 TR VCHAR(1),VECTOR 42000014 TM VCHAR,X'FF' 42600014 BC ALL,SETDLM 43200014 ERROR MVI NCARD+15,59 SYNTAX ERROR 43800014 BC ALWAYS,ROUT 44400014 * 45000014 DOLSGN L MODEX,NMODET+28 SET MODE OF DOLLAR SIGN 45600014 BC ALWAYS,SETMOD 46200014 * 46800014 NUMBER MVI NACCSV+3,1 SET CODE = 1 (NUMBER) 47400014 BC ALWAYS,ROUT 48000014 * 48600014 LETTER SR MODEX,MODEX 49200014 IC MODEX,0(0,INDEX) PICKUP FIRST CHARACTER 49800014 N MODEX,ENDBYT 50400014 SLL MODEX,1 51000014 TM 0(INDEX),X'10' 51600014 BC ALL,ADD1 52200014 TM 0(INDEX),X'20' 52800014 BC ALL,ADD2 53400014 * 54000014 BACK SR INDEX,INDEX 54600014 IC INDEX,NIMPCT-1(MODEX) GET CORRESPONDING MODE 55200014 SLL INDEX,2 55800014 L MODEX,NMODET-4(INDEX) 56400014 SETMOD ST MODEX,NSHFT1 SET MODE FOR SYMTLU 57000014 MVI NACCSV+3,2 SET CODE = 2 (VARIABLE) 57600014 ROUT LM 14,12,12(13) RESTORE REGISTERS 58200014 MVI 12(13),X'FF' 58800014 BCR ALWAYS,R RETURN 59400014 * 60000014 ADD1 LA MODEX,18(0,MODEX) 60600014 BC ALWAYS,BACK 61200014 ADD2 LA MODEX,34(0,MODEX) 61800014 BC ALWAYS,BACK 62400014 EJECT 63000014 * 63600014 * COMMON DEFINITIONS 64200014 * 64800014 PH10 EQU IEKCAA 65400014 NCARD EQU PH10 66000014 NCDIN EQU PH10+X'10' 66600014 NIMPCT EQU PH10+X'580' 67200014 NMODET EQU PH10+X'5B4' 67800014 NBEGPT EQU PH10+X'6B8' 68400014 NSCNPT EQU PH10+X'6BC' 69000014 LENGTH EQU PH10+X'6C0' 69600014 NPRVDL EQU PH10+X'6C4' 70200014 NDELM EQU PH10+X'6C8' 70800014 NTST EQU PH10+X'6CC' 71400014 NACCSV EQU PH10+X'6E0' 72000014 NSHFT1 EQU PH10+X'6EC' 72600014 * 73200014 * CONSTANT AREA 73800014 * 74400014 VPH10 DC A(IEKCAA) 75000014 ENDBYT DC X'0000000F' 75600014 VCHAR DC AL1(0) 76200014 VECTOR DC X'000000FF00FFFFFF',X'00000000FF',XL6'00',X'FF000000FF' 76800014 DC X'00FF00FF0000FFFFFF0000FFFF00FF00000000FFFFFF00FFFF00' 77400014 DC X'00FF' 78000014 * 78600014 * TRANSLATE TABLE 79200014 * 79800014 TRTAB DC 256XL1'00' 80400014 ORG TRTAB+C'.' PERIOD 81000014 DC C'.' 81600014 ORG TRTAB+C'(' LEFT PAREN 82200014 DC C'(' 82800014 ORG TRTAB+C'+' PLUS 83400014 DC C'+' 84000014 ORG TRTAB+X'4F' END MARK 84600014 DC X'4F' 85200014 ORG TRTAB+C'*' ASTERISK 85800014 DC C'*' 86400014 ORG TRTAB+C')' RIGHT PAREN 87000014 DC C')' 87600014 ORG TRTAB+C'-' MINUS 88200014 DC C'-' 88800014 ORG TRTAB+C'/' SLASH 89400014 DC C'/' 90000014 ORG TRTAB+C',' COMMA 90600014 DC C',' 91200014 ORG TRTAB+C'@' QUOTE 91800014 DC C'@' 92400014 ORG TRTAB+C'''' QUOTE 93000014 DC C'''' 93600014 ORG TRTAB+C'=' EQUAL 94200014 DC C'=' 94800014 * 95400014 END 96000014 ./ ADD SSI=02000674,NAME=IEKCIO,SOURCE=0 C SUBROUTINE XIOOP 00100014 SUBROUTINE IEKCIO 00200014 C3660511000 16440 00250016 C1452199300,199600,427000 19345 00270018 C A229090-229900,C233000,D272000,A271200-272800 LL53067 00280021 C A151500-151900,C157000 LL63568 00290021 C 00300014 C DICTIONARY LAYOUT 00400014 C 00500014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00600014 LOGICAL*1 BYA,BYB,BYC 00700014 INTEGER*2 DIS,MDD,TYP 00800014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00900014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01000014 * NAM1,NAM2,NAM3,NAM4 01100014 C 01200014 C 01300014 C LABEL LAYOUT 01400014 C 01500014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 01600014 LOGICAL*1 COMP,DN 01700014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 01800014 C 01900014 C 02000014 C INTERMEDIATE TEXT LAYOUT 02100014 C 02200014 LOGICAL * 1 ADJCD 02300014 INTEGER * 2 TMOD,TTYP 02400014 INTEGER TXTCHN,TPTR 02500014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 02600014 C 02700014 COMMON /IEKAAA/ NPTR (2,35) 02800014 COMMON /IEKAER/ NERTBL (2,50) 02900014 C 03000014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 03100014 INTEGER SLIMS 03200014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 03300014 *M2R3,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 03400014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 03500014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 03600014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 03700014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 03800014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 03900014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 04000014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 04100014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 04200014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 04300014 C 04400014 EQUIVALENCE (NPTR (1,9), NPUT) 04500014 DATA NEND,NERR/Z00C5D5C4,Z00C5D9D9/ 04600014 DATA NX1,NX2/Z0000C9C2,ZC3D6D47B/ 04700014 DATA NAMER1,NAMER2,NAMEW1,NAMEW2/Z0000C6D9,ZC4D5D37B,Z0000C6E6, 04800014 *ZD9D5D37B/ 04900014 DATA IDAVAR/'.DAC'/ 04950016 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC05000014 C C05100014 C XIOOP - IEKCIO C05200014 C C05300014 C FUNCTION - XIOOP DOES SYNTAX CHECKING AND GENERATES INTERMEDIATE C05400014 C TEXT FOR INPUT/OUTPUT STATEMENTS EREAD, WRITE, PRINT, PUNCHN.C05500014 C C05600014 C CALLED BY - DSPTCH, TXTBLD C05700014 C C05800014 C CALLS - PUTX, CLOSE, CSORN, ERROR, GETWD, LABTLU, COMPAT, SYMTLU C05900014 C C06000014 C COMMON - BLANK, PH10 C06100014 C C06200014 C ERRORS - 160, 156, 161, 162, 164, 165 C06300014 C C06400014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC06500014 C 06600014 NEXCSG=1 06700014 NERRS=0 06800014 NENDS=0 06900014 NLFMS=0 07000014 C 07100014 C IF THE I/O ROUTINE NAME IBCOM= HAS 07200014 C BEEN PREVIOUSLY ENTERED, BRANCH. 07300014 C 07400014 IF(NPTR (1,22) .NE.0) GO TO 1005 07500014 C 07600014 C SET NAME AND LENGTH. 07700014 C 07800014 NAME (3) = NX1 07900014 C 08000014 NAME (4) = NX2 08100014 C 08200014 LENGTH = 6 08300014 C 08400014 C GENERATE ENTRY. 08500014 C 08600014 C CALL SYMTLU 08700014 CALL IEKCS2 08800014 C 08900014 C SET TYPE AND BYTE A USAGE. 09000014 C 09100014 TYP (IDCTPT) = 4 09200014 C 09300014 BYA (IDCTPT) = 64 09400014 C 09500014 C SET LOCATION OF IBCOM= ENTRY. 09600014 C 09700014 NPTR (1,22) = IDCTPT 09800014 C 09900014 C OBTAIN POINTER TO START OF STATEMENT.10000014 C 10100014 1005 I = NCARD (1) 10200014 C 10300014 C IF THE FIRST CHARACTER IS NOT A LEFT 10400014 C PAREN, BRANCH. 10500014 C 10600014 IF(NCDIN (I) .NE. NLFPR) GO TO 1200 10700014 C 10800014 C FOLLOWING CALL ACCESSES THE ELEMENT 10900014 C FOLLOWING THE LEFT PAREN. 11000014 C 11100014 C CALL GETWD 11200014 CALL IEKCGW 11300014 C 11400014 C ISURE IT IS NOT A DELIMITER. 11500014 C 11600014 IF(LENGTH .NE. 0) GO TO 1010 11700014 C 11800014 160 MSGNO = 160 11900014 C 12000014 1300 NERSW = 6 12100014 C 12200014 CALL IEKCDP 12300014 C 12400014 C IF THE ELEMENT IS DELIMITED BY AN 12500014 C APOSTROPHE, BRANCH. 12600014 C 12700014 1010 IF(NDELM .EQ. NQUOT) GO TO 1400 12800014 C 12900014 C IF A FIND STATEMENT IS BEING 13000014 C PROCESSED, SET THE ERROR. 13100014 C 13200014 IF(NCARD (4) .EQ. 12) GO TO 160 13300014 C SET ADJECTIVE CODE FOR WRITE. 13400014 C 13500014 1015 ADJCD (NPUT) = 219 13600014 C 13700014 C IF READ, RESET. 13800014 IF(NCARD (4) .EQ. 44) ADJCD (NPUT) = 220 13900014 C IF FIND, RESET. 14000014 IF(NCARD (4) .EQ. 12) ADJCD (NPUT) = 227 14100014 C SET POINTER TO IBCOM=. 14200014 C 14300014 IDCTPT = NPTR (1,22) 14400014 CALL IEKCPX 14500014 C SAVE TEXT LOCATION. 14600014 NOPSAV = LPUT 14700014 C GENERATE ENTRY FOR I/O UNIT. 14800014 C 14900014 C CALL CSORN 15000014 CALL IEKCCR 15100014 C 15150021 C INSURE IT IS NOT HOLLERITH. IF 15160021 C SO, SET ERROR 15170021 C 15180021 IF(NHRETN .EQ. 1 ) GO TO 9977 15190021 C 15200014 C INSURE IT IS AN INTEGER. 15300014 C 15400014 IF(MDD (IDCTPT) .EQ. 5) GO TO 1020 15500014 C 15600014 9977 MSGNO = 166 15700021 C 15800014 GO TO 1300 15900014 C 16000014 C SET I/O UNIT CODE. 16100014 C 16200014 1020 ADJCD (NPUT) = 251 16300014 CALL IEKCPX 16400014 C IF THE UNIT IS FOR DIRECT ACCESS, 16500014 C BRANCH. 16600014 C 16700014 IF(NSUBCT .NE. 0) GO TO 1410 16800014 C 16900014 C IF THE ELEMENT IS NOT DELIMITED BY A 17000014 C COMMA, BRANCH. 17100014 C 17200014 1025 IF(NDELM .NE. NCOMA) GO TO 1105 17300014 C 17400014 C IF A FIND STATEMENT IS BEING 17500014 C PROCESSED, SET THE ERROR. 17600014 C 17700014 IF(NCARD (4) .EQ. 12) GO TO 160 17800014 C CALL GETWD 17900014 CALL IEKCGW 18000014 C 18100014 C INSURE ELEMENT IS NOT A DELIMITER. 18200014 C 18300014 IF(LENGTH .EQ. 0) GO TO 160 18400014 C 18500014 C IF IT IS NOT A CONSTANT, BRANCH. 18600014 C 18700014 IF(NACCSV .NE. 1) GO TO 1045 18800014 C 18900014 C CONSTANT MUST BE A FORMAT LABEL. 19000014 C IF A FORMAT OR NAMELIST HAS NOT YET 19100014 C BEEN PROCESSED, BRANCH. 19200014 C CHECK FOR INVALID POSITIONING OF THE 19230014 C END/ERR PARAMETER. 19260014 C 19300014 IF(NLFMS + NENDS + NERRS .EQ. 0) GO TO 1030 19400014 C 19500014 161 MSGNO = 161 19600014 C 19700014 GO TO 1300 19800014 C 19900014 164 MSGNO=164 19930018 GO TO 1300 19960018 C SET SWITCH INDICATING THAT A FORMAT 20000014 C PARAMETER HAS BEEN ACCESSED. 20100014 C 20200014 1030 NLFMS = 1 20300014 C 20400014 C ENTER FORMAT LABEL. 20500014 C 20600014 C CALL LABTLU 20700014 CALL IEKCLT 20800014 C 20900014 C SET CODE FOR FORMAT LABEL. 21000014 C 21100014 ADJCD (NPUT) = 252 21200014 C 21300014 1035 MTPSET = - 1 21400014 C 21500014 1040 CALL IEKCPX 21600014 C 21700014 GO TO 1025 21800014 C 21900014 C VARIABLE PARAMETER. 22000014 C 22100014 C IF THE VARIABLE IS NOT DELIMITED BY 22200014 C AN EQUAL SIGN, BRANCH. 22300014 C 22400014 1045 IF(NDELM .NE. NEQ) GO TO 1070 22500014 C 22600014 CALL IEKCS1 22700014 C IF THE VARIABLE IS NOT END, BRANCH. 22800014 IF(NAME (4) .NE. NEND) GO TO 1060 22900014 C 22909021 C END PARAMETER. IF IT IS ON A WRITE STMT. ,IGNORE 22918021 C IT. DO NOT PUT OUT TEXT. 22927021 C 22936021 IF(ADJCD(NOPSAV) .NE. 219) GO TO 1044 22945021 C 22954021 C SCAN OVER LABEL AND THEN GO TO CONTINUE SCAN 22963021 C 22972021 1066 CALL IEKCGW 22981021 GO TO 1025 22990021 C 23000014 C INSURE FIRST END. 23100014 C 23200014 1044 IF(NENDS .NE. 0) GO TO 161 23300021 C 23400014 NENDS = 1 23500014 C 23600014 C SET CODE FOR END. 23700014 ADJCD (NPUT) = 230 23800014 C 23900014 C FOLLOWING CALL ACCESSES THE LABEL. 24000014 C 24100014 1050 CALL IEKCGW 24200014 C 24300014 C ISNURE IT IA A CONSTANT. 24400014 C 24500014 IF(NACCSV .EQ. 1) GO TO 1055 24600014 C 24700014 MSGNO = 6 24800014 C 24900014 GO TO 1300 25000014 C 25100014 C CALL LABTLU 25200014 1055 CALL IEKCLT 25300014 C 25400014 C INDICATE THAT THE LABEL IS THE OBJECT25500014 C OF A BRANCH. 25600014 C 25700014 BYA (ILABPT) = BITON (BYA (ILABPT),7) 25800014 C 25900014 GO TO 1035 26000014 C 26100014 C VARIABLE MUST BE ERR. 26200014 C 26300014 1060 IF(NAME (4) .EQ. NERR) GO TO 1065 26400014 C 26500014 MSGNO = 156 26600014 C 26700014 GO TO 1300 26800014 C 26900014 C 27100014 C 27120021 C IF END PARAM ON WRITE , IGNORE IT.DO NOT 27140021 C PUT OUT TEXT 27160021 C 27180021 1065 IF(ADJCD(NOPSAV) .EQ. 219) GO TO 1066 27200021 C 27220021 C INSURE IT IS 1ST ERR 27240021 C 27260021 IF(NERRS .NE. 0) GO TO 161 27280021 C 27300014 NERRS = 1 27400014 C 27500014 C SET CODE FOR ERR. 27600014 C 27700014 ADJCD (NPUT) = 231 27800014 C 27900014 GO TO 1050 28000014 C 28100014 C VARIABLE MUST BE A NAMELIST OR FORMAT28200014 C NAME. 28300014 C INSURE THAT A FORMAT OR NAMELIST WAS 28400014 C NOT PROCESSED. 28500014 C CHECK FOR INVALID POSITIONING OF THE 28530014 C END/ERR PARAMETER. 28560014 C 28600014 1070 IF(NLFMS + NENDS + NERRS .NE. 0) GO TO 161 28700014 C 28800014 C LOOK UP DICTIONARY ENTRY. 28900014 C CALL CSORN 29000014 CALL IEKCCR 29100014 C 29200014 C IF THE VARIABLE IS NOT AN ARRAY, 29300014 C BRANCH. 29400014 C 29500014 IF(LAND (TYP (IDCTPT),M2R3) .NE. 2) GO TO 1080 29600014 C 29700014 C SET CODE FOR OBJECT TIME FORMAT. 29800014 C 29900014 ADJCD (NPUT) = 213 30000014 C 30100014 1075 NLFMS = 1 30200014 C 30300014 GO TO 1040 30400014 C 30500014 C IF THE VARIABLE IS A NAMELIST NAME, 30600014 C BRANCH. 30700014 C 30800014 1080 IF(MDD (IDCTPT) .EQ. 13) GO TO 1085 30900014 C 31000014 165 MSGNO = 165 31100014 C 31200014 GO TO 1300 31300014 C 31400014 C IF THE NAMELIST DOES NOT APPEAR IN A 31500014 C D/A-I/O STATEMENT, BRANCH. 31600014 C 31700014 1085 IF(NSUBCT .EQ. 0) GO TO 1090 31800014 C 31900014 MSGNO = 169 32000014 C 32100014 GO TO 1300 32200014 C 32300014 C RESET READ/WRITE TO INCLUDE NAMELIST.32400014 C 32500014 1090 ADJCD (NOPSAV) = ADJCD (NOPSAV) + 6 32600014 IDCTSV = IDCTPT 32700014 C 32800014 C IF WRITE, BRANCH. 32900014 C 33000014 IF(ADJCD (NOPSAV) .EQ. 225) GO TO 1100 33100014 C 33200014 C ENTER READ-NAMELIST. (FRDNL=) 33300014 C 33400014 NAME (3) = NAMER1 33500014 C 33600014 NAME (4) = NAMER2 33700014 C 33800014 C ENTER IN CHAIN 6. 33900014 C 34000014 1095 LENGTH = 6 34100014 C 34200014 CALL IEKCS2 34300014 C 34400014 C SET BYTE A USAGE AND TYPE. 34500014 C 34600014 BYA(IDCTPT) = 66 34700014 C 34800014 TYP (IDCTPT) = 4 34900014 C 35000014 C RESET POINTER TO IBCOM=. 35100014 C 35200014 TPTR (NOPSAV) = IDCTPT 35300014 C 35400014 C SET CODE FOR NAMELIST. 35500014 C 35600014 ADJCD (NPUT) = 253 35700014 C 35800014 IDCTPT = IDCTSV 35900014 GO TO 1075 36000014 C 36100014 C ENTER WRITE-NAMELIST (FWRNL=). 36200014 C 36300014 1100 NAME (3) = NAMEW1 36400014 C 36500014 NAME (4) = NAMEW2 36600014 C 36700014 GO TO 1095 36800014 C 36900014 C IF THE ELEMENT IS NOT DELIMITED BY A 37000014 C RIGHT PAREN, SET THE ERROR. 37100014 C 37200014 1105 IF(NDELM .NE. NRTPR) GO TO 160 37300014 C END OF PARAMETERS. 37400014 NSUBCT = 0 37500014 C IF A FORMAT AND NAMELIST WERE NOT 37600014 C USED, RESET TO UNFORMATTED. 37700014 C 37800014 IF (NLFMS.EQ.0.AND.NCARD(4).NE.12) ADJCD(NOPSAV) = ADJCD(NOPSAV)-237900014 C 38000014 C ACCESS NEXT ELEMENT. 38100014 C 38200014 1107 CALL IEKCGW 38300014 C 38400014 C IF THE ELEMENT ACCESSED IS A 38500014 C DELIMITER, BRANCH. 38600014 C 38700014 IF(LENGTH .EQ. 0) GO TO 1115 38800014 C 38900014 C I/O LIST FOLLOWS. 39000014 C 39100014 C SET INDICATOR. 39200014 C 39300014 1110 IOSWG = 1 39400014 C 39500014 C RESET SCAN POINTER TO START OF LIST. 39600014 C 39700014 NSCNPT = NBEGPT 39800014 C 39900014 C RESET DELIMITER. 40000014 C 40100014 NDELM = NPRVDL 40200014 C 40300014 C SET CODE TO BEGIN I/O LIST. 40400014 C 40500014 ADJCD (NPUT) = 221 40600014 C 40700014 MTPSET = 1 40800014 C 40900014 CALL IEKCPX 41000014 C 41100014 C SET CODE FOR LIST ITEM. 41200014 C 41300014 ADJCD (NPUT) = 247 41400014 C 41500014 9999 RETURN 41600014 C 41700014 C DELIMITER FOLLOWS PARAMETERS. 41800014 C IF IT IS A LEFT PAREN, INDICATING AN 41900014 C IMPLIED - DO, BRANCH. 42000014 C 42100014 1115 IF(NDELM .EQ. NLFPR) GO TO 1110 42200014 C 42300014 C IF IT IS NOT AN END MARK, SET THE 42400014 C ERROR. 42500014 C 42600014 IF(NDELM.NE.NGPMK.AND.NDELM.NE.NPLUS.AND.NDELM.NE.NDOLAR)GOTO 164 42700018 C 42800014 C CLOSE TEXT. 42900014 C 43000014 1120 NCLSTX = 1 43100014 C 43200014 CALL IEKCPX 43300014 C 43400014 GO TO 9999 43500014 C 43600014 C FIRST CHARACTER OF I/O STATEMENT IS 43700014 C NOT A LEFT PAREN - ASSUME SYSTEM 43800014 C READ/PRINT/PUNCH. 43900014 C 44000014 C INSURE SCAN POINTER IS AT START OF 44100014 C STATEMENT. 44200014 C 44300014 1200 NSCNPT = I 44400014 IF(NCARD (4) .EQ. 51) GO TO 160 44450014 ADJCD (NPUT) = 219 44500014 IF(NCARD (4) .EQ. 44) ADJCD (NPUT) = 220 44600014 IDCTPT = NPTR (1,22) 44700014 CALL IEKCPX 44800014 NAME (3) = 0 44900014 NAME (4) = 1 45000014 IF(NCARD (4) .EQ. 39) NAME (4) = 2 45100014 IF(NCARD (4) .EQ. 40) NAME (4) = 3 45200014 NSHFT1 = 5 45300014 LENGTH = 14 45400014 CALL IEKCS2 45500014 ADJCD (NPUT) = 251 45600014 TPTR (NPUT) = IDCTPT 45700014 MTPSET = 1 45800014 CALL IEKCPX 45900014 CALL IEKCGW 46000014 IF(LENGTH .EQ. 0) GO TO 160 46100014 IF(NACCSV .EQ. 2) GO TO 1210 46200014 CALL IEKCLT 46300014 ADJCD (NPUT) = 252 46400014 MTPSET = - 1 46500014 1205 CALL IEKCPX 46600014 IF(NDELM .EQ. NGPMK) GO TO 1120 46700014 IF(NDELM .NE. NCOMA) GO TO 160 46800014 GO TO 1107 46900014 1210 CALL IEKCS3 47000014 IF(LAND (TYP (IDCTPT),M2R3) .NE. 2) GO TO 165 47100014 ADJCD (NPUT) = 213 47200014 GO TO 1205 47300014 C 47400014 C 47500014 C 47700014 C UNIT IS DELIMITED BY AN APOSTROPHE. 47800014 C 47900014 C DIRECT ACCESS I/O. 48000014 C 48100014 C SET D/A INDICATOR. 48200014 C 48300014 1400 NSUBCT = 1 48400014 C 48500014 C SAVE POINTER TO THE UNIT. 48600014 C 48700014 IUNPTR = NBEGPT 48800014 C 48900014 CALL IEKCGW 49000014 C 49020016 C INITIALIZE SWITCH 49040016 C 49060016 IHALF=0 49080016 C 49100014 C IF THE ELEMENT ACCESSED IS A 49200014 C DELIMITER OR IT IS NOT DELIMITED BY A49300014 C RIGHT PAREN OR 49400014 C COMMA, INDICATING THAT AN EXPRESSION 49500014 C IS USED TO DENOTE THE RELATIVE 49600014 C POSITION, BRANCH. 49700014 IF(LENGTH .EQ. 0 .OR. NDELM .NE. NCOMA .AND. NDELM .NE. NRTPR) 49800014 * GO TO 1415 49900014 C 50000014 C SAVE POINTER TO NEXT ELEMENT AND THE 50100014 C PRESENT ELEMENT'S DELIMITER. 50200014 IEXPND = NSCNPT 50300014 ISVNDL = NDELM 50400014 C GENERATE ENTRY FOR POSITION 50500014 C 50600014 CALL IEKCCR 50700014 C 50800014 C INSURE ELEMENT IS AN INTEGER. 50900014 C 51000014 IF(MDD(IDCTPT).EQ.5) GO TO 1405 51060016 IF (MDD(IDCTPT).EQ.4) GO TO 1413 51120016 C 51200014 MSGNO = 170 51300014 C 51400014 GO TO 1300 51500014 C 51600014 1405 BYC (IDCTPT) = 1 51700014 C 51800014 C SAVE THE LOCATION OF THE ENTRY. 51900014 C 52000014 IRLPOS = IDCTPT 52100014 C RESTORE POINTER TO I/O UNIT. 52200014 C 52300014 1407 NSCNPT = IUNPTR 52400014 C 52500014 C RE-ACCESS UNIT. 52600014 C 52700014 CALL IEKCGW 52800014 C 52900014 GO TO 1015 53000014 C 53100014 C SET CODE FOR RELATIVE POSITION. 53200014 C 53300014 1410 ADJCD (NPUT) = 212 53400014 C 53500014 C RESET POINTER. 53600014 C 53700014 IDCTPT = IRLPOS 53800014 C 53900014 CALL IEKCPX 54000014 C 54100014 C RESET POINTER TO ELEMENT FOLLOWING 54200014 C THE RELATIVE POSITION ELEMENT OR 54300014 C EXPRESION AND THE DELIMITER. 54400014 C 54500014 NSCNPT = IEXPND 54600014 C 54700014 NDELM = ISVNDL 54800014 C 54900014 GO TO 1025 55000014 C 55100014 C EXPRESSION DENOTES RELATIVE POSITION.55200014 C 55300014 C FOLLOWING CREATES TEXT FOR AN 55400014 C ARITHMETIC STATEMENT, SETTING A 55500014 C COMPILER GENERATED VARIABLE (.DAC) = 55600014 C EXPRESSION. 55700014 C THIS VARIABLE WILL THEN BE USED IN 55800014 C THE I/O STATEMENT. 55900014 C 56000014 C SPECIAL HANDLING FOR I*2 56020016 C 56040016 1413 IHALF=IDCTPT 56060016 BYC(IHALF)=1 56080016 C IF THE VARIABLE HAS BEEN PREVIOUSLY 56100014 C ENTERED, BRANCH. 56200014 C 56300014 1415 IF(NSUBSW .NE. 0) GO TO 1420 56400014 C 56500014 C DEFINE AND ENTER. 56600014 C 56700014 NAME (4) = IDAVAR 56800014 C 56900014 NSHFT1 = 5 57000014 I = LENGTH 57100014 LENGTH = 4 57200014 C 57300014 CALL IEKCS2 57400014 LENGTH = I 57500014 BYC (IDCTPT) = 1 57600014 C 57700014 NAM2 (IDCTPT) = BITON (NAM2 (IDCTPT),0) 57800014 C 57900014 C SAVE LOCATION OF .DAC. 58000014 C 58100014 NSUBSW = IDCTPT 58200014 C 58300014 C .DAC IS ENTERED. 58400014 C OBTAIN LOCATION. 58500014 C 58600014 1420 IDCTPT = NSUBSW 58700014 IRLPOS = IDCTPT 58800014 C SET CODE FOR ARITHMETIC STATEMENT. 58900014 C 59000014 ADJCD (NPUT) = 241 59100014 C 59200014 C SET NEW DELIMITER INDICATOR TO AN 59300014 C EQUAL SIGN. 59400014 C 59500014 NDELM = NEQ 59600014 C 59700014 C SET 59800014 C 241 .DAC 59900014 C 60000014 CALL IEKCPX 60100014 C 60200014 C BRANCH IF NOT I*2 VARIABLE 60209016 C 60218016 IF (IHALF.EQ.0) GO TO 1425 60227016 IDCTPT=IHALF 60236016 C 60245016 C GENERATE = VAR 60254016 C 60263016 CALL IEKCPX 60272016 GO TO 1430 60281016 C 60290016 C SET POINTER TO ELEMENT AFTER 60300014 C APOSTROPHE. 60400014 1425 NSCNPT=NBEGPT 60500016 C 60600014 C FOLLOWING CALL TI XARITH HAS THE 60700014 C EXPRESSION PROCESSED. 60800014 C 60900014 NERSW = 1 61000014 C 61100014 CALL IEKCAR 61200014 C 61300014 C EXPRESSION COMPLETED. 61400014 C 61500014 C SAVE THE DELIMITER AND THE POINTER TO61600014 C THE FOLLOWING ELEMENT. 61700014 C 61800014 ISVNDL = NDELM 61900014 C 62000014 IEXPND = NSCNPT 62100014 C 62200014 C CLOSE EXPRESSION TEXT. 62300014 C 62400014 1430 ADJCD(NPUT) = 26 62500016 C 62600014 MTPSET = 1 62700014 C 62800014 CALL IEKCPX 62900014 C 63000014 GO TO 1407 63100014 C 63200014 END 63300014 ./ ADD SSI=01011176,NAME=IEKCLT,SOURCE=0 C SUBROUTINE LABTLU 00300014 SUBROUTINE IEKCLT 00600014 C1170477000 000B 00700016 C 00900014 C 01200014 C LABEL LAYOUT 01500014 C 01800014 INTEGER BPC,PB,SN,SEQPTR,BSZ 02100014 INTEGER*2 ISNCHN,CHNEND,WRTCNT,PAD,NTRY 02400014 LOGICAL * 1 BYA,BYB,COMP,DN 02700014 STRUCTURE // BPC,BYA,BYB,COMP,DN,PB,SN,PAD,CHNEND,WRTCNT,ISNCHN, 03000014 *ISNDEF,BSZ,SEQPTR 03300014 C 03600014 COMMON /IEKAAA/ NPTR (2,35) 03900014 COMMON /IEKAAD/ NADSIZ,NTRY(1000) 04200014 COMMON /IEKAER/ NERTBL (2,50) 04500014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 04800014 INTEGER SLIMS 05100014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 05400014 *M2R3,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 05700014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 06000014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 06300014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 06600014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 06900014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 07200014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 07500014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 07800014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 08100014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 08400014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC08700014 C C09000014 C LABTLU - IEKCLT C09300014 C C09600014 C STATUS - CHANGE LEVEL 0 C09900014 C C10200014 C FUNCTION - LABTLU PROCESSES BOTH SOURCE AND GENERATED LABELS. IT C10500014 C GENERATES TEXT IN THE STATEMENT NUMBER/ARRAY TABLE AND C10800014 C INDICATES WHETHER THE LABEL IS BEING DEFINED OR REFERENCED. C11100014 C C11400014 C CALLED BY - XCLASS, GENDO, GRPKEQ, RTPRQT, PERLOG, XGO, DSPTCH, C11700014 C XDO, XIMPD, XIOOP, XSUBPG, XASGN C12000014 C C12300014 C CALLS - ERROR, LITCON, SYSDIR C12600014 C C12900014 C COMMON - BLANK, PH10 C13200014 C C13500014 C ERRORS - 112 C13800014 C C14100014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC14400014 C 14700014 C SUBROUTINE LABTLU HANDLES 15000014 C SOURCE AND GENERATED LABELS. IT 15300014 C MAKES THE APPROPRIATE STATEMENT15600014 C NUMBER ENTRY FOR THE LABEL. UPON15900014 C 16200014 C LABTLU ALSO SETS THE APPROPRIATE16500014 C BITS IN THE STATEMENT NUMBER 16800014 C ENTRY INDICATING WHETHER THE 17100014 C LABEL IS REFERENCED OR DEFINED, 17400014 C AND SOURCE OR COMPILER 17700014 C GENERATED. 18000014 C 18300014 C 18600014 C FOLLOWING DETERMINES IF THE 18900014 C LABEL TO BE ENTERED IS A SOURCE 19200014 C OR GENERATED LABEL. IF LBSWG, 19500014 C SET BY THE CALLING ROUTINE, IS 19800014 C EQUAL TO ONE, THE LABEL IS A 20100014 C GENERATED LABEL AND THE BRANCH 20400014 C OCCURS. 20700014 IF(LBSWG .EQ. 1) GO TO 1001 21000014 C FOLLOWING CALL TO LITCON HAS THE21300014 C SOURCE LABEL CONVERTED TO ITS 21600014 C BINARY EQUIVALENT FORM. THE 21900014 C CONVERTED LABEL IS PLACED, BY 22200014 C LITCON, IN NAMEE4N. 22500014 C CALL LITCON 22800014 CALL IEKCLC 23100014 C IF THE CONVERTED ELEMENT WAS NOT23400014 C AN INTEGER OR WAS GREATER THAN 523700014 C CHARACTERS, SET THE ERROR. 24000014 IF(NNT .EQ. 1 .AND. NAME (4) .LE. 99999) GO TO 1003 24300014 MSGNO = 6 24600014 C CALL ERROR 24900014 1300 NERSW = 6 25200014 CALL IEKCDP 25500014 C GENERATED LABEL. 25800014 C SET VALUE. 26100014 1001 LABCMP = NGENLB 26400014 C INCREMENT VALUE. 26700014 NGENLB = NGENLB + 1 27000014 GO TO 1015 27300014 C SAVE THE CONVERTED LABEL. 27600014 1003 LABCMP = NAME(4) 27900014 C SAVE POINTER TO LABEL CHAIN. 28200014 1015 ILABPT = NPTR (2,17) 28500014 IF((NPTR(2,29)+32).GT.NPTR(2,30).OR.LAND(NPTR(1,3),256).NE.0.AND. 28800014 *(NPTR(2,29)+36).GT.NPTR(2,30)) CALL IEKAGC(2) 29100014 C FOLLOWING DETERMINES IF A 29400014 C PREVIOUS STATEMENT NUMBER ENTRY 29700014 C HAS BEEN MADE. 30000014 C IF IT HAS, 30300014 C BRANCH TO SEARCH FOR END OF 30600014 C CHAIN. 30900014 IF(ILABPT .NE. 0) GO TO 1043 31200014 C FOLLOWING SETS UP FOR INITIAL 31500014 C ENTRY. 31800014 C SET POINTER TO NEXT AVAILABLE 32100014 C DICTIONARY LOCATION, WHICH WILL 32400014 C BE USED AS THE ENTRY, INTO THE 32700014 C COMMUNICATION AREA. 33000014 1025 NPTR(2,17)=NPTR(2,29) 33300014 C SET LOCATION TO BE USED FOR THE 33600014 C ENTRY. 33900014 1030 ILABPT = NPTR (2,29) 34200014 C SVE LOCATION OF LAST ENTRY. 34500014 1031 PB(NPTR(2,17))=ILABPT 34800014 C UPDATE POINTER TO NEXT AVAILABLE35100014 C DICTIONARY LOCATION. 35400014 NPTR (2,29) = NPTR (2,29) + 32 35700014 C IF XREF REQUESTED, EXTEND DICT. 36000014 C ENTRY BY ONE WORD. 36300014 IF(LAND(NPTR(1,3),256).NE.0) NPTR(2,29)=NPTR(2,29)+4 36600014 C SET LABEL INTO DICTIONARY. 36900014 SN(ILABPT) = LABCMP 37200014 C IF THE LABEL IS A GENERATED 37500014 C LABEL, BRANCH. 37800014 IF(LBSWG .EQ. 1) GO TO 1060 38100014 C FOLLOWING DETERMINES IF LABEL IS38400014 C BEING REFERENCED BY TESTING ITS 38700014 C POSITION IN THE CARD INPUT AREA.39000014 C FOLLOWING INSURES THAT BIT 1 OF 39300014 C BYTE A FOR THE LABEL5S ENTRY IS 39600014 C ON, INDICATING THAT THE LABEL IS39900014 C REFERENCED. 40200014 1035 IF(NBEGPT .GT. 6) BYA (ILABPT) = BITON (BYA (ILABPT),1) 40500014 C 40800014 C ************************************ 41100014 C ***** THE FOLLOWING SECTION OF ***** 41400014 C ***** CODE BUILDS XREF ENTRIES ***** 41700014 C ***** FOR LABELS ***** 42000014 C ************************************ 42300014 C 42600014 C IF XREF NOT REQUESTED BYPASS XREF 42900014 IF(LAND(NPTR(1,3),256).EQ.0) GOTO 9999 43200014 C IF LABEL NOT DEFINED IN THIS 43500014 C STATEMENT, BRANCH 43800014 IF(NBEGPT.GT.6) GOTO 1036 44100014 C IF LABEL IS MULTIPLY DEFINED, BRANCH 44400014 IF(ISNDEF(ILABPT).NE.0) GOTO 1038 44700014 C PUT ISN IN DICTIONARY ENTRY AS 45000014 C DEFINING ISN, THEN EXIT 45300014 ISNDEF(ILABPT)=ISN 45600014 GOTO 9999 45900014 C SET DEFINING ISN TO ALL ONES TO 46200014 C INDICATE MULTIPLY DEFINED. 46500014 1038 ISNDEF(ILABPT)=-1 46800014 GOTO 9999 47100014 C IF XREF BUFFER IS FULL, WRITE IT OUT 47400014 1036 IF (NPTR(1,19) .GE. NPTR(2,8)-4) CALL IEKXRS 47700016 C GET PTR TO NEXT AVAILABLE SLOT IN 48000014 C XREF BUFFER 48300014 NDEX=NPTR(1,19)/2+1 48600014 C IF NOT ZERO, THIS IS NOT FIRST USE 48900014 C OF THIS LABEL 49200014 IF(CHNEND(ILABPT).NE.0) GOTO 1037 49500014 C PUT DISK WRITE NUMBER IN XREF ENTRY 49800014 1047 NTRY(NDEX)=WRTCNT(ILABPT) 50100014 C PUT NEW DISK WRITE NUMBER IN 50400014 C DICTIONARY ENTRY 50700014 WRTCNT(ILABPT)=NPTR(2,20) 51000014 C INCREMENT TO SECOND HALF OF XREF 51300014 C ENTRY 51600014 NDEX=NDEX+1 51900014 C PUT PTR TO FIRST XREF ENTRY INTO 52200014 C CURRENT XREF ENTRY FROM DICTIONARY 52500014 C ENTRY. THIS XREF ENTRY NOW GIVES THE52800014 C DISK WRITE NUMBER OF THE LAST DISK 53100014 C WRITE IN WHICH THIS LABEL WAS USED 53400014 C AND CONTAINS A PTR TO THE FIRST 53700014 C REFERENCE TO THE LABEL IN THAT DISK 54000014 C WRITE. 54300014 NTRY(NDEX)=ISNCHN(ILABPT) 54600014 C INCREMENT POINTER TO NEXT AVAILABLE 54900014 C XREF SLOT 55200014 NPTR(1,19)=NPTR(1,19)+4 55500014 C SET PTR TO FIRST XREF ENTRY IN 55800014 C DICTIONARY TO CURRENT XREF ENTRY. 56100014 ISNCHN(ILABPT)=NPTR(1,19) 56400014 GOTO 1039 56700014 C IF LAST REFERENCE TO LABEL (LAST 57000014 C XREF ENTRY) IS IN A BLOCK PREVIOUSLY 57300014 C WRITTEN ON DISK, SET UP POINTERS TO 57600014 C IT. 57900014 1037 IF(WRTCNT(ILABPT).NE.NPTR(2,20)) GOTO 1047 58200014 C GET PTR TO LAST XREF ENTRY FOR LABEL.58500014 NDEX=CHNEND(ILABPT)/2+1 58800014 C SET PTR IN LAST XREF ENTRY TO POINT 59100014 C TO CURRENT XREF ENTRY 59400014 NTRY(NDEX)=NPTR(1,19) 59700014 C SET PTR TO LAST XREF IN DICTIONARY 60000014 C ENTRY TO POINT TO CURRENT XREF ENTRY 60300014 1039 CHNEND(ILABPT)=NPTR(1,19) 60600014 C PICK UP ISN 60900014 NISN=ISN 61200014 C IF THIS IS AN 'IF' TRAILER, DECREMENT61500014 C ISN BY 1 61800014 IF(IFTRLG.EQ.2) NISN=NISN-1 62100014 C GET PTR TO CURRENT XREF ENTRY. 62400014 NDEX=NPTR(1,19)/2+1 62700014 C SET PTR TO NEXT XREF ENTRY TO ZERO. 63000014 NTRY(NDEX)=0 63300014 C INCREMENT TO SECOND HALF OF XREF 63600014 C ENTRY. 63900014 NDEX=NDEX+1 64200014 C PUT ISN IN XREF ENTRY 64500014 NTRY(NDEX)=NISN 64800014 C INCREMENT POINTER TO NEXT AVAILABLE 65100014 C XREF SLOT 65400014 NPTR(1,19)=NPTR(1,19)+4 65700014 C 66000014 C ************************************ 66300014 C 66600014 C RETURN CONTROL. 66900014 GO TO 9999 67200014 C IF THE LABEL IS A SOURCE 67500014 C LABEL, BRANCH. 67800014 1043 IF(LBSWG .EQ. 0) GO TO 1045 68100014 C OBTAIN LOCATION OF LAST LABEL. 68400014 ILABPT = PB (NPTR (2,17)) 68700014 GO TO 1055 69000014 C PREVIOUS ENTRY HAS BEEN MADE. 69300014 C COMPARE PRESENT LABEL TO 69600014 C PREVIOUS LABEL. IF EQUAL, BRANCH69900014 1045 IF(SN (ILABPT) .EQ. LABCMP) GO TO 1035 70200014 C LABELS ARE NOT THE SAME. 70500014 C FOLLOWING DETERMINES IF THE END 70800014 C OF THE STATEMENT NUMBER CHAIN 71100014 C HAS BEEN REACHED. IF IT HAS, 71400014 C BRANCH. 71700014 IF(BPC (ILABPT) .EQ. 0) GO TO 1055 72000014 C END OF CHAIN NOT REACHED. 72300014 C OBTAIN POINTER TO NEXT ENTRY. 72600014 ILABPT = BPC (ILABPT) 72900014 C BRANCH BACK TO CONTINUE SEARCH. 73200014 GOTO 1045 73500014 C END OF CHAIN HAS BEEN REACHED. 73800014 C CHAIN ADDRESS OF NEW ENTRY TO 74100014 C LAST ENTRY. 74400014 1055 BPC (ILABPT) = NPTR (2,29) 74700014 C 75000014 C *************************** 75300014 C ***** SEQUENCE LABELS ***** 75600014 C *************************** 75900014 C 76200014 C IF GENERATED LABEL OR IF XREF NOT 76500014 C REQUESTED, BYPASS XREF 76800014 IF((LBSWG.EQ.1.OR.LAND(NPTR(1,3),256).EQ.0)) GOTO 1030 77100014 C IF THIS IS FIRST LABEL ENCOUNTERED, 77400014 C BRANCH 77700014 IF(NPTR(2,7).EQ.0) GOTO 1040 78000014 C GET ADDRESS OF DICT. ENTRY FOR LAST 78300014 C LABEL (SEQUENCED) 78600014 NDEX=NPTR(2,7) 78900014 C IF THIS LABEL NOT LARGEST 79200014 C ENCOUNTERED, BRANCH 79500014 IF(SN(NDEX).GT.LABCMP) GOTO 1041 79800014 C LABEL IS LAST IN SEQUENCE. CHAIN 80100014 C DICT. ENTRY TO END OF SEQUENCE CHAIN 80400014 SEQPTR(NDEX)=NPTR(2,29) 80700014 C PUT ADDRESS OF DICT. ENTRY IN NPTR 81000014 C TABLE AS LAST IN SEQUENCE 81300014 1042 NPTR(2,7)=NPTR(2,29) 81600014 GOTO 1030 81900014 C PUT ADDRESS OF DICT. ENTRY FOR FIRST 82200014 C LABEL IN NPTR TABLE 82500014 1040 NPTR(1,7)=NPTR(2,29) 82800014 GOTO 1042 83100014 C SET LOCATION TO BE USED FOR THE 83400014 C ENTRY 83700014 1041 ILABPT=NPTR(2,29) 84000014 C SET INDEX TO POINT TO FIRST LABEL IN 84300014 C CHAIN 84600014 NDEX=NPTR(1,7) 84900014 C IF CURRENT LABEL IS SMALLER THAN 85200014 C FIRST IN CHAIN, BRANCH 85500014 IF(LABCMP.LT.SN(NDEX)) GOTO 1046 85800014 C SAVE INDEX 86100014 1044 NDEX1=NDEX 86400014 C ADVANCE TO NEXT DICT. ENTRY IN 86700014 C SEQUENCED CHAIN 87000014 NDEX=SEQPTR(NDEX) 87300014 C IF CURRENT LABEL GREATER, ADVANCE TO 87600014 C NEXT DICT. ENTRY 87900014 IF(LABCMP.GT.SN(NDEX)) GOTO 1044 88200014 C POINT CURRENT ENTRY TO NEXT HIGHER 88500014 C ENTRY 88800014 SEQPTR(ILABPT)=SEQPTR(NDEX1) 89100014 C POINT NEXT LOWER ENTRY TO CURRENT 89400014 C ENTRY 89700014 SEQPTR(NDEX1)=ILABPT 90000014 GOTO 1031 90300014 C CHAIN CURRENT ENTRY INTO BEGINNING OF90600014 C CHAIN 90900014 1046 SEQPTR(ILABPT)=NPTR(1,7) 91200014 C PUT ADDRESS OF CURRENT ENTRY IN NPTR 91500014 C AS FIRST 91800014 NPTR(1,7)=ILABPT 92100014 GOTO 1031 92400014 C 92700014 C *************************** 93000014 C 93300014 C LABEL IS A GENERATED LABEL. 93600014 C ZERO GENERATED LABEL SWITCH. 93900014 1060 LBSWG=0 94200014 C SET BITS INDICATING LABEL IS 94500014 C REFERENCED AND IS OBJECT OF A 94800014 C TRANSFER. 95100014 BYA (ILABPT) = 65 95400014 C SET BIT INDICATING LABEL IS A 95700014 C GENERATED LABEL. 96000014 BYB (ILABPT) = 64 96300014 9999 CONTINUE 96600014 RETURN 96900014 END 97200014 ./ ADD SSI=01012180,NAME=IEKCPX,SOURCE=0 C SUBROUTINE PUTX 00200014 SUBROUTINE IEKCPX 00400014 C 460200-461800 24244 00500020 C 00600014 C DICTIONARY LAYOUT 00800014 C 01000014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 01200014 LOGICAL*1 BYA,BYB,BYC 01400014 INTEGER*2 DIS,MDD,TYP 01600014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 01800014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 02000014 * NAM1,NAM2,NAM3,NAM4 02200014 C 02400014 C 02600014 C INTERMEDIATE TEXT LAYOUT 02800014 C 03000014 LOGICAL * 1 ADJCD 03200014 INTEGER * 2 TMOD,TTYP 03400014 INTEGER TXTCHN,TPTR 03600014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 03800014 C 04000014 C LABEL LAYOUT 04200014 C 04400014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 04600014 LOGICAL*1 COMP,DN 04800014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 05000014 C 05200014 COMMON /IEKAAA/ NPTR (2,35) 05400014 COMMON /IEKAER/ NERTBL (2,50) 05600014 C 05800014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 06000014 INTEGER SLIMS 06200014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 06400014 *NBLK,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 06600014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 06800014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 07000014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 07200014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 07400014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 07600014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 07800014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 08000014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 08200014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 08400014 C 08600014 EQUIVALENCE (NPTR(1,9),NPUT) 08800014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC09000014 C C09200014 C PUTX - IEKCPX C09400014 C C09600014 C 09800014 C FUNCTION - PUTX CHAINS THE NEW TEXT ENTRY, SET UP BY THE CALLING 10000014 C ROUTINE, TO THE PREVIOUS TEXT ENTRY. IT THEN SETS THE NEXT 10200014 C OPERATOR OF THE SOURCE STATEMENT INTO THE NEXT TEXT ENTRY TO 10400014 C BE USED. 10600014 C 10800014 C CALLED BY - XARITH, XCLASS, GENDO, XCONT, XSTOP, RTPRQT, XPUSE, C11000014 C GRPKEQ, PERLOG, XDATA, XGO, DSPTCH, XNMLST, XDO, XBCKRW, C11200014 C XIMPD, XFMT, MINSLS, XEND, XIF, CLOSE, COMAST, TXTBLD C11400014 C XIOOP, XRETN, XSUBPG, XASF2, XASGM C11600014 C C11800014 C CALLS - ERROR, GETCOR C12000014 C C12200014 C COMMON - BLANK, PH10, P10A C12400014 C C12600014 C ERRORS - 13 C12800014 C C13000014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC13200014 C 13400014 C 13600014 C 13800014 C OBTAIN TYPE OF TEXT INDICATOR. 14000014 C 0 = NORMAL 14200014 C 1 = DATA 14400014 C 2 = FORMAT 14600014 C 3 = NAMELIST 14800014 C 4 = STATEMENT FUNCTION 15000014 C 15= DEFINE FILE 15200014 C 15400014 NTAB = NPTR (1,8) 15600014 C 15800014 C IF THE CLOSING OF A TEXT ENTRY IS 16000014 C CALLED FOR, BRANCH. 16200014 C 16400014 IF(NCLSTX .EQ. 1) GO TO 300 16600014 C 16800014 C IF NORMAL TEXT, BRANCH. 17000014 C 17200014 1010 IF(NTAB .EQ. 0) GO TO 1015 17400014 C 17600014 C SPECIAL TEXT. 17800014 C IF NTAB IS LESS THAN 5, I.E. THIS IS 18000014 C THE START OF SPECIAL 18200014 C TEXT STATEMENT, BRANCH. 18400014 C 18600014 IF(NTAB .LT. 5) GO TO 1073 18800014 C 19000014 C NOT FIRST SPECIAL TEXT ENTRY. 19200014 C RESET INDICATOR. 19400014 C 19600014 NTAB = NTAB - 10 19800014 C 20000014 GO TO 1075 20200014 C 20400014 C NORMAL TEXT. 20600014 C FOLLOWING CHAINS THE NEW ENTRY TO THE20800014 C PREVIOUS ENTRY. 21000014 C 21200014 1015 CODESV = ADJCD (LPUT) 21400014 C 21600014 TXTCHN (LPUT) = NPUT 21800014 C 22000014 ADJCD (LPUT) = CODESV 22200014 C 22400014 C RESET LOCATION OF LAST TEXT ITEM. 22600014 C 22800014 1035 LPUT = NPUT 23000014 C 23200014 C BRANCH ACCORDING TO TYPE OF ENTRY. 23400014 C 23600014 IF(MTPSET) 1038,1037,1039 23800014 C 24000014 C MTPSET = 0, I.E. TEXT IS FOR A 24200014 C DICTIONARY ENTRY. 24400014 C SET MODE. 24600014 C 24800014 1037 TMOD (NPUT) = MDD (IDCTPT) 25000014 C 25200014 C IF THE ENTRY IS NOT FOR AN I/O LIST 25400014 C OR THE ELEMENT IS A CONSTANT, BRANCH.25600014 C 25800014 IF(IOSWG .EQ. 0 .OR. TYP (IDCTPT) .EQ. 5) GO TO 10373 26000014 C 26200014 C IF THE VARIABLE IS NOT A READ LIST 26400014 C ITEM, BRANCH. 26600014 C 26800014 IF(ADJCD (NPUT) .NE. 247 .OR. NCARD (4) .EQ. 51) GO TO 10372 27000014 C 27200014 C SET STORE BIT ON. 27400014 C 27600014 NAM2 (IDCTPT) = BITON (NAM2 (IDCTPT),0) 27800014 C 28000014 GO TO 10373 28200014 C 28400014 C SET FETCH BIT ON. 28600014 C 28800014 10372 NAM2 (IDCTPT) = BITON (NAM2 (IDCTPT),1) 29000014 C 29200014 C SET TYPE. 29400014 C 29600014 10373 TTYP (NPUT) = TYP (IDCTPT) 29800014 C 29820014 C IF THE VARIABLE IS A DUMMY EXTERNAL 29840014 C FUNCTION, RESET THE TYPE TO 4. 29860014 C (REMAINS 12 IN DICTIONARY) 29880014 C 29900014 IF(TTYP (NPUT) .EQ. 12) TTYP (NPUT) = 4 29920014 C IF THE VARIABLE OR CONSTANT TO BE 30000014 C ENTERED IS NEGATIVE, RESET THE TYPE. 30200014 C 30400014 IF(NXSMNG .NE. 0) TTYP (NPUT) = TTYP (NPUT) + 8 30600014 C 30800014 C SET LOCATION OF DICTIONARY ENTRY. 31000014 C 31200014 TPTR (NPUT) = IDCTPT 31400014 C 31600014 GO TO 1040 31800014 C 32000014 C MTPSET = -1, I.E. TEXT IS FOR A 32200014 C LABEL ENTRY. 32400014 C SET MODE. 32600014 C 32800014 1038 TMOD (NPUT) = 11 33000014 C 33200014 C SET LOCATION OF LABEL ENTRY. 33400014 C 33600014 TPTR (NPUT) = ILABPT 33800014 C 34000014 C RESET INDICATOR. (IF MTPSET = 1, ALL 34200014 C FIELDS ARE AS THEY SHOULD BE) 34400014 C 34600014 1039 MTPSET = 0 34800014 C 35000014 C SET LOCATION OF NEXT TEXT ENTRY. 35200014 C 35400014 1040 NPUT = NPUT + 12 35600014 C IF THE TEXT LIMIT HAS BEEN EXCEEDED, 35800014 C OBTAIN NEW BLOCK. 36000014 C GETCOR 36200014 IF(NPUT + 12 .GT. NPTR (2,9)) CALL IEKAGC (0) 36400014 C 36600014 GO TO 1095 36800014 C 37000014 C START OF A SPECIAL TEXT STATEMENT. 37200014 C SET INDICATOR. 37400014 C 37600014 1073 LPUTS (NTAB) = 0 37800014 C 38000014 C OBTAIN LOCATION USED FOR ENTRY. 38200014 C 38400014 1075 N = SLIMS (1,1) 38600014 C 38800014 C IF THE ENTRY IS NOT FOR A STATEMENT 39000014 C FUNCTION OR A STATEMENT FUNCTION 39200014 C ARGUMENT USAGE, BRANCH. 39400014 C 39600014 IF(NTAB .NE. 4 .OR. NASF .EQ. 0) GO TO 1080 39800014 C 40000014 C STATEMENT FUNCTION ARGUMENT USAGE. 40200014 C 40400014 C ZERO MODE AND TYPE. 40600014 C 40800014 TMOD (N) = 0 41000014 C 41200014 TTYP (N) = 0 41400014 C 41600014 C IF THE ARGUMENT IS NEGATIVE, RESET 41800014 C THE TYPE. 42000014 C 42200014 IF(NXSMNG .EQ. 1) TTYP (N) = 8 42400014 C 42600014 C SET ARGUMENT SEQUENCE NUMBER. 42800014 C 43000014 TPTR(N) = MOD24(IASFTB(1,NASF)) 43200017 C 43400014 NASF = 0 43600014 GO TO 1085 43800014 C 44000014 C BRANCH ACCORDING TO TYPE OF ENTRY. 44200014 C 44400014 1080 IF(MTPSET) 1082,1081,1083 44600014 C 44800014 C DICTIONARY ENTRY. 45000014 C SET MODE, TYPE, AND POINTER. 45200014 C 45400014 1081 TMOD (N) = MDD (IDCTPT) 45600014 C 45800014 TTYP (N) = TYP (IDCTPT) 46000014 C 46020020 IF( NTAB.EQ.4 .AND. TYP(IDCTPT).EQ.12 ) TTYP(N)=4 46040020 C 46060020 C IN TXT TYP=4 FOR FUNCTION 46080020 C TYP=12 FOR NEG FUNCTION 46100020 C 46120020 C IN DICT TYP=4 FOR FUNCTION 46140020 C TYP=12 FOR DUMMY/EXTERNAL FUNCT 46160020 C 46180020 C IF THE VARIABLE OR CONSTANT TO BE 46200014 C ENTERED IS NEGATIVE, RESET THE TYPE. 46400014 C 46600014 IF(NXSMNG .NE. 0) TTYP (N) = TTYP (N) + 8 46800014 C 47000014 TPTR (N) = IDCTPT 47200014 C 47400014 GO TO 1085 47600014 C 47800014 C LABEL ENTRY. 48000014 C SET MODE AND POINTER. 48200014 C 48400014 1082 TMOD (N) = 11 48600014 C 48800014 TPTR (N) = ILABPT 49000014 C 49200014 1083 MTPSET = 0 49400014 C 49600014 C OBTAIN LOCATION USED FOR THE LAST 49800014 C ENTRY. 50000014 C 50200014 1085 L = LPUTS (NTAB) 50400014 C 50600014 C IF L = 0, I.E. THIS IS THE START OF 50800014 C A SPECIAL TEXT STATEMENT, SAVE THE 51000014 C STARTING LOCATION. 51200014 C 51400014 IF(L .EQ. 0) LFPUTS (1,NTAB) = N 51600014 C 51800014 IF(L .EQ. 0) GO TO 1090 52000014 C 52200014 C NOT FIRST ENTRY. 52400014 C FOLLOWING CHAINS THE NEW ENTRY TO THE52600014 C PREVIOUS ENTRY. 52800014 C 53000014 CODESV = ADJCD (L) 53200014 C 53400014 TXTCHN (L) = N 53600014 C 53800014 ADJCD (L) = CODESV 54000014 C SET LOCATION OF NEXT AVAILABLE ENTRY.54200014 C 54400014 1090 SLIMS (1,1) = N + 12 54600014 C 54800014 C IF THE TEXT LIMIT HAS BEEN EXCEEDED, 55000014 C OBTAIN NEW BLOCK. 55200014 C GETCOR 55400014 IF(SLIMS (1,1) + 12 .GT. SLIMS (2,1)) CALL IEKAGC (1) 55600014 C 55800014 C SAVE LOCATION OF LAST ENTRY. 56000014 C 56200014 LPUTS (NTAB) = N 56400014 IF(NTAB .EQ. 4) NPUT = SLIMS (1,1) 56600014 C 56800014 C RESET NTAB INDICATING THAT SPECIAL 57000014 C TEXT PROCESSING HAS BEGUN. 57200014 C 57400014 NTAB = NTAB + 10 57600014 C 57800014 C IF CALLED TO CLOSE TEXT, BRANCH. 58000014 C 58200014 1095 IF(NCLSTX .EQ. 1) GO TO 310 58400014 C 58600014 C THE NEW DELIMITER IS AN END MARK, 58800014 C BRANCH. 59000014 C 59200014 IF(NDELM .EQ. NGPMK) GO TO 1115 59400014 C 59600014 C SET PREVIOUS DELIMITER. 59800014 C 60000014 NPRVDL = NDELM 60200014 C 60400014 C FOLLOWING OBTAINS THE INTERNAL CODE 60600014 C FOR THE NEW DELIMITER. 60800014 C 61000014 DO 1105 I = 1,12 61200014 C 61400014 IF(NDELM .EQ. NDLMTB (1,I)) GO TO 1110 61600014 C 61800014 1105 CONTINUE 62000014 C 62200014 MSGNO = 13 62400014 C 62600014 C CALL ERROR 62800014 NERSW = 6 63000014 C 63200014 CALL IEKCDP 63400014 C 63600014 C FOLLOWING SETS THE INTERNAL CODE FOR 63800014 C THE NEW DELIMITER INTO THE NEXT TEXT 64000014 C ENTRY. 64200014 C 64400014 C OBTAIN NEXT NORMAL TEXT. 64600014 C 64800014 1110 N = NPUT 65000014 C 65200014 C RESET IF SPECIAL TEXT. 65400014 C 65600014 IF(NTAB .NE. 0) N = SLIMS (1,1) 65800014 C 66000014 C SET CODE. 66200014 C 66400014 ADJCD (N) = NDLMTB (2,I) 66600014 C 66800014 C RESET TYPE OF TEXT INDICATOR. 67000014 C 67200014 1115 NPTR (1,8) = NTAB 67400014 C 67600014 C RESET INDICATORS. 67800014 C 68000014 1120 NXSMNG = 0 68200014 C 68400014 NCLSTX = 0 68600014 C 68800014 9999 CONTINUE 69000014 RETURN 69200014 C 69400014 C CALLED TO CLOSE TEXT. 69600014 C 69800014 C IF CALLED FOR NORMAL TEXT, BRANCH. 70000014 C 70200014 300 IF(NTAB .EQ. 0) GO TO 305 70400014 C 70600014 C END SPECIAL TEXT STATEMENT. 70800014 C 71000014 C RESET TYPE OF TEXT INDICATOR. 71200014 C 71400014 NTAB = NTAB - 10 71600014 C 71800014 C IF NOT STATEMENT FUNCTION TEXT, 72000014 C BRANCH. 72200014 C 72400014 IF(NTAB .NE. 4) GO TO 1065 72600014 C 72800014 C STATEMENT FUNCTION. 73000014 C 73200014 C SET THE LOCATION OF THE S.F. TEXT 73400014 C INTO THE DICTIONARY ENTRY FOR THE 73600014 C S.F. NAME. 73800014 C 74000014 PDI (KSV1) = LFPUTS (1,4) 74200014 C 74400014 GO TO 307 74600014 C 74800014 C DATA, FORMAT, OR NAMELIST. 75000014 C 75200014 C IF THIS IS THE FIRST SPECIAL TEXT 75400014 C STATEMENT FOR THE GIVEN TYPE, BRANCH.75600014 C 75800014 1065 IF(LFPUTS (2,NTAB) .EQ. 0) GO TO 1070 76000014 C 76200014 C NOT FIRST ENTRY. 76400014 C FOLLOWING CHAINS THE NEW TEXT BLOCK 76600014 C TO THE PREVIOUS. 76800014 C 77000014 C OBTAIN LOCATION OF LAST ENTRY. 77200014 C 77400014 L = LFPUTS (2,NTAB) 77600014 C 77800014 C IF NOT DATA TEXT, OBTAIN SECOND TEXT 78000014 C ITEM OF THE BLOCK. (BOTH FORMAT AND 78200014 C NAMELIST HAVE THE POINTER TO THE NEXT78400014 C BLOCK IN THE SECOND ENTRY). 78600014 C 78800014 IF(NTAB .NE. 1) L = TXTCHN (L) 79000014 C 79200014 C CHAIN TO PREVIOUS ENTRY. 79400014 C 79600014 TPTR (L) = LFPUTS (1,NTAB) 79800014 C 80000014 C RESET LAST ENTRY. 80200014 C 80400014 1070 LFPUTS (2,NTAB) = LFPUTS (1,NTAB) 80600014 C 80800014 C ZERO TYPE OF TEXT INDICATOR. 81000014 C 81200014 307 NPTR (1,8) = 0 81400014 ADJCD(SLIMS(1,1)) = 0 81600014 C 81800014 GO TO 1120 82000014 C 82200014 C CLOSE NORMAL TEXT. 82400014 C 82600014 C SET END MARK AND ISN. 82800014 C 83000014 305 ADJCD (NPUT) = 26 83200014 C 83400014 TPTR (NPUT) = ISN 83600014 C 83800014 C SET SWITCH INDICATING THAT ALL FIELDS84000014 C ARE SET. 84200014 C 84400014 MTPSET = 1 84600014 C 84800014 C IF THIS IS THE FIRST ENTRY, BRANCH TO85000014 C AVOID CHAINING. 85200014 C 85400014 IF(LPUT .EQ. 0) GO TO 1035 85600014 C 85800014 C BRANCH TO CHAIN. 86000014 C 86200014 GO TO 1015 86400014 C 86600014 C SAVE LOCATION OF LAST END MARK. 86800014 C 87000014 310 LASTEM = LPUT 87200014 C 87400014 C IF IF-STATEMENTS ARE NOT BEING 87600014 C PROCESSED, RESET INDICATOR. 87800014 C 88000014 IF(NCARD(4).NE.31.AND.(NPTR(1,2).NE.31.OR.NCARD(4).NE.32)) NIF = 088200014 C 88400014 GO TO 1120 88600014 C 88800014 END 89000014 ./ ADD SSI=02011152,NAME=IEKCSP,SOURCE=0 C SUBROUTINE XSPECS 00100014 SUBROUTINE IEKCSP 00200014 C 292000 3653 00250015 C1298304050-304850,336000,338100-338900 17890 00270017 C2200757000-758000,861000-862000 18648 00280017 C2200162000 000C 00290017 C2282593000,598500 19060 00295017 C2841559200-559600 CRB20433 00296018 C0321304770-304830,338200-338400 21952 00297018 C0381304500,762040-762960,772000 21987,000D 00298018 C0481211000,215500-216500,218000 22032 00298618 C0481298000-304850,334000-338900,762040-762960,772000 22032 00299218 C 083500,131500-131700,453500-453700,749600-749800 20.1 34253 00299620 C X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X 00300014 C1140120000,124000,165700-167100,286000,289000,365000-365500, 000F 00310020 C 372300-372600,373500,453800,461000-462000,465000,524000, 000F 00320020 C 532000,537000,582000-583000,627000-630000,631100-632200, 000F 00330020 C 638300-638600,640000,645500,660000,669000,749800-750400, 000F 00340020 C 810000-812000,861000-860600,861600,863700-865100, 000F 00350020 C 892000,894000,895040-895800 000F 00360020 C 00400014 C DICTIONARY LAYOUT 00500014 C 00600014 INTEGER CHN,ADC,PDI 00700014 LOGICAL * 1 BYA,BYB,BYC,STRFCH 00800014 INTEGER*2 DISP,MDD,TYP 00900020 STRUCTURE //CHN,BYA,BYB,DISP,ADC,MDD,TYP,BYC 01000014 STRUCTURE //CHN,BYA,BYB,DISP,ADC,MDD,TYP,PDI,NAM1,NAM2,NAM3,NAM4 01100020 STRUCTURE //CHN,BYA,BYB,DISP,ADC,MDD,TYP,PDI,NAM1,STRFCH 01200014 C 01300014 C EQUIVALENCE GROUP ENTRY 01400014 C 01500014 LOGICAL*1 INDBYG 01600014 INTEGER GRPCHN,PTRVAR,PTRBSG,EISN 01700014 STRUCTURE //INDBYG//GRPCHN,PTRVAR,PTRBSG,EISN 01800014 C 01900014 C EQUIVALENCE VARIABLE ENTRY 02000014 C 02100014 LOGICAL*1 INDBYT,NSUBS 02200014 INTEGER PTREQV,CHNVAR,OFFSET 02300014 INTEGER * 4 SUBSCR 02400014 STRUCTURE//INDBYT//PTREQV,NSUBS//PTREQV,CHNVAR,OFFSET,SUBSCR 02500014 C 02600014 C NORMAL TEXT LAYOUT 02700014 C 02800014 INTEGER CH,SM,P1,P2,P3,DP,DPTR,BLKEND 02900014 LOGICAL*1 FC,R1,R2,R3,L11,L12,L13 03000014 INTEGER*2 H1,H2,H3 03100014 STRUCTURE // CH,SM,P1,P2,P3,DP 03200014 STRUCTURE // CH,H1,FC,L11,R1,L12,H2,R2,L13,H3,R3 03300014 C 03400014 C 03500014 C TEXT LABEL LAYOUT 03600014 C 03700014 LOGICAL*1 ABFN 03800014 STRUCTURE // CH,H1,FC,ABFN,DPTR,BLKEND,MVF,MV1,MV2,MV3, 03900014 * MVS,MV4,MV5,MV6,MVX 04000014 C 04100014 C 04200014 C 04300014 C LABEL LAYOUT 04400014 C 04500014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 04600014 LOGICAL*1 COMP,DN 04700014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 04800014 C 04900014 C 05000014 C 05100014 C COMMON BLOCK LAYOUT 05200014 INTEGER PTRVAR,CSIZE,NAMA,NAMB 05300014 INTEGER *2 NCHAR,JISN 05400014 STRUCTURE//CHN,PTRVAR,CSIZE,NAMA,NAMB,NCHAR,JISN 05500014 C 05600014 C 05700014 C DIMENSION ENTRY LAYOUT 05800014 C 05900014 INTEGER ASIZE,DIM1 06000014 INTEGER*2 ELGTH,NDIM 06100014 STRUCTURE // ASIZE,NDIM,ELGTH,DIM1 06200014 C 06300014 COMMON/IEKAAA/ NPTR(2,35) 06400014 COMMON/IEKAER/ NERTB(2,50) 06500014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 06600014 INTEGER SLIMS 06700014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 06800014 *NBLK,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 06900014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 07000014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 07100014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 07200014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 07300014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 07400014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 07500014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 07600014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 07700014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 07800014 C 07900014 DIMENSION NDIMWK(13) 08000014 LOGICAL*1 NSIZE 08100014 DIMENSION NSIZE(8) 08200014 DATA NSIZE/1,4,2,4,8,4,16,8/ 08300014 DATA MASK3/Z0000FFFF/ 08350020 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 08400014 C C 08500014 C THIS ROUTINE PROCESSES COMMON DIMENSION AND EQUIVALENCE 08600014 C C 08700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 08800014 C 08900014 C IF THE STATEMENT IS THE 09000014 C STATEMENT PORTION OF A LOGICAL- 09100014 C IF, BRANCH TO SET THE ERROR. 09200014 C NPTR(1,2) CONTAINS THE PREVIOUS 09300014 C CLASS CODE--LOG.-IF 6 31. 09400014 IF(NPTR(1,2).EQ. 31) GOTO 1020 09500014 IF(NERSW-2) 1000,2000,3000 09600014 C 09700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC09800014 C C09900014 C FUNCTION - XDIM TRANSLATES ARRAY DEFINITIONS APPEARING IN DIMEN- C10000014 C SION, COMMON, AND TYPE STATEMENTS. IT CHECKS SYNTAX, C10100014 C CALCULATES THE SIZE OF THE ARRAY AND ENSURES THAT THE C10200014 C DICTIONARY ENTRIES ARE MADE. C10300014 C C10400014 C ERRORS - 46, 149, 150, 151, 200 C10500014 C C10600014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC10700014 C 10800014 1000 IARG = 0 10900014 C IF CALLED BY XCOMON OR XTYPE, 11000014 C BRANCH. 11100014 IF (NCOMEX.EQ.1) GO TO 1030 11200014 IF (NTYPEX.EQ.1) GO TO 1060 11300014 C FOLLOWING CALL TO GETWD ACCESSES11400014 C THE VARIABLE TO BE DIMENSIONED. 11500014 1005 CALL IEKCGW 11600014 C INSURE IT IS A VARIABLE. 11700014 IF (NACCSV.EQ.2) GO TO 1025 11800014 MSGNO=151 11900014 GO TO 5002 12000020 1020 MSGNO=139 12100014 GOTO 5000 12200014 167 MSGNO = 167 12300014 GO TO 5002 12400020 C FOLLOWING CALL TO COMSYM HAS 12500014 C THE VARIABLE PACKED AND THE 12600014 C DICTIONARY ENTRY FOR THE 12700014 C VARIABLE GENERATED, OR RETRIVED 12800014 C IF IT WAS PREVIOUSLY USED. 12900014 1025 CALL IEKCS3 13000014 IF(TYP (IDCTPT) .GT. 3) GO TO 167 13100014 C IF VARIABLE IS SUBPROGRAM NAME 13120016 C BRANCH TO SET THE ERROR 13140016 NAM3XX=LAND(NAM3(IDCTPT),MASK3) 13150020 IF(NPTR(1,31) .NE. NPTR(2,31) .AND. NPTR(1,10) .EQ. NAM3XX 13160020 ..AND.NPTR(2,10).EQ.NAM4(IDCTPT)) GO TO 167 13180016 C IF THE VARIABLE WAS PREVIOUSLY 13200014 C ENTERED, BRANCH. 13300014 IF(NTRYMD.EQ.0) GOTO 1055 13400014 C SET TYPE TO ARRAY. 13500014 1030 TYP(IDCTPT) = 2 13600014 C IF THE CALL BY NAME BIT IS ON, 13700014 C RESET TYPE TO DUMMY ARRAY 13800014 IF (TBIT(BYB(IDCTPT),1))TYP(IDCTPT) = 3 13900014 C IF THE CALL BY VALUE BIT IS OFF,14000014 C BRANCH. 14100014 IF (.NOT.TBIT(BYB(IDCTPT),0)) GO TO 1035 14200014 C SET CALL BY NAME BIT ON, OTHERS 14300014 C OFF. 14400014 BYB(IDCTPT) = 64 14500014 C RESET TYPE TO DUMMY ARRAY. 14600014 1033 TYP(IDCTPT) = 3 14700014 C FOLLOWING DO-LOOP SETS NDIMWK TO14800014 C ZEROS. 14900014 1035 DO1040 I=1,13 15000014 1040 NDIMWK(I)=0 15100014 C INITIALIZE. 15200014 NX=6 15300014 C SAVE LOCATION OF DICT. ENTRY OF 15400014 C THE VARIABLE. 15500014 L = IDCTPT 15600014 C OBTAIN MODE. 15700014 I = MDD(IDCTPT) 15800014 GO TO 1095 15900014 1055 IF (PDI(IDCTPT).EQ.0) GO TO 1060 16000014 C ITEM PREVIOUSLY DIMENSIONED 16100014 MSGNO=202 16200017 NERSW = 6 16300014 CALL IEKCDP 16400014 C SKIP DIMENSION INFORMATION 16500014 1056 CALL IEKCGW 16570020 1057 IF( NDELM.EQ.NGPMK ) GO TO 9999 16640020 IF( NDELM.NE.NRTPR ) GO TO 1056 16710020 GO TO 1166 16800014 C IF THE VARIABLE WAS USED AS AN 16900014 C ARGUMENT IN A SUBROUTINE 17000014 C OR FUNCTION STATEMENT, SET 17100014 C THE INDICATOR. 17200014 1060 IF (TBIT(BYB(IDCTPT),0).OR.TBIT(BYB(IDCTPT),1)) IARG=1 17300014 IF (NTYPEX.EQ.1) GO TO 1030 17400014 C SET MODE TO DUMMY ARRAY IF IT IS 17500014 C DUMMY SCALAR. OTHERWISE SET IT 17600014 C TO ARRAY. 17700014 IF (TYP(IDCTPT).EQ.1) GO TO 1070 17800014 TYP(IDCTPT) = 2 17900014 GOTO 1035 18000014 1070 BYB(IDCTPT) = BITON(BYB(IDCTPT),1) 18100014 BYB(IDCTPT) = BITOFF(BYB(IDCTPT),0) 18200014 GO TO 1033 18300014 C SET LENGTH ACCORDING TO MODE 18400014 1095 I = NSIZE(I-1) 18500014 1100 NDIMWK(5)=I 18600014 C IF THE VARIABLE IS NOT FOLLOWED 18700014 C BY A LEFT PAREN, SET THE ERROR. 18800014 IF(NDELM.EQ.NLFPR) GOTO 1110 18900014 1105 MSGNO=150 19000014 GO TO 5001 19100014 C SAVE POINTERS AND DELIMITERS. 19200014 C SCAN POINTER. 19300014 1110 NSVSCN = NSCNPT 19400014 C BEGIN POINTER. 19500014 NSVBPT=NBEGPT 19600014 C NEW DELIMITER. 19700014 NSVND=NDELM 19800014 C PREVIOUS DELIMITER. 19900014 NSVPD = NPRVDL 20000014 C FOLLOWING CALL TO GETWD ACCESSES20100014 C THE FIRST -NEXT- SUBSCRIPT. 20200014 1115 CALL IEKCGW 20300014 C IF THE ELEMENT ACCESSED IS A 20400014 C DELIMITER, BRANCH TO SET THE 20500014 C ERROR. 20600014 IF(LENGTH.EQ.0) GOTO 1105 20700014 C IF THE ELEMENT IS A VARIABLE, 20800014 C INDICATING THE USE OF ADJUSTABLE20900014 C DIMENSIONS, BRANCH. 21000014 IF ( NACCSV .EQ. 2 ) GO TO 1175 21100018 C FOLLOWING CALL TO INTCON HAS THE21200014 C SUBSCRIPT CONVERTED AND ISURES 21300014 C THAT IT IS AN INTEGER. 21400014 CALL IEKCLC 21500014 IF ( NNT .EQ. 1 ) GO TO 1118 21550018 MSGNO = 148 21600018 GO TO 5001 21650018 C INCREMENT SUBSCRIPT COUNT. 21700014 1118 NDIMWK(1) = NDIMWK(1) + 1 21800018 C IF THE NUMBER OF SUBSCRIPTS 21900014 C EXCEEDS 7, SET THE ERROR. 22000014 IF(NDIMWK(1).LE.7) GOTO 1125 22100014 1120 MSGNO=74 22200014 GO TO 5001 22300014 C IF THIS IS NOT THE FIRST 22400014 C SUBSCRIPT, BRANCH. 22500014 1125 IF (NDIMWK (1).GT.1) GOTO 1135 22600014 C FIRST SUBSCRIPT. 22700014 C SET ARRAY SIZE TO THE ELEMENT 22800014 C LENGTH * THE SUBSCRIPT. 22900014 NDIMWK(3)=NDIMWK(5)*NACCM 23000014 C SAVE ARRAY SIZE. 23100014 M=NDIMWK(3) 23200014 C IF THE NEW DELIMITER IS A RIGHT 23300014 C PAREN, INDICATING THE END OF THE23400014 C SUBSCRIPTS, BRANCH. 23500014 1130 IF(NDELM.EQ.NRTPR) GOTO 1140 23600014 C IF THE NEW DELIMITER IS NOT A 23700014 C COMMA, BRANCH TO SET THE ERROR. 23800014 IF(NDELM.NE.NCOMA) GOTO 1105 23900014 C BRANCH BACK TO ACCESS NEXT 24000014 C SUBSCRIPT. 24100014 GOTO 1115 24200014 C NOT FIRST SUBSCRIPT. 24300014 C SET ARRAY SIZE. 24400014 1135 NAME(4)=M 24500014 C FOLLOWING CALL TO SYMTLU HAS THE24600014 C DICTIONARY ENTRY FOR THE 24700014 C CONSTANT GENERATED. 24800014 CALL IEKCS2 24900014 C INSURE REFERENCED BIT IS ON. 25000014 BYA(IDCTPT) = BITON(BYA(IDCTPT),1) 25100014 C SET ADDRESS OF ENTRY INTO 25200014 C DIMENSION ENTRY. 25300014 NDIMWK(NX) = IDCTPT 25400014 NX=NX+1 25500014 C CALCULATE NEW ARRAY SIZE. 25600014 M=M*NACCM 25700014 GOTO 1130 25800014 C RIGHT PAREN FOUND. 25900014 C SET TOTAL ARRAY SIZE. 26000014 1140 NDIMWK(3)=M 26100014 C OBTAIN NEXT AVAILABLE DICTIONARY26200014 C LOCATION. 26300014 1145 N = NDIMWK(1) 26350014 IF ((NPTR(2,29)+8).GT.NPTR(2,30)) CALL IEKAGC(2) 26400014 J1 = NPTR(2,29) 26450014 C FOLLOWING DO-LOOP MOVES THE 26500014 C DIMENSION ENTRY INTO THE 26600014 C DICTIONARY. 26700014 C PUT DIMENSION ENTRY IN DICTIONARY 26800014 NDIMP = NPTR(2,29) 26900014 NPTR(2,29) = NPTR(2,29)+ 8 27000014 NDIM(NDIMP) = NDIMWK(1) 27100014 IF(NDIMWK (3) .EQ. 0) NDIM (NDIMP) = NDIM (NDIMP) - 1 27200014 ASIZE(NDIMP)= NDIMWK(3) 27300014 ELGTH(NDIMP)= NDIMWK(5) 27400014 NDN = 8 27500014 DO 1150 NVP=1,N 27600014 ASIZE(NDIMP+NDN) = NDIMWK(5+NVP) 27700014 IF(NPTR(2,29)+4 .LE. NPTR(2,30)) GO TO 1149 27800014 CALL IEKAGC(2) 27900014 GO TO 1145 28000014 1149 NPTR(2,29) = NPTR(2,29) + 4 28100014 NDN = NDN + 4 28200014 1150 CONTINUE 28300014 1160 PDI (L) = NDIMP 28400014 C TEST IF TIME TO EXIT 28500014 1166 IF( NCOMEX.EQ.1 ) GO TO 3333 28600020 IF (NTYPEX.EQ.1.OR.NDELM.EQ.NGPMK) GO TO 9999 28700014 C GET NEXT WORD 28800014 CALL IEKCGW 28900020 IF(LENGTH.GT.0) GOTO 1105 29000014 C TEST FOR MORE ARRAYS 29100014 IF (NDELM.EQ.NCOMA) GO TO 1000 29200015 IF(NDELM.EQ.NGPMK) GOTO 9999 29300014 GOTO 1105 29400014 C VARIABLE IS USED AS A SUBACRIPT.29500014 C FOLLOWING OPERATION HANDLES THE 29600014 C ADJUSTABLE DIMENSION. 29700014 C RESET POINTERS AND DELIMITERS. 30700014 C SCAN PTR. 30800014 1175 NSCNPT = NSVSCN 30900014 C BEGIN PTR. 31000014 NBEGPT=NSVBPT 31100014 C NEW DELIM. 31200014 NDELM=NSVND 31300014 C PREVIOUS DELIM. 31400014 NPRVDL = NSVPD 31500014 C SET WORK AREA TO ZERO. 31600014 IARG = 0 31700014 DO1180 K=1,13 31800014 1180 NDIMWK(K)=0 31900014 C SET ELEMENT LENGTH. 32000014 NDIMWK(5)=I 32100014 NX=6 32200014 C FOLLOWING CALL TO GETWD ACCESSES32300014 C THE FIRST -NEXT- SUBSCRIPT. 32400014 1185 CALL IEKCGW 32500014 C IF THE ELEMENT ACCESSED IS A 32600014 C DELIMITER, BRANCH TO SET THE 32700014 C ERROR. 32800014 IF(LENGTH.EQ.0) GOTO 1105 32900014 C FOLLOWING CALL TO CSORN HAS THE 33000014 C DICTIONARY ENTRY FOR THE 33100014 C SUBSCRIPT GENERATED. 33200014 CALL IEKCCR 33300014 C SET ADDRESS OF DICTIONARY ENTRY 33900014 C OF SUBSCRIPT. 34000014 1190 NDIMWK(NX) = IDCTPT 34100014 NX=NX+1 34200014 C INCREMENT SUBSCRIPT COUNT. 34300014 NDIMWK(1)=NDIMWK(1)+1 34400014 C IF THE NUMBER OF SUBSCRIPTS 34500014 C EXCEEDS 7, BRANCH TO SET THE 34600014 C ERROR. 34700014 IF(NDIMWK(1).GT.7) GOTO 1120 34800014 C INSURE REFERENCE BIT IS ON. 34900014 BYA(IDCTPT) = BITON(BYA(IDCTPT),1) 35000014 C IF THE NEW DELIMITER IS A COMMA 35100014 C BRANCH BACK TO ACCESS NEXT 35200014 C SUBSCRIPT. 35300014 IF(NDELM .EQ. NCOMA) GO TO 1185 35400014 C IF IT IS NOT A RIGHT PAREN, 35500014 C SET THE ERROR. 35600014 IF(NDELM .NE. NRTPR) GO TO 1105 35700014 NDIMWK (1) = NDIMWK (1) + 1 35800014 GO TO 1145 35900014 C 36000014 C DIMENSION IN ERROR. RESET TYPE TO 36100014 C SCALAR OR DUMMY SCALAR. 36200014 C 36300014 5001 TYP (L) = TYP (L) - 2 36400014 5002 NERSW=7 36450020 CALL IEKCDP 36500020 GO TO 1057 36550020 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC36600014 C C36700014 C FUNCTION - XEQUI TRANSLATES THE EQUIVALENCE STATEMENT. IT CHECKS C36800014 C SYNTAX AND MAKES AN ENTRY IN THE EQUIVALENCE CHAIN OF THE C36900014 C DICTIONARY. IT ENSURES THAT ALL VARIABLES IN THE EQUI- C37000014 C VALENCE GROUP ARE PLACED IN THE DICTIONARY. IF A VARIABLE C37100014 C IS SUBSCRIPTED, ITS DISPLACEMENT IN THE ARRAY IS CALCULATED. C37200014 C THIS ROUTINE CHECKS FOR MULTIPLE SYNTAX ERRORS IN THE SAME C 37230020 C SOURCE STATEMENT. C 37260020 C C37300014 C ERROR MESSAGES - 62,70,72,73,74,167 C 37400020 C C37500014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC37600014 C 37700014 2000 IF (NCDIN(17).NE.NLFPR) GO TO 2185 37800014 NEQPTR = 0 37900014 KKK=1 38000014 IACC=0 38100014 MFST=0 38200014 C FOLLOWING DETERMINES IF 38300014 C FIRST ENEWN DELIMITER IS A LEFT 38400014 C PAREN. IF NOT, BRANCH TO ERROR.38500014 2005 IF (NDELM.NE.NLFPR) GO TO 2220 38600014 C OBTAIN POINTER TO START OF 38700014 C EQUIVALENCE CHAIN. 38800014 J = NPTR(2,26) 38900014 IF ((NPTR(2,29)+16).GT.NPTR(2,30)) CALL IEKAGC(2) 38950014 C FOLLOWING DETERMINES IF ANY 39000014 C PREVIOUS EQUIVALENCE ENTRY HAS 39100014 C BEEN MADE. IF IT HAS NOT, 39200014 C BRANCH TO HANDLE THE INITIAL 39300014 C ENTRY. 39400014 IF(J.EQ.0) GOTO 2040 39500014 C A PREVIOUS ENTRY HAS BEEN MADE. 39600014 C OBTAIN POINTER TO LAST 39700014 C GROUP ENTRY. 39800014 J = NPTR (1,4) 39900014 C CHAIN ADDRESS OF DICTIONARY 40000014 C LOCATION TO BE USED FOR THE NEW 40100014 C ENTRY TO THE LAST ENTRY. 40200014 ICSAVE = INDBYG(J) 40300014 GRPCHN(J) = NPTR(2,29) 40400014 INDBYG(J) = ICSAVE 40500014 C ZERO SWITCH, INDICATING THAT THE40600014 C EQUIVALENCE GROUP ENTRY WAS 40700014 C CHAINED TO A PREVIOUS ENTRY. 40800014 NCOMAR=0 40900014 C SAVE THE ADDRESS OF THE PREVIOUS41000014 C ENTRY TO WHICH THE NEW ENTRY IS 41100014 C CHAINED. 41200014 NSVCHN=J 41300014 GOTO 2045 41400014 C INITIAL ENTRY. 41500014 C SET ADDRESS OF THE LOCATION TO 41600014 C BE USED FOR THE INITIAL ENTRY 41700014 C INTO THE COMMUNICATION AREA. 41800014 2040 NPTR(2,26)=NPTR(2,29) 41900014 C SET A SWITCH INDICATING THAT THE42000014 C PRESENT ENTRY WAS CHAINED FROM 42100014 C THE COMMUNICATION AREA. 42200014 NCOMAR=1 42300014 C SAVE ADDRESS OF LOCATION TO BE 42400014 C USED FOR NEW GROUP ENTRY. 42500014 2045 J=NPTR(2,29) 42600014 JACK=J 42700014 C SAVE LOCATION AS LAST GROUP. 42800014 NPTR (1,4) = J 42900014 EISN(J) = ISN 43000014 C UPDATE POINTER TO NEXT AVAILABLE43100014 C DICTIONARY LOCATION. 43200014 NPTR (2,29) = NPTR (2,29) + 16 43300014 C TEST FOR OVERLFOW. 43400014 C FOLLOWING CALL TO GETWD ACCESSES43500014 C THE FIRST ENEXTN VARIABLE TO BE 43600014 C EQUIVALENCED. 43700014 CALL IEKCGW 43800014 C INSURE THERE ARE NO MISPLACED 43900014 C DELIMITERS. IF THERE ARE, BRANCH44000014 C TO SET ERROR MESSAGE NUMBER. 44100014 IF(LENGTH.EQ.0) GOTO 2220 44200014 C INSURE ELEMENT ACCESSED IS A 44300014 C VARIABLE. IF NOT, BRANCH. 44400014 2060 IF (NACCSV.NE.2) GO TO 2215 44500014 C FOLLOWING CALL TO COMSYM HAS THE44600014 C VARIABLE PACKED, ONE CHARACTER 44700014 C PER BYTE, AND LOCATED IN DICT. 44800014 CALL IEKCS3 44900014 C IF THE VARIABLE IS A 45000014 C FUNCTION NAME, 45100014 C BRANCH TO SET THE ERROR. 45200014 IF(TYP (IDCTPT) .GT. 3) GO TO 1671 45300014 C IF VARIABLE IS SUBPROGRAM NAME 45320016 C BRANCH TO SET THE ERROR 45340016 NAM3XX=LAND(NAM3(IDCTPT),MASK3) 45350020 IF(NPTR(1,31) .NE. NPTR(2,31) .AND. NPTR(1,10) .EQ. NAM3XX 45360020 . .AND. NPTR(2,10).EQ.NAM4(IDCTPT) ) GO TO 1671 45380020 C SET THE BIT IN THE DICTIONARY 45400014 C ENTRY FOR THE VARIABLE 45500014 C INDICATING THAT IT IS 45600014 C EQUIVALENCED. 45700014 BYA(IDCTPT) = BITON(BYA(IDCTPT),4) 45800014 C FOLLOWING TESTS IF VARIABLE IS 45900014 C FOLLOWED BY A LEFT PAREN, 46000014 C INDICATING THAT IT IS 46100020 C SUBSRIPTED.IF IT IS 46200020 C SUBSCRIPTED, BRANCH. 46300014 IF (NDELM.EQ.NLFPR) GO TO 2140 46400014 C IF THE VAR/SUBSCRIPT IS NOT 46500020 C DELIMITED BY A COMMA OR A RIGHT 46600014 C PAREN, BRANCH TO SET THE ERROR. 46700014 2075 IF(NDELM.NE.NCOMA.AND.NDELM.NE.NRTPR) GOTO 2220 46800014 C START LOOK UP IN VAR CHAIN 46900014 IF ((NPTR(2,29)+12).GT.NPTR(2,30)) CALL IEKAGC(2) 46950014 IF (MOD24(PTRVAR(JACK)).EQ.0) GO TO 2085 47000014 C OBTAIN POINTER TO LAST 47100014 C VARIABLE ENTRY. 47200014 NEQPTR = LEQPTR 47300014 2105 ICSAVE = NSUBS (NEQPTR) 47400014 CHNVAR (NEQPTR) = NPTR (2,29) 47500014 NSUBS (NEQPTR) = ICSAVE 47600014 GOTO 2090 47700014 C THIS UPDATES CHAIN OF VAR 47800014 2085 PTRVAR(JACK)= NPTR(2,29) 47900014 2090 NEQPTR=NPTR(2,29) 48000014 C SAVE LOCATION AS LAST VARIABLE. 48100014 LEQPTR = NEQPTR 48200014 C UPDATE PTRS + SPACE USED 48300014 NPTR(2,29) = NPTR(2,29) + 12 48400014 IF(INDBYT(NEQPTR).EQ.1)NPTR(2,29)=NPTR(2,29)+(NSUBS(NEQPTR)*4) 48500014 IF (KKK-1) 2095,2095,2175 48600014 C 310 IS NON ZERO OFFSET 48700014 C INSERT 0 OFFSET 48800014 2095 OFFSET(NEQPTR)= 0 48900014 2100 ICSAVE = INDBYT(NEQPTR) 49000014 PTREQV(NEQPTR) = IDCTPT 49100014 INDBYT(NEQPTR) = ICSAVE 49200014 IF (KKK-1) 2105,2110,2180 49300014 C GET NEXT 49400014 2110 CALL IEKCGW 49500014 IF(LENGTH.NE.0) GOTO 2060 49600014 C IF END OF GP INSERT CT + ZERO 49700014 2115 IF (NDELM.EQ.NGPMK) GOTO 2125 49800014 IF(NDELM.NE.NCOMA.AND.NDELM.NE.NRTPR) GOTO 2220 49900014 2120 CALL IEKCGW 50000014 IF(NDELM.EQ.NRTPR.AND.LENGTH.EQ.0) GOTO 2120 50100014 C NOT E OF CD, GET + START NEW GP. 50200014 IF(LENGTH.NE.0) GOTO 2220 50300014 IF(NDELM.NE.NGPMK) GOTO 2135 50400014 2125 IF (NPRVDL.NE.NRTPR) GO TO 2220 50500014 GOTO 9999 50600014 2135 IF(NDELM.NE.NCOMA) GOTO 2005 50700014 CALL IEKCGW 50800014 IF (LENGTH.EQ.0) GO TO 2005 50900014 GO TO 2220 51000014 C VARIABLE IS FOLLOWED BY A 51100014 C SUBSCRIPT. 51200014 C IF IT WAS NOT PREVIOUSLY 51300014 C DIMENSIONED, BRANCH. 51400014 2140 IF(MOD24 (PDI (IDCTPT)) .EQ. 0) GO TO 2218 51500014 C FOLLOWING CALL TO GETWD ACCESSES51600014 C THE FIRST - NEXT - SUBSCRIPT. 51700014 2145 CALL IEKCGW 51800014 C IF IT IS NOT A CONSTANT, BRANCH 51900014 C TO SET THE ERROR. 52000014 2147 IF (NACCSV.NE.1) GO TO 2200 52100014 C CONVERT SUBSCRIPT 52200014 CALL IEKCLC 52300014 IF( NNT.NE.1 ) GO TO 2200 52400020 K = PDI(IDCTPT) 52500014 IF(MFST.NE.0) GOTO 2155 52600014 C FIRST * LENGTH 52700014 IACC=NAME(4)-1 52800014 C INITIALIZE VARIABLE TO SERVE 52900014 C AS A COUNTER FOR THE NUMBER 53000014 C OF SUBSCRIPTS --- VARIABLE IS 53100014 C INITIALIZED TO 3 IN ORDER THAT 53200020 C IT MAY ALSO BE USED AS AN INDEX.53300014 MFST = 3 53400014 GOTO 2160 53500014 2155 IF(MFST - 1 .GT. NDIM (K)) GO TO 62 53600014 MFST1 = ASIZE(K+4*MFST-4) 53700014 C 2ND *(D1*L) + FIRST ETC 53800014 KN = NAM4(MFST1) 53900014 KN1 = ELGTH(K) 54000014 IACC=IACC+((NAME(4)-1)*KN)/KN1 54100014 C BUMP SUBSCRIPT CT 54200014 MFST=MFST+1 54300014 IF (MFST.GT.9) GO TO 2190 54400014 C IF THE NEW DELIMITER IS A COMMA 54500014 C INDICATING ANOTHER SUBSCRIPT, 54600014 C BRANCH TO PROCESS IT. 54700014 2160 IF(NDELM.EQ.NCOMA) GOTO 2145 54800014 C CK FOR END OF SUBSC. 54900014 IF (NDELM.NE.NRTPR) GO TO 2220 55000014 C END OF SUBSC.OPER 55100014 2165 IF (MFST.EQ.3.AND.NAME(4).EQ.1) IACC=0 55200014 MFST1 = 0 55300014 MFST=0 55400014 C SET COMP GO TO AND PUT AWAY 55500014 KKK=2 55600014 C VAR ENTRY WITH OFFSET 55700014 GOTO 2075 55800014 2175 OFFSET(NEQPTR) = IACC 55900014 IF (MOD24(PDI(IDCTPT)).EQ.0 ) GO TO 2176 55920018 IF (NSUBS(NEQPTR).EQ.0) NSUBS(NEQPTR) = 1 55940018 2176 CONTINUE 55960018 C THIS IS OFFSET PUTAWAY 56000014 IACC=0 56100014 GOTO 2100 56200014 C RESET COMP GO TO 56300014 2180 KKK=1 56400014 CALL IEKCGW 56500014 IF(LENGTH.NE.0) GOTO 2220 56600014 C END OF CD OR END OF GP 56700014 IF(NDELM.EQ.NCOMA) GOTO 2110 56800014 GOTO 2115 56900014 62 MSGNO = 62 57000014 GO TO 2225 57100014 2185 MSGNO = 70 57200014 GO TO 5003 57300020 2190 MSGNO=74 57400014 GO TO 2225 57500014 2200 MSGNO = 73 57600014 GO TO 2225 57700014 2215 MSGNO = 72 57800014 GOTO 2225 57900014 1671 MSGNO = 167 58000014 GO TO 2225 58100014 C VARIABLE IS FOLLOWED BY A 58400014 C SUBSCRIPT BUT WAS NOT 58500014 C PREVIOUSLY DIMENSIONED. 58600014 C ACCESS SUBSCRIPT. 58700014 2218 CALL IEKCGW 58800014 C IF THE NEW DELIMITER IS A 58900014 C RIGHT PAREN, INDICATING ONLY 59000014 C ONE SUBSCRIPT, BRANCH TO 59100014 C CONTINUE PROCESSING. 59200014 IF(NDELM.EQ.NRTPR) GO TO 2188 59300017 C IF THE NEW DELIMITER IS NOT A 59400014 C COMMA, SET THE ERROR. 59500014 IF(NDELM .NE. NCOMA) GO TO 2220 59600014 C GENERATE SPECIAL EQUIVALENCE FORMATS 59700014 C SET INDICATOR BYTES IN GROUP AND VARIABLE ENTRIES 59800014 2188 IF((NPTR(2,29)+40).GT.NPTR(2,30)) CALL IEKAGC(2) 59850017 INDBYG(J) = 1 59900014 NEQPTR = NPTR(2,29) 60000014 INDBYT(NEQPTR) = 1 60100014 N5 = 0 60200014 C INSURE SUBSCRIPT A CONSTANT 60300014 2219 NSUBS(NEQPTR) = NSUBS(NEQPTR) + 1 60400014 IF (NACCSV.NE.1) GOTO 2200 60500014 CALL IEKCLC 60600014 C RESERVE SUBSCRIPT INTO SUBSCR FIELD 60700014 SUBSCR(NEQPTR+N5)= NAME(4) 60800014 IF (NDELM.EQ.NRTPR) GOTO 2165 60900014 IF (NDELM.NE.NCOMA) GOTO 2220 61000014 N5 = N5+4 61100014 CALL IEKCGW 61200014 IF (LENGTH.NE.0) GOTO 2219 61300014 2220 MSGNO = 70 61400014 C AN ERROR HAS BEEN FOUND. 61500014 C FOLLOWING OPERATION UNCHAINS THE61600014 C GROUP ENTRY. 61700014 C IF THE ENTRY WAS CHAINED INTO 61800014 C THE COMMUNICATION AREA, BRANCH. 61900014 2225 IF(NCOMAR.EQ.1) GOTO 2235 62000014 C ZERO CHAIN OF PREVIOUS ENTRY 62100014 C TO WHICH THE INVALID EQUIVALENCE62200014 C TNTRY WAS CHAINED. 62300014 ICSAVE = INDBYG(NSVCHN) 62400014 GRPCHN(NSVCHN) = 0 62500014 INDBYG(NSVCHN) = ICSAVE 62600014 NPTR(1,4) = NSVCHN 62700020 GO TO 5003 62800020 2235 NPTR(2,26) = 0 63100014 C ENTER MESSAGE AND CONTINUE 63110020 C PROCESSING NEXT EQUIV GROUP. 63120020 5003 NERSW = 7 63130020 CALL IEKCDP 63140020 C FIND START OF NEXT GROUP 63150020 5004 IF( NDELM.EQ.NGPMK ) GO TO 9999 63160020 CALL IEKCGW 63170020 IF( NDELM.NE.NCOMA .OR. LENGTH.NE.0 63180020 1 .OR. NPRVDL.NE.NRTPR ) GO TO 5004 63190020 CALL IEKCGW 63200020 IF( NDELM.NE.NLFPR .OR. LENGTH.NE.0 ) GO TO 5004 63210020 GO TO 2005 63220020 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC63300014 C C63400014 C FUNCTION - XCOMON TRANSLATES THE COMMON STATEMENT. IT CHECKS SYNTAX C63500014 C AND ENSURES DICTIONARY ENTRIES ARE MADE FOR THE COMMON C63600014 C BLOCK NAME AND ALL VARIABLES AND ARRAYS APPEARING IN THE C63700014 C BLOCK. C63800014 C THIS ROUTINE CHECKS FOR MULTIPLE SYNTAX ERRORS IN THE SAME C 63830020 C SOURCE STATEMENT. C 63860020 C C63900014 C ERROR MESSAGES - 69,75,86,87,88,167,112,202 C 64000020 C C64100014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC64200014 C 64300014 C FOLLOWING INITIALIZES 64400014 3000 NCMFST=1 64500014 NCMPTR = 0 64550020 NCOMEX=0 64600014 C FOLLOWING TESTS TO SEE IF THE 64700014 C FIRST ELEMENT FOLLOWING THE 64800014 C KEYWORD IS A SLASH 64900014 IF (NCDIN(12).EQ.NSLAS) GO TO 3005 65000014 C STATEMENT DOES NOT START WITH A 65100014 C SLASH. 65200014 C INSURE THAT AN INVALID 65300014 C DELIMITER DOES NOT BEGIN THE 65400014 C STATEMENT. 65500014 IF (NSCNPT.NE.12) GO TO 3080 65600014 C THE FOLLOWING CALL TO GETWD 65700014 C ACCESSES THE FIRST ELEMENT 65800014 C FOLLOWING THE KEYWORD 65900014 3001 CALL IEKCGW 66000020 C TEST IF THIS ELEMENT IS A 66100014 C VARIABLE. IF IT IS NOT, BRANCH 66200014 C TO RECORD THE ERROR. OTHERWISE, 66300014 C FALL THRU TO PROCESS THE 66400014 C UNLABELED COMMON. 66500014 IF(NACCSV.NE.2) GOTO 3160 66600014 C FOLLOWING SETS UP FOR CREATING 66700014 C AN UNLABELED COMMON. 66800014 C SET THE COMMON NAME TO BE 66900020 C ENTERED TO ZEROS. THIS 67000014 C REPRESENTS AN UNLABELED COMMON. 67100014 3020 NCNAM=0 67200014 NCNAM2=0 67300014 NCLGTH=0 67400014 C FOLLOWING IS THE ENTRY-MAKING 67500014 C OPERATION 67600014 C SAVE THE POINTER TO THE COMMON 67700014 C CHAIN 67800014 3025 NCMPTR=NPTR(2,25) 67900014 C TEST TO SEE IF THE POINTER IS 68000014 C ZERO, WHICH INDICATES THAT NO 68100014 C PREVIOUS COMMON ENTRIES HAVE 68200014 C BEEN MADE. IF IT IS ZERO, BRANCH68300014 C TO SET UP FOR THE FIRST ENTRY. 68400014 IF(NCMPTR.EQ.0) GOTO 3035 68500014 C NCMPTR IS NOT ZERO, THEREFORE A 68600014 C PREVIOUS ENTRY HAS BEEN MADE. 68700014 C FOLLOWING COMPARES THE NAME OF 68800014 C THAT ENTRY TO THE PRESENT COMMON68900014 C BLOCK NAME. IF THE NAMES ARE THE69000014 C SAME, BRANCH. 69100014 3030 IF(NAMA(NCMPTR).EQ.NCNAM.AND.NAMB(NCMPTR).EQ.NCNAM2) GOTO 3055 69200014 C NAMES ARE NOT THE SAME. 69300014 C FOLLOWING TESTS THE CHAIN 69400014 C ADDRESS PORTION OF THE PREVIOUS 69500014 C ENTRY FOR ZERO, INDICATING THE 69600014 C END OF THE CHAIN. 69700014 IF (CHN(NCMPTR).EQ.0) GOTO 3040 69800014 C CHAIN ADDRESS DOES NOT EQUAL 69900014 C ZERO, AND THEREFORE CONTAINS 70000014 C THE ADDRESS OF THE NEXT COMMON 70100014 C BLOCK NAME ENTRY 70200014 C SAVE THE POINTER TO THIS NEXT 70300014 C ENTRY 70400014 NCMPTR = CHN(NCMPTR) 70500014 C BRANCH TO CONTINUE THE COMMON 70600014 C BLOCK NAME SEARCH 70700014 GOTO 3030 70800014 C FOLLOWING SETS UP TO MAKE THE 70900014 C INITIAL COMMON BLOCK NAME ENTRY.71000014 C FOLLOWING PUTS THE ADDRESS OF 71100014 C THE NEXT AVAILABLE DICTIONARY 71200014 C ENTRY LOCATION IN THE 71300014 C COMMUNICATION AREA. 71400014 3035 IF ((NPTR(2,29)+24).GT.NPTR(2,30)) CALL IEKAGC(2) 71460014 NPTR(2,25) = NPTR(2,29) 71520014 C SAVE THIS ADDRESS 71600014 NCMPTR=NPTR(2,25) 71700014 C BRANCH TO CONTINUE PROCESSING 71800014 GOTO 3045 71900014 C CHAIN ADDRESS EQUALS ZERO. 72000014 C SET THE CHAIN FOR THE NEW ENTRY 72100014 3040 IF ((NPTR(2,29)+24).GT.NPTR(2,30)) CALL IEKAGC(2) 72160014 CHN(NCMPTR) = NPTR(2,29) 72220014 C SAVE THE NEW ENTRY ADDRESS 72300014 NCMPTR=NPTR(2,29) 72400014 C RESET THE ADDRESS OF THE NEXT 72500014 C AVAILABLE DICTIONARY ENTRY 72600014 3045 NPTR(2,29) = NPTR(2,29) + 24 72700014 C TEST FOR DICTIONARY OVERFLOW. 72800014 IF(NPTR(2,29).GT.NPTR(2,30)) GOTO 3060 72900014 C FOLLOWING ENTERS THE COMMON 73000014 C BLOCK NAME AND ITS LENGTH 73100014 NAMA(NCMPTR) = NCNAM 73200014 NAMB(NCMPTR) = NCNAM2 73300014 NCHAR(NCMPTR) = NCLGTH 73400014 JISN(NCMPTR) = ISN 73500014 C SAVE THE ADDRESS OF THIS ENTRY 73600014 3055 NSVBLK = NCMPTR 73700014 C FOLLOWING TESTS THE FIRST TIME 73800014 C SWITCH. IF IT IS ON, IT 73900014 C INDICATES THAT THE FIRST 74000014 C COMMON VARIABLE HAS ALREADY 74100014 C BEEN ACCESSED BY GETWD. 74200014 IF(NCMFST.EQ.1) GOTO 3095 74300014 C FOLLOWING CALL TO GETWD ACCESSES74400014 C THE FIRST ENEXTN COMMON VARIABLE74500014 3090 CALL IEKCGW 74600014 C INSURE THE ELEMENT IS A VARIABLE74700014 IF(NACCSV.NE.2) GOTO 3160 74800014 3095 CALL IEKCS3 74900014 C IF VARIABLE IS SUBPROGRAM NAME 74920016 C BRANCH TO SET THE ERROR 74940016 NAM3XX=LAND(NAM3(IDCTPT),MASK3) 74960020 IF(NPTR(1,31) .NE. NPTR(2,31) .AND. NPTR(1,10) .EQ. NAM3XX 74980020 ..AND. NPTR(2,31).EQ.NAM4(IDCTPT) ) GO TO 3167 75000020 IF( TYP(IDCTPT).GT.3 ) GO TO 3167 75040020 C FOLLOWING INSURES THAT THE 75100014 C VARIABLE HAS NOT BEEN REFERENCED75200014 C IN A PREVIOUS COMMON STATEMENT. 75300014 C IF IT HAS NOT BEEN, PROCESSING 75400014 C CONTINUES. OTHERWISE THE ERROR 75500014 C IS RECORDED. 75600014 IF (TBIT(BYA(IDCTPT),2))GO TO 3155 75700014 C IF THE VARIABLE IS A DUMMY 75710017 C SCALAR AND IF EITHER ITS 'CALL 75720017 C BY VALUE' OR 'CALL BY NAME' BIT 75730017 C IS ON,BRANCH TO SET ERROR. 75740017 IF(TYP(IDCTPT).EQ.1.AND.(TBIT(BYB(IDCTPT),0).OR. 75750017 *TBIT(BYB(IDCTPT),1))) GO TO 3088 75760017 C FOLLOWING SETS A BIT IN THE 75800014 C VARIABLE'S ENTRY INDICATING 75900014 C THAT IT HAS BEEN REFERENCED 76000014 C IN A COMMON STATEMENT. 76100014 BYA(IDCTPT) = BITON(BYA(IDCTPT),2) 76200014 C FOLLOWING TESTS THE LOCATION OF 76300014 C THE COMMON BLOCK NAME WHICH 76400014 C CONTAINS THE POINTER TO THE 76500014 C VARIABLES IT CONTAINS. IF THE 76600014 C VALUE IS ZERO, IT INDICATES THAT76700014 C NO PREVIOUS VARIABLES HAVE BEEN 76800014 C ENTERED FOR THIS BLOCK, AND A 76900014 C BRANCH IS MADE TO HANDLE THE 77000014 C INITIAL VARIABLE. 77100014 IF ( PTRVAR(NSVBLK) .EQ. 0 ) GO TO 3115 77200018 C PREVIOUS VARIABLES HAVE BEEN 77300014 C ENTERED. 77400014 C CHAIN NEW ENTRY TO LAST. 77500014 ISTFCH = STRFCH (CSIZE (NSVBLK)) 77600014 NAM2 (CSIZE (NSVBLK)) = IDCTPT 77700014 STRFCH (CSIZE (NSVBLK)) = ISTFCH 77800014 GO TO 3120 77900014 C FOLLOWING SETS THE ADDRESS OF 78000014 C THE FIRST COMMON VARIABLE INTO 78100014 C THE ENTRY FOR ITS COMMON BLOCK 78200014 C NAME 78300014 3115 PTRVAR(NSVBLK) = IDCTPT 78400014 C SAVE LOCATION OF LAST VARIABLE 78500014 C IN CHAIN. 78600014 3120 CSIZE (NSVBLK) = IDCTPT 78700014 C FOLLOWING TESTS TO SEE IF THE 78800014 C VARIABLE IS SUBSCRIPTED 78900014 IF(NDELM .NE. NLFPR) GO TO 3125 79000014 C VARIABLE IS SUBSCRIPTED. 79100014 IF (MOD24(PDI(IDCTPT)).NE.0) GO TO 3137 79200014 C SET SWITCH TO INDICATE TO XDIM 79300014 C THAT XCOMON IS THE CALLING 79400014 C ROUTINE 79500014 NCOMEX=1 79600014 GOTO 1000 79700014 C IF ERROR RETURN, BRANCH TO 79800014 C RETURN CONTROL 79900014 C RESET SWITCH 80000014 3333 NCOMEX=0 80100014 C BRANCH TO ACCESS NEXT ELEMENT 80200014 GOTO 3140 80300014 C VARIABLE IS NOT SUBSCRIPTED. 80400014 C TEST DELIMITER FOLLOWING THE 80500014 C VARIABLE. 80600014 C IF DELIMITER IS A COMMA, BRANCH 80700014 C TO ACCESS NEXT VARIABLE. 80800014 3125 IF(NDELM.EQ.NCOMA) GOTO 3090 80900014 C IF DELIMITER IS A SLASH,ACCESS 81000020 C COMMON BLOCK NAME. IF IT IS NOT 81100020 C BRANCH TO CHECK SYNTAX. 81200020 IF (NDELM.NE.NSLAS) GO TO 3130 81300014 C FOLLOWING CALL TO GETWD ACCESSES81400014 C THE ELEMENT FOLLOWING THE SLASH 81500014 3005 CALL IEKCGW 81600014 C TEST IF THIS ELEMENT IS A 81700014 C DELIMITER. IF IT IS, BRANCH 81800014 IF(LENGTH.EQ.0) GOTO 3070 81900014 C TEST IF THIS ELEMENT IS A 82000014 C VARIABLE. IF IT IS NOT, BRANCH 82100014 C TO RECORD THE ERROR 82200014 IF(NACCSV.NE.2) GOTO 3165 82300014 C ELEMENT FOLLOWING THE SLASH IS 82400014 C A VARIABLE. BRANCH TO CONTINUE 82500014 C PROCESSING. 82600014 C FOLLOWING INSURES THAT THE 82700014 C DELIMITER FOLLOWING THE VARIABLE82800014 C IS A SLASH 82900014 IF (NDELM.NE.NSLAS) GO TO 3080 83000014 C FOLLOWING TURNS OFF THE FIRST 83100014 C TIME SWITCH INDICATING THAT THE 83200014 C FIRST COMMON VARIABLE HAS NOT 83300014 C YET BEEN ACCESSED BY GETWD. 83400014 NCMFST = 0 83500014 C BRANCH TO HANDLE THE COMMON 83600014 C BLOCK NAME 83700014 C FOLLOWING CALL TO COMPAT HAS THE83800014 C COMMON BLOCK NAME PACKED INTO 83900014 C NAME - 1 CHARACTER PER BYTE. 84000014 3085 CALL IEKCS1 84100014 C SAVE THE PACKED NAME AND ITS 84200014 C LENGTH. 84300014 NCNAM=NAME(3) 84400014 NCNAM2=NAME(4) 84500014 NCLGTH=LENGTH 84600014 C BRANCH TO THE ENTRY MAKING 84700014 C OPERATION 84800014 GOTO 3025 84900014 C FOLLOWING TURNS THE FIRST TIME 85000014 C SWITCH OFF INDICATING THAT THE 85100014 C FIRST COMMON VARIABLE HAS NOT 85200014 C YET BEEN ACCESSED BY GETWD. 85300014 3070 NCMFST=0 85400014 C FOLLOWING INSURES THAT THE 85500014 C DELIMITER FOLLOWING THE SLASH 85600014 C IS A SLASH. IF IT IS, BRANCH TO 85700014 C PROCESS THE UNLABELED COMMON 85800014 IF (NDELM.EQ.NSLAS) GO TO 3020 85900014 3080 MSGNO = 69 86000014 GO TO 5005 86060020 3088 MSGNO=88 86130017 GO TO 5005 86160020 3137 MSGNO = 202 86200014 NERSW = 6 86300014 3138 IF( NDELM.EQ.NGPMK ) GO TO 9999 86370020 CALL IEKCGW 86440020 IF( NDELM.NE.NRTPR ) GO TO 3138 86510020 IF (NDELM.NE.NRTPR) GO TO 3138 86600014 C FOLLOWING CALL TO GETWD ACCESSES86700014 C THE ELEMENT FOLLOWING THE 86800014 C SUBSCRIPTED VARIABLE. 86900014 3140 CALL IEKCGW 87000014 C ELEMENT MUST BE A DELIMITER. 87100014 C IF IT IS NOT, BRANCH TO RECORD 87200014 C THE ERROR. 87300014 IF(LENGTH.NE.0) GOTO 3080 87400014 C IF DELIMITER IS A SLASH, BRANCH 87500014 C TO HANDLE A NEW COMMON BLOCK 87600014 C NAME. 87700014 IF(NDELM.EQ.NSLAS) GOTO 3005 87800014 C IF DELIMITER IS A COMMA, BRANCH 87900014 C TO ACCESS NEXT VARIABLE. 88000014 IF(NDELM.EQ.NCOMA) GOTO 3090 88100014 C BRANCH TO TEST FOR END MARK 88200014 C IF DELIMITER IS NOT AN END MARK,88300014 C BRANCH TO RECORD THE ERROR, AS 88400014 C ANY OTHER DELIMITER AT THIS 88500014 C POINT IS INVALID. 88600014 3130 IF(NDELM.NE.NGPMK) GOTO 3080 88700014 GO TO 9999 88800014 3060 MSGNO = 112 88900014 GOTO 5000 89000014 3155 MSGNO = 75 89100014 GO TO 5005 89200020 3160 MSGNO = 86 89300014 GO TO 5005 89400020 3165 MSGNO = 87 89500014 GO TO 5005 89504020 3167 MSGNO = 167 89508020 5005 NERSW = 7 89512020 CALL IEKCDP 89516020 C FIND NEXT VARIABLE OR GROUP 89520020 5006 IF( NDELM.EQ.NGPMK ) GO TO 9999 89524020 IF( NDELM.EQ.NSLAS ) GOTO 5008 89528020 IF( NDELM.EQ.NCOMA ) GO TO 5007 89532020 CALL IEKCGW 89536020 GO TO 5006 89540020 C IF FIRST VARIABLE IN BLOCK 89544020 C BRANCH TO SET UP POINTERS 89548020 5007 IF( NCMPTR.EQ.0 ) GO TO 3001 89552020 C BRANCH TO PROCESS NEXT VARIABLE 89556020 GO TO 3090 89560020 C IF ERROR IN GROUP NAME 89564020 C ACCESS NEXT VARIABLE 89568020 C OTHERWISE ACCESS GROUP NAME 89572020 5008 IF( NPRVDL.EQ.NSLAS ) GO TO 5007 89576020 GO TO 3005 89580020 5000 NERSW = 6 89600014 CALL IEKCDP 89700014 9999 RETURN 89800014 END 89900014 ./ ADD SSI=02000674,NAME=IEKCSR,SOURCE=0 C SUBROUTINE XSUBPG 00200014 SUBROUTINE IEKCSR 00400014 C 724000-726000 000A 00500015 C0030342000 15553 00550016 C1176418000-426000,430000-432000,436000 16623 00570016 C 00600014 C1411259000,619000,652080-653760,722100-722600 17890 00700017 C2210202700-202800 18949 00750017 C2842372600-373200,401000 19000 00760017 C2621722400 000C 00780017 C1040259000,619000,652080-653760,722100-722600 22032 00785018 C 604400-605600,617000 21981 00790018 C 415000,453000,457000-458000 22011 00795018 C 168000 000D 00797018 C 745000-746000 22023 00798018 C 122500,202990-203060,333100,333400,368000 20.1 34253 00799020 C 333300-333700 LL46524 00799521 C A636300-637500 LL55885 00799721 C C088000,A419500,A422500 LL57810 00799821 C C333300-33350,A333200-333220,A333800-333988 LL63554 00799921 C DICTIONARY LAYOUT 00899921 C 01000014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 01200020 LOGICAL*1 BYA,BYB,BYC 01400014 INTEGER*2 DIS,MDD,TYP 01600020 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 01800014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 02000014 * NAM1,NAM2,NAM3,NAM4 02200020 C 02400014 C 02600014 C INTERMEDIATE TEXT LAYOUT 02800014 C 03000014 LOGICAL * 1 ADJCD 03200014 INTEGER * 2 TMOD,TTYP 03400014 INTEGER TXTCHN,TPTR 03600014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 03800014 C 04000014 C 04200014 C LABEL LAYOUT 04400014 C 04600014 INTEGER BPC,PB,ADC,SN,NPBP,ILEAD,JLEAD,BSZ 04800014 LOGICAL*1 COMP,DN 05000014 STRUCTURE// BPC,BYA,BYB,COMP,DN,PB,SN,NPBP,ILEAD,JLEAD,BSZ 05200014 C 05400014 C 05600014 C EQUIVALENCE LAYOUT 05800014 C 06000014 INTEGER GRPCHN,PTRVAR,PTRBSG,EISN,PTREQV,CHNVAR,OFFSET,SUBSCR 06200014 LOGICAL * 1 INDBYT,NSUBS 06400014 C 06600014 C GROUP ENTRY 06800014 STRUCTURE // GRPCHN,PTRVAR,PTRBSG,EISN 07000014 C 07200014 C VARIABLE ENTRY 07400014 C 07600014 STRUCTURE//INDBYT// PTREQV,NSUBS // PTREQV,CHNVAR,OFFSET,SUBSCR 07800014 C 08000014 COMMON /IEKAAA/ NPTR (2,35) 08200014 COMMON /IEKAER/ NERTBL (2,50) 08400014 C 08600014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB,INDSAV 08800021 INTEGER SLIMS 09000014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 09200014 *NBLK,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 09400014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 09600014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 09800014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 10000014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 10200014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 10400014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 10600014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 10800014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 11000014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 11200014 C 11400014 EQUIVALENCE (NPTR (1,9), NPUT) 11600014 INTEGER*2 NOPTS,NSTNS,NOPTM,NSTNM 11800014 DIMENSION NOPTS(4),NSTNS(4),NOPTM(4),NSTNM(4) 12000014 DATA NOPTS/2,8,16,1/,NSTNS/4,4,8,4/,NOPTM/4,6,8,2/,NSTNM/5,7,9,3/ 12200014 DATA MASK3/Z0000FFFF/ 12300020 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC12400014 C C12600014 C XSUBPG - IEKCSR C12800014 C C13000014 C FUNCTION - XSUBPG TRANSLATES THE CALL, ENTRY, FUNCTION, AND SUB- C13200014 C ROUTINE STATEMENTS. IT CHECKS SYNTAX AND GENERATES C13400014 C THE NECESSARY DICTIONARY AND TEXT ENTRIES. C13600014 C C13800014 C CALLED BY - DSPTCH C14000014 C C14200014 C CALLS - CLOSE, ERROR, GETWD, LABTLU, LITCON, SYMTLU, COMPAT, PUTX C14400014 C C14600014 C COMMON - BLANK, PH10 C14800014 C C15000014 C ERRORS - 57, 58, 199, 59, 152 C15200014 C C15400014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC15600014 C 15800014 C 16000014 C DETERMINE TYPE OF STATEMENT 16200014 IF (NCARD(4).EQ.8) GO TO 1030 16400014 IF (NCARD(4).EQ.22) GO TO 1075 16600014 IF(ISN.EQ.2) 16800018 * GO TO 1080 17000014 C NOT FIRST STATEMENT 17200014 MSGNO = 199 17400014 GOTO 1010 17600014 C CALL OPERATIONS 17800014 1030 NEXCSG = 1 18000014 NCALLG=1 18200014 NPTR(1,23) = 1 18400014 ADJCD (NPUT) = 246 18600014 C ACCESS NAME 18800014 C CALL GETWD 19000014 CALL IEKCGW 19200014 C BRANCH IF NOT A VARIABLE 19400014 IF (NACCSV.NE.2) GO TO 1005 19600014 C PUT NAME IN DICTIONARY 19800014 C CALL COMSYM 20000014 CALL IEKCS3 20200014 C IF DICT ENTRY HAS BEEN 20220016 C MADE - BRANCH 20240016 IF(NTRYMD.EQ.1) GO TO 1045 20260017 KTEST=2**(IDOLEV+NDOLEV-1) 20268017 IF((DIS(IDCTPT).GT.KTEST.AND.TYP(IDCTPT).NE.4.AND.TYP(IDCTPT).NE. 20276017 *12).OR.(DIS(IDCTPT).EQ.KTEST.AND.TYP(IDCTPT).NE.4.AND.TYP(IDCTPT) 20284017 *.NE.12.AND.TYP(IDCTPT).NE.1))GO TO 1038 20292017 NAM3XX=LAND(NAM3(IDCTPT),MASK3) 20301020 IF(NPTR(1,31) .NE. NPTR(2,31) .AND. NPTR(1,10) .EQ. NAM3XX 20310020 ..AND.NPTR(2,10).EQ.NAM4(IDCTPT)) GO TO 167 20320016 C BRANCH IF CALL BY VALUE 20400014 C IF VARIABLE WAS PASSED AS 20500017 C ARGUMENT AND WAS NOT YET 20600017 C RETYPED AS DUMMY EXTERNAL 20700017 C - RETYPE - 20800017 1045 IF(TYP(IDCTPT).EQ.1) TYP(IDCTPT) = 12 20900017 C OTHERWISE RETYPE TO 21000017 C EXTERNAL FUNCTION 21100017 IF(TYP(IDCTPT).EQ.0) TYP(IDCTPT) = 4 21200017 C CALL PUTX 21600014 CALL IEKCPX 21800014 C TEST IF ANY ARGUMENTS 22000014 IF(NDELM.EQ.NLFPR) GOTO 1060 22200014 C END OF STATEMENT 22400014 IF(NDELM.EQ.NGPMK) GOTO 1065 22600014 1057 MSGNO = 58 22800014 GOTO 1010 23000014 171 MSGNO=171 23060016 GO TO 1010 23120016 1038 MSGNO = 168 23200014 GO TO 1010 23400014 C BUMP PAREN COUNT 23600014 1060 NPRCNT=NPRCNT+1 23800014 ADJCD (NPUT) = 15 24000014 GOTO 1015 24200014 C CLOSE TEXT 24400014 C CALL CLOSE 24600014 1065 NCLSTX = 1 24800014 CALL IEKCPX 25000014 NCALLG=0 25200014 GOTO 1015 25400014 C ENTRY OPERATIONS 25600014 1075 NPTR(1,20) = 1 25800014 IF(ADJCD (LPUT) .EQ. 223) GO TO 1077 26000014 C GENERATE LABEL PRECEDING 26200014 C ENTRY IN TEXT. 26400014 LBSWG = 1 26600014 C CALL LABTLU 26800014 CALL IEKCLT 27000014 ADJCD (NPUT) = 223 27200014 MTPSET = -1 27400014 C CALL PUTX 27600014 CALL IEKCPX 27800014 GO TO 1080 28000014 C 28200014 C GEN LABEL EXISTS IN TEXT. 28400014 C IF IT WAS NOT GENERATED FOR 28600014 C COMPUTED GO TO USAGE RESET BYA. 28800014 C (REFERENCED AND OBJECT OF BRANCH 29000014 C BITS PRESET BY IEKCLT). 29200014 C 29400014 1077 IF(.NOT.TBIT(BYB(TPTR(LPUT)),7)) BYA (TPTR (LPUT)) = 0 29600014 C SUBROUTINE / FUNCTION OPERATIONS 29800014 1080 ADJCD(NPUT) = 208 30000014 MTPSET = 1 30200014 C CALL PUTX 30400014 1085 CALL IEKCPX 30600014 C SAVE LOC IN NSUBRG 30800014 NSUBRG = LPUT 31000014 ADJCD (NPUT) = 0 31200014 IF (NCARD(4).EQ.46) NPTR(2,31) = 1 31400014 IF (NCARD(4).NE.46.AND.NCARD(4).NE.22) NPTR(1,31) = 1 31600014 C ACCESS NAME 31800014 C CALL GETWD 32000014 CALL IEKCGW 32200014 C BRANCH IF NOT A VARIABLE 32400014 IF (NACCSV.NE.2) GO TO 1005 32600014 C PUT NAME IN DICTIONARY 32800014 C CALL COMSYM 33000014 CALL IEKCS3 33200014 C MAKE SURE THERE IS A UNIQUE 33250016 C NAME FOR ENTRY POINT. 33300016 NAM3XX=LAND(NAM3(IDCTPT),MASK3) 33310020 C WAS NAME USED AS SUBROUTINE 33320021 C OR FUNCTION NAME? 33322021 IF(NCARD(4) .EQ. 22 .AND. 33330021 C (NAM3XX .EQ. NPTR(1,10) .AND. NAM4(IDCTPT) .EQ. NPTR(2,10))) 33350021 C GO TO 171 33370021 C FOR SUBROUTINES ONLY- CHECK 33380021 C THAT ENTRY NAME WAS NOT USED 33390021 C AS A VARIABLE BEFORE.FUNCTIONS- 33392021 C IT IS PERMISSIBLE. 33394021 IF(NCARD(4) .EQ. 22 .AND. DIS(IDCTPT) .GT. 0 .AND. 33396021 * NPTR(2,31) .NE. 0) GO TO 171 33398021 C ENTRY - BRANCH AROUND MODE SET 33400014 NLENSV=0 33600014 IF (NCARD(4).EQ.22) GO TO 1100 33800014 IF (NPTR(1,31).EQ.1) NPTR(1,14) = IDCTPT 34000014 IF (NCARD(4).EQ.24.OR.NCARD(4).EQ.46) GO TO 1199 34200014 C SET SPECIFICATION BIT ON 34260016 BYA(IDCTPT)=BITON(BYA(IDCTPT),7) 34320016 IF(NCARD (4) .EQ. 10) GO TO 1197 34400014 C SET MODE EXPLICITLY 34600014 III = 2 34800014 IF (NCARD(4).EQ.28) III = 1 35000014 IF (NCARD(4).EQ.4) III = 3 35200014 IF (NCARD(4).EQ.33) III = 4 35400014 C SET STANDARD MODE 35600014 MDD(IDCTPT) = NSTNM(III) 35800014 GO TO 1199 36000014 1197 MDD (IDCTPT) = 6 36200014 IF(NDELM .EQ. NASTR) GO TO 1200 36400014 C NAME OF SUBROUTINE OR FUNCTION 36600014 1199 NPTR(1,10) = NAM3(IDCTPT) 36700020 NPTR(1,10)=LAND(NPTR(1,10),MASK3) 36900020 NPTR (2,10) = NAM4 (IDCTPT) 37000014 IF (NDELM.NE.NASTR) GO TO 1100 37200014 IF(NCARD(4).EQ.24.AND.MDD(IDCTPT).EQ.7)III=2 37260017 IF(NCARD(4).EQ.24.AND.MDD(IDCTPT).EQ.5)III=1 37320017 C ACCESS LENGTH SPECIFICATION 37400014 C CALL GETWD 37600014 CALL IEKCGW 37800014 IF (LENGTH.NE.0) GO TO 1205 38000014 C ERROR LENGTH 38200014 1200 MSGNO=59 38400014 GOTO 1010 38600014 C CALL LITCON TO CONVERT LENGTH. 38800014 C RESULT WILL BE IN NACCM. 39000014 C CALL LITCON 39200014 1205 CALL IEKCLC 39400014 C ERROR IF NOT INTEGER 39600014 IF (NNT.NE.1) GO TO 1200 39800014 NLENSV = NACCM 40000014 C BRANCH IF NOT ENTRY WITHIN 40200014 C A FUNCTION SUBPROGRAM. 40400014 1100 IF (NCARD(4).NE.22.OR.NPTR(1,31).EQ.0) GO TO 1140 40600014 C EQUIVALENCE ENTRY NAME 40800014 C TO FUNCTION NAME. 41000014 IF (NPTR(1,14).EQ.0) GO TO 1125 41200014 C FIND END OF EQUIV. CHAIN 41400014 IF((NPTR(2,29)+16).GT.NPTR(2,30)) CALL IEKAGC(2) 41500018 IF (NPTR(2,26).EQ.0) GO TO 1110 41600014 N=NPTR(1,4) 41900016 INDSAV=INDBYT(N) 41950021 GRPCHN(N)=NPTR(2,29) 42200016 INDBYT(N)=INDSAV 42250021 GO TO 1120 42500016 1110 NPTR(2,26) = NPTR(2,29) 42800014 C GENERATE GROUP EQUIV. ENTRY 43400014 1120 K = NPTR(2,29) 43600014 NPTR(1,4)=K 43700016 NPTR(1,15) = K 43800014 NPTR (2,29) = NPTR (2,29) + 16 44000014 PTRVAR (K) = K + 16 44200014 EISN (K) = ISN 44400014 C GENERATE VAR. ENTRY FOR 44600014 C FUNCTION NAME. 44800014 PTREQV (K + 16 ) = NPTR (1,14) 45000014 NPTR(1,14) = 0 45200014 IF((NPTR(2,29)+12).GT.NPTR(2,30)) CALL IEKAGC(2) 45300018 NPTR (2,29) = NPTR (2,29) + 12 45400014 C GENERATE VAR. FOR ENTRY NAME 45600014 1125 IF((NPTR(2,29)+12).GT.NPTR(2,30)) CALL IEKAGC(2) 45700018 K=NPTR(2,29) 45800018 NPTR (2,29) = NPTR (2,29) + 12 46000014 PTREQV (K) = IDCTPT 46200014 J = NPTR(1,15) 46400014 J = PTRVAR (J) 46600014 C SEARCH FOR LAST VAR. ENTRY 46800014 1130 IF(CHNVAR (J) .EQ. 0) GO TO 1135 47000014 J = CHNVAR (J) 47200014 GOTO 1130 47400014 C SET CHAIN IN VAR. ENTRY 47600014 1135 CHNVAR (J) = K 47800014 C MODE IS SCALAR FOR SUBROUTINE 48000014 C OR SUBROUTINE ENTRY NAMES. 48200014 1140 IF (NPTR(2,31).EQ.1.OR.NCARD(4).EQ.22.AND.NPTR(1,31).NE.1) 48400014 *TMOD(NPUT) = 0 48600014 IF (NLENSV.EQ.0) GO TO 1185 48800014 C TEST FOR INVALID LENGTH SPEC. 49000014 IF(NLENSV.NE.NSTNS(III).AND.NLENSV.NE.NOPTS(III)) GO TO 1200 49200014 C IF OPTIONAL LENGTH GIVEN, 49400014 C RESET TO OPTIONAL MODE. 49600014 IF (NLENSV.EQ.NOPTS(III)) MDD(IDCTPT) = NOPTM(III) 49800014 C PUT TO TEXT 50000014 C CALL PUTX 50200014 1185 CALL IEKCPX 50400014 C TEST IF ANY ARGUMENTS 50600014 IF(NDELM .EQ. NLFPR) GO TO 100 50800014 IF (NCARD(4).NE.46.AND.NCARD(4).NE.22) GO TO 56 51000014 IF (NDELM.NE.NGPMK) GO TO 1057 51200014 C CALL CLOSE 51400014 1190 NCLSTX = 1 51600014 C CALL PUTX 51800014 CALL IEKCPX 52000014 GOTO 1015 52200014 C FUNCTION WITH NO ARGUMENTS 52400014 56 MSGNO = 56 52600014 GO TO 1010 52800014 C 53000014 C ARGUMENTS PRESENT. 53200014 C SET OPENING PARENTHESIS. 53400014 C 53600014 100 ADJCD (NPUT) = 25 53800014 C 54000014 C FOLLOWING CALL TO GETWD ACCESSES THE 54200014 C FIRST (NEXT) ARGUMENT. 54400014 C 54600014 C CALL GETWD 54800014 105 CALL IEKCGW 55000014 C 55200014 C IF THE ELEMENT ACCESSED IS A CONSTANT55400014 C BRANCH TO SET THE ERROR. 55600014 C 55800014 IF(NACCSV .EQ. 1) GO TO 1057 56000014 C 56200014 C IF THE ELEMENT ACCESSED IS A 56400014 C DELIMITER, BRANCH. 56600014 C 56800014 IF(LENGTH .EQ. 0) GOTO 125 57000014 C 57200014 C VARIABLE ACCESSED. 57400014 C GENERATE DICTIONARY ENTRY. 57600014 C 57800014 C CALL COMSYM 58000014 CALL IEKCS3 58200014 C 58400014 C IF A SF NAME IS BEING USED AS AN 58600014 C ARGUMENT, BRANCH TO SET THE ERROR. 58800014 C 59000014 IF(TYP (IDCTPT) .EQ. 6) GO TO 167 59200014 C 59400014 C IF THE VARIABLE IS DIMENSIONED OR IS 59600014 C EXTERNAL, BRANCH. 59800014 C 60000014 IF (MOD24(PDI(IDCTPT)).NE.0.OR.TYP(IDCTPT).EQ.4) GO TO 120 60200014 C 60400014 C IF TYPE IS DUMMY EXTERNAL 60440018 C FUNCTION, BRANCH. 60480018 C 60520018 IF(TYP(IDCTPT).EQ.12) GOTO 106 60560018 C SET TYPE TO DUMMY SCALAR. 60600014 C 60800014 TYP (IDCTPT) = 1 61000014 C 61200014 C SET TO CALL BY VALUE. 61400014 C 61600014 106 BYB(IDCTPT)=BITON(BYB(IDCTPT),0) 61700018 C 62000014 C BUILD TEXT. 62200014 C 62400014 C 62600014 C CALL PUTX 62800014 110 CALL IEKCPX 63000014 C 63200014 112 IF(NDELM .EQ. NCOMA) GO TO 105 63400014 IF (NDELM.NE.NRTPR) GO TO 152 63600014 C 63630021 C IT IS A RIGHT PAREN. CHECK THAT END MARK FOLLOWS. 63660021 C IF NOT, SET ERROR. 63690021 C 63720021 IF(NCDIN(NSCNPT) .NE. 79) GO TO 152 63750021 C 63800014 C SET CLOSING PARENTHESIS. 64000014 C 64200014 ADJCD(NPUT) = 5 64400014 MTPSET = 1 64600014 C CALL PUTX 64800014 CALL IEKCPX 65000014 GO TO 1190 65200014 C 65400014 C DELIMITER ACCESSED. 65600014 C 65800014 125 IF(NDELM .NE. NASTR) GO TO 130 66000014 C 66200014 C DUMMY RETURN. 66400014 C IF NOT SUBROUTINE OR ENTRY, ERROR. 66600014 C 66800014 IF(NCARD (4) .NE. 46 .AND. NCARD (4) .NE. 22) GO TO 152 67000014 C 67200014 C CALL GETWD 67400014 CALL IEKCGW 67600014 IF (LENGTH.EQ.0) GO TO 112 67800014 152 MSGNO = 152 68000014 GO TO 1010 68200014 C 68400014 130 IF(NDELM .NE. NSLAS) GO TO 152 68600014 C CALL GETWD 68800014 CALL IEKCGW 69000014 IF(NACCSV .NE. 2) GO TO 1057 69200014 IF(NDELM .NE. NSLAS) GO TO 152 69400014 C CALL COMSYM 69600014 CALL IEKCS3 69800014 IF(TYP (IDCTPT) .EQ. 6) GO TO 167 70000014 C CALL GETWD 70200014 CALL IEKCGW 70400014 IF(LENGTH .NE. 0) GO TO 152 70600014 C 70800014 C VARIABLE IS CALL BY NAME. 71000014 C SET CALL BY VALUE BIT OFF. 71200014 C 71400014 120 BYB (IDCTPT) = BITOFF (BYB (IDCTPT),0) 71600014 C SET CALL BY NAME ON. 71800014 BYB (IDCTPT) = BITON (BYB (IDCTPT),1) 72000014 C 72200014 IF (TYP(IDCTPT).EQ.4) GO TO 110 72300015 TYP(IDCTPT)=1 72400015 IF(MOD24(PDI(IDCTPT)).NE.0) TYP(IDCTPT)=3 72500015 GO TO 110 72800014 167 MSGNO = 167 73000014 GO TO 1010 73200014 C 73400014 1005 MSGNO=57 73600014 C CALL ERROR 73800014 1010 NERSW = 6 74000014 CALL IEKCDP 74200014 C BRANCH IF CALL 74400014 1015 IF( NCARD(4).NE.22 .AND. 74500018 1 ( NCARD(4).EQ.8 .OR. IFTRLG.EQ.2 ) ) GOTO 9999 74600018 LBSWG = 1 74800014 C CALL LABTLU 75000014 CALL IEKCLT 75200014 C PUT LABEL PNTR WITH 208 ADJ CODE 75400014 TPTR(NSUBRG) = ILABPT 75600014 ADJCD (NPUT) = 223 75800014 MTPSET = -1 76000014 C CALL PUTX 76200014 CALL IEKCPX 76400014 9999 CONTINUE 76600014 RETURN 76800014 END 77000014 ./ ADD SSI=21440029,NAME=IEKCTN,SOURCE=0 C SUBROUTINE XTNDED 00100014 SUBROUTINE IEKCTN 00200014 C1421007000-008000,011000,381000 15357 00220016 C1421219000,263000 15457 00240016 C1421375000 15553 00260016 C1311250200-250600 20279 00280018 C0380178070-178210 20287 00290018 C0800137500,456500 000D 00295018 C 258000,263640-263920,270000-272000,273080-274480 23519 00297018 C 142200-142800,158000-161000 23395 00297719 C 512100-512500 23859 00298419 C 157500,202300-202600 24796 00299119 C D137000,A136500-137000,C206500 LL53079 00299521 C 00300014 C DICTIONARY LAYOUT 00400014 C 00500014 INTEGER CHN,ADC,PDI,NAM1,NAM2,NAM3,NAM4 00600014 LOGICAL*1 BYA,BYB,BYC,NAMBEG,BNAM 00700016 INTEGER*2 DIS,MDD, TYP, XREF 00800016 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,BYC 00900014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01000014 * NAM1,NAM2,NAM3,NAM4 01100014 STRUCTURE // CHN,BYA,BYB,DIS,ADC,MDD,TYP,PDI, 01130016 * NAM1,NAM2,XREF,NAMBEG,BNAM 01160016 C 01200014 C 01300014 C INTERMEDIATE TEXT LAYOUT 01400014 C 01500014 LOGICAL * 1 ADJCD 01600014 INTEGER * 2 TMOD,TTYP 01700014 INTEGER TXTCHN,TPTR 01800014 STRUCTURE // ADJCD // TXTCHN,TMOD,TTYP,TPTR 01900014 C 02000014 COMMON /IEKAAA/ NPTR (2,35) 02100014 COMMON /IEKAER/ NERTBL (2,50) 02200014 LOGICAL*1 NCDIN,NIMPCT,NDLMTB 02300014 INTEGER SLIMS 02400014 COMMON /IEKCAA/ NCARD(4),NCDIN(1392),NIMPCT(2,26),NMODET(9), 02500014 *M2R3,NEQ,NQUOT,NPLUS,NPER,NLFPR,NMIN,NASTR,NSLAS,NCOMA,NRTPR, 02600014 *NGPMK,NDOLAR,NLOGTB(2,10),NDLMTB(2,12),NAMTYP(2,5),NGENLB,ISN, 02700014 *IDOLEV,NAME(4),NBEGPT,NSCNPT,LENGTH,NPRVDL,NDELM,NTST,NNT,NLOG, 02800014 *NCPLX,NACCM,NACCSV,NMNSW,NCPX,NSHFT1,ISAVE2,NXTRN,NTST2,IFTRLG, 02900014 *NDOSG,NCALLG,NASF,NRELIF,NXSMNG,NDATSG,NPRCNT,LBSWG,NSBOL,NDVSV, 03000014 *INEWDL,IPREDL,IASTR,NARGSW,NCOMEX,NTYPEX,IMDOSW,NLFARY,NDOLRT, 03100014 *NHRETN,IOSWG,NAMLST,NIF,NSUBCT,NSUBSW,LABCMP,NDATSV,NXTRA,NBEGDO, 03200014 *NEXCSG,NDOLEV,LIFTXL,LSTXX,LABSAV,NSUBRG,NTRYMD,IDCTPT,ILABPT, 03300014 *NCLSTX,MTPSET,NPUTSV,LPUT,MSGNO,NERSW,IMPDOD(6,20),IASFTB(3,20), 03400014 *KSV1,NSSEQ,SLIMS(2,5),LFPUTS(2,5),LPUTS(5),LASTEM,NDOPDN(6,25) 03500014 C 03600014 EQUIVALENCE (NPTR (1,9), NPUT) 03700014 DIMENSION ITBL(13) 03800014 DATA ITBL/3,5,7,1,8,2,8,16,1,2,4,6,9/ 03900014 LOGICAL * 1 LNAME (4) , LPAD 04000014 EQUIVALENCE (INAME,LNAME (1)) 04100014 DATA NX1,NX2/Z0000C4C9,ZD6C3E27B/ 04200014 C 04300014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 04400014 C C 04500014 C THIS ROUTINE HANDLES THE IMPLICIT, NAMELIST,AND 04600014 C STRUCTURE STATEMENT 04700014 C C 04800014 C 04900014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 05000014 C 05100014 C IF THE STATEMENT IS THE 05200014 C STATEMENT PORTION OF A LOGICAL- 05300014 C IF, BRANCH TO SET THE ERROR. 05400014 C NPTR(1,2) CONTAINS THE PREVIOUS 05500014 C CLASS CODE--LOG.-IF 6 31. 05600014 IF(NPTR(1,2).EQ.31) GOTO 1110 05700014 GO TO (100,200,2005,400),NERSW 05800014 C C05900014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC06000014 C C06100014 C FUNCTION - XSTRUC CHECKS SYNTAX FOR THE STRUCTURE STATEMENT. IT C06200014 C ENSURES EACH VARIABLE IS IN THE DICTIONARY AND ADDS EACH C06300014 C VARIABLE5S DISPLACEMENT TO THE DICTIONARY. C06400014 C C06500014 C ERRORS - 97, 98, 99, 100 C06600014 C C06700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC06800014 2005 JDISP=0 06900014 C CALL GETWD 07000014 2010 CALL IEKCGW 07100014 IF(NDELM.NE.NSLAS) GOTO 2020 07200014 C CALL GETWD 07300014 2015 CALL IEKCGW 07400014 2020 IF(LENGTH.EQ.0) GOTO 2025 07500014 C CALL CSORN 07600014 CALL IEKCCR 07700014 IF (TYP(IDCTPT).GT.3.OR.MOD24(PDI(IDCTPT)).NE.0) GO TO 2085 07800014 IBYA = BYA (IDCTPT) 07900014 IBYB = BYB (IDCTPT) 08000014 IF(LAND (IBYA,42) .NE. 0 .OR. LAND (IBYB,17) .NE. 0) GO TO 2085 08100014 IF( .NOT. TBIT (BYA (IDCTPT),0)) GO TO 2040 08200014 C PREVIOUSLY STRUCTURED 08300014 IF(DIS (IDCTPT) .EQ. JDISP) GO TO 2045 08400014 C DISPLACEMENTS ARE NOT EQUAL 08500014 MSGNO=98 08600014 GOTO 5000 08700014 2040 BYA (IDCTPT) = BYA (IDCTPT) + 128 08800014 TYP (IDCTPT) = 2 08900014 DIS (IDCTPT) = JDISP 09000014 C COMPUTE NEXT DISPLACEMENT 09100014 2045 I = MDD (IDCTPT) 09200014 IF(I.LT.2.OR.I.GT.10) GOTO 2025 09300014 GOTO (2025,2050,2060,2055,2060,2065,2060,2070,2065,2075),I 09400014 2050 JDISP=JDISP+1 09500014 GOTO 2080 09600014 2055 IF(LAND(JDISP,1).NE.0) GOTO 2095 09700014 JDISP=JDISP+2 09800014 GOTO 2080 09900014 2060 IF(LAND(JDISP,3).NE.0) GOTO 2095 10000014 JDISP=JDISP+4 10100014 GOTO 2080 10200014 2065 IF(LAND(JDISP,7).NE.0) GOTO 2095 10300014 JDISP=JDISP+8 10400014 GOTO 2080 10500014 2070 IF(LAND(JDISP,7).NE.0) GOTO 2095 10600014 JDISP=JDISP+16 10700014 GOTO 2080 10800014 2075 JDISP = JDISP + NAM2 (IDCTPT) 10900014 2080 IF (NDELM.EQ.NGPMK) GO TO 9999 11000014 IF(NDELM.EQ.NSLAS) GOTO 2090 11100014 IF(NDELM.EQ.NCOMA) GOTO 2015 11200014 2025 MSGNO = 97 11300014 GOTO 5000 11400014 2085 MSGNO = 99 11500014 GOTO 5000 11600014 C CALL GETWD 11700014 2090 CALL IEKCGW 11800014 IF(NDELM.NE.NSLAS) GOTO 2025 11900014 JDISP=0 12000014 GOTO 2015 12100014 C WRONG WORD BOUNDARY 12200014 2095 MSGNO = 100 12300014 GOTO 5000 12400014 C C12500014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC12600014 C C12700014 C FUNCTION - XNMLST CHECKS SYTAX AND GENERATES DICTIONARY C12800014 C ENTRIES FOR THE NAMELIST STATEMENT. EVARIABLE AND ARRAY C12900014 C C13000014 C ERRORS - 64, 65, 66, 67 C13100014 C C13200014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC13300014 C 13400014 C INSURE THAT THE STATEMENT BEGINS13500014 C WITH A SLASH. 13600014 100 LSTNAM=0 13650021 IF(NCDIN(14) .NE. NSLAS) GO TO 3005 13700021 IF(SLIMS(1,1)+12.GT.SLIMS(2,1))CALL IEKAGC(1) 13750018 IF(NPTR (1,32) .EQ. 0) NPTR (1,32) = SLIMS (1,1) 13800014 C FOLLOWING CALL TO GETWD ACCESSES13900014 C THE NAMELIST NAME. 14000014 C CALL GETWD 14100014 3020 CALL IEKCGW 14200014 C SET SWITCH INDICATING TO PUTX 14220019 C THAT NAMELIST TEXT IS TO BE 14240019 C GENERATED. 14260019 NPTR(1,8)=3 14280019 C INSURE IT IS A VARIABLE. 14300014 IF(NACCSV.NE.2) GOTO 3021 14400014 C INSURE A SLASH DELIMITS THE NAME14500014 IF(NDELM.NE.NSLAS) GOTO 3005 14600014 C PACK NAME. 14700014 C DICTIONARY LOOK-UP. 14800014 C CALL COMSYM 14900014 CALL IEKCS3 15000014 C INSURE THAT THE NAME WAS NOT 15100014 C PREVIOUSLY USED. 15200014 IF(NTRYMD.NE.1) GOTO 3031 15300014 C SET ADJECTIVE CODE. 15400014 ADJCD(SLIMS(1,1)) = 248 15500014 C SET MODE. 15600014 MDD (IDCTPT) = 13 15700014 LSTNAM=IDCTPT 15750019 C CALL PUTX 16200014 CALL IEKCPX 16300014 C FOLLOWING CALL TO PUTX HAS THE 16400014 C SLASH-CHAIN ENTRY GENERATED. 16500014 C CALL PUTX 16600014 MTPSET = 1 16700014 CALL IEKCPX 16800014 C FOLLOWING CALL TO GETWD ACCESSES16900014 C THE LIST ELEMENT. 17000014 C CALL GETWD 17100014 3035 CALL IEKCGW 17200014 C INSURE IT IS A VARIABLE. 17300014 IF(NACCSV.NE.2) GOTO 3039 17400014 C PACK NAME. 17500014 C DICTIONARY LOOK-UP. 17600014 C CALL COMSYM 17700014 CALL IEKCS3 17800014 C BRANCH TO SET ERROR IF VARIABLE 17807018 C HAS BEEN USED AS NAMELIST NAME. 17814018 IF(MDD(IDCTPT).EQ.13)GO TO 3039 17821018 C DIAGNOSE DUMMY VARIABLE OR ARRAY. 17830014 IF(TBIT (TYP (IDCTPT),15)) GO TO 3039 17860014 ADJCD (SLIMS (1,1)) = 247 17900014 C CALL PUTX 18000014 CALL IEKCPX 18100014 C IF THE VARIABLE IS DELIMITED BY 18200014 C AN END MARK, BRANCH. 18300014 IF(NDELM.EQ.NGPMK) GOTO 3015 18400014 C IF A COMMA, INDICATING ANOTHER 18500014 C LIST ITEM, BRANCH. 18600014 IF(NDELM.EQ.NCOMA) GOTO 3035 18700014 C IF NOT A SLASH, THE ONLY VALID 18800014 C DELIMITER AT THIS POINT, BRANCH 18900014 C TO SET THE ERROR. 19000014 IF(NDELM.NE.NSLAS) GOTO 3005 19100014 C CALL CLOSE 19200014 NCLSTX = 1 19300014 C CALL PUTX 19400014 CALL IEKCPX 19500014 GOTO 3020 19600014 C CALL CLOSE 19700014 3015 NCLSTX = 1 19800014 C CALL PUTX 19900014 CALL IEKCPX 20000014 GO TO 9999 20100014 3039 MSGNO = 67 20200014 C ERASE NAMELIST MODE 20230019 MDD(LSTNAM)=5 20260019 GO TO 5000 20300014 3031 MSGNO = 66 20400014 GO TO 5000 20500014 3005 MSGNO = 64 20600014 IF(LSTNAM .NE. 0) MDD(LSTNAM)=5 20650021 GO TO 5000 20700014 3021 MSGNO = 65 20800014 GO TO 5000 20900014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC21000014 C C21100014 C FUNCTION - XIMPC CHECKS THE IMPLICIT STATEMENT FOR SYNTAX C21200014 C AND RESETS THE IMPLICIT MODE TABLE ENIMPCN ACCORDING C21300014 C TO THE SPECIFICATIONS IN THE STATEMENT. C21400014 C C21500014 C ERRORS - 78, 79, 80, 81, 82, 83, 77, 84 C21600014 C C21700014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC21800014 200 NSCNPT = NCARD(1) 21900014 IF((ISN.NE.2.AND.NPTR(1,31).EQ.NPTR(2,31).AND.NPTR(1,2).NE.3) 21930016 ..OR.(ISN.NE.3.AND.NPTR(1,31).NE.NPTR(2,31))) GO TO 76 21960016 NTST=1 22000014 IEND = 0 22100014 1005 LENGTH=4 22200014 NSTART=NSCNPT 22300014 IF (NCDIN(NSCNPT).NE.NIMPCT(1,18)) NSCNPT=NSCNPT+3 22400014 C IF THE CHARACTER POINTED TO 22500014 C IS P, INDICATING COMPLEX, 22600014 C SET THE CALL INDICATOR. 22700014 IF (NCDIN(NSCNPT).EQ.NIMPCT(1,16)) NPTR(1,23) = 1 22800014 NBEGPT=NSCNPT 22900014 C CALL COMPAT 23000014 CALL IEKCS1 23100014 DO 1010 I=1,4 23200014 1010 IF(NAME(4).EQ.NAMTYP(2,I)) GOTO 1020 23300014 MSGNO=78 23400014 C CALL ERROR 23500014 5000 NERSW = 6 23600014 CALL IEKCDP 23700014 1020 NSCNPT=NSTART+4 23800014 IF(I.NE.2) NSCNPT=NSCNPT+3 23900014 NSTART=NSCNPT 24000014 C CALL GETWD 24100014 CALL IEKCGW 24200014 IF(LENGTH.NE.0) GOTO 1025 24300014 IF(NDELM.EQ.NASTR) GOTO 1105 24400014 GOTO 1030 24500014 1025 NSCNPT=NSTART 24600014 1030 ITPST=ITBL(I) 24700014 C CALL GETWD 24800014 1035 CALL IEKCGW 24900014 IF(LENGTH.EQ.0) GOTO 1039 25000014 C BRANCH TO SET ERROR IF NOT 25020018 C SINGLE CHARACTER. 25040018 IF(LENGTH.NE.1) GO TO 1055 25060018 C SEE IF RANGE OF CHAR TO BE CHGD. 25100014 1040 IF(NDELM.EQ.NMIN) GOTO 1095 25200014 LETND=NCDIN(NBEGPT) 25300014 LETBG=NCDIN(NBEGPT) 25400014 C ONLY ONECHAR TO BE CHGD. 25500014 C LOOK UP CHAR IN IMPCT TABLE 25600014 1045 DO1050 I=1,26 25700014 IF(LETBG.EQ.NIMPCT(1,I)) GOTO 1061 25800018 1050 CONTINUE 25900014 IF (LETBG.EQ.NDOLAR) GO TO 1065 26000014 C CHAR NOT FOUND IN TABLE 26100014 1055 MSGNO=80 26200014 GOTO 5000 26300014 76 MSGNO=76 26330016 GO TO 5000 26360016 85 MSGNO=85 26364018 GOTO 5000 26368018 1061 IF(LETND.EQ.NDOLAR) GOTO 1062 26372018 C 26376018 C IF RANGE OF LETTER SPECIFICATIONS IS NOT IN 26380018 C ASCENDING ALPHABETIC SEQUENCE, BRANCH TO ERROR 26384018 C 26388018 IF(NIMPCT(1,I).GT.LETND) GOTO 85 26392018 C SET NEW MODE SUBSCRIPT FOR BEG-OR26400014 1060 NIMPCT(2,I)=ITPST 26500014 C NEXT CHAR 26600014 IF(NIMPCT(1,I).EQ.LETND) GOTO 1070 26700014 C IF END CHAR, LOOK FOR DELM 26900014 1063 I=I+1 27000018 C ELSE BUMP BY ONE CHAR AND KEEP 27100018 IF(I.GT.26) GOTO 1055 27200018 GOTO 1060 27300014 C 27308018 C IF $ SPECIFIED AS END RANGE OF LETTER SPECIFICATIONS 27316018 C SET ITS MODE AND MODE OF BEGINNING OF RANGE-UPDATE 27324018 C END OF RANGE TO Z-IF Z IS BEGINNING OF RANGE,BRANCH 27332018 C OTHERWISE, CONTINUE PROCESSING REMAINING LETTERS 27340018 C 27348018 1062 NIMPCT(2,I)=ITPST 27356018 NMODET(8)=NMODET(ITPST) 27364018 LETND=NIMPCT(1,26) 27372018 IF(NIMPCT(1,I).EQ.LETND) GOTO 1070 27380018 GOTO 1063 27388018 C 27398018 C ERROR IF $ SPECIFIED AS BEGINNING RANGE OF 27408018 C LETTER SPECIFICATIONS 27418018 C 27428018 1065 IF(NPRVDL.EQ.NMIN.AND.LETBG.NE.LETND) GOTO 85 27438018 NMODET(8)=NMODET(ITPST) 27448018 C IF COMA, GET NEXT FST CHAR 27500014 1070 IF(NDELM.EQ.NCOMA) GOTO 1035 27600014 IF(NDELM.NE.NRTPR) GOTO 1069 27700014 C CALL GETWD 27800014 1075 CALL IEKCGW 27900014 C LOOK FOR NEW GROUP 28000014 IF(LENGTH.NE.0) GOTO 1079 28100014 C END OF STMT, CLOSE + RETURN 28200014 1080 IF (NDELM.NE.NGPMK) GO TO 1090 28300014 C IF THE IMPLICIT STATEMENT 28400014 C IS THE SECOND STATEMENT 28500014 C AND THE PROGRAM IS A 28600014 C FUNCTION OR SUBROUTINE 28700014 C SUBPROGRAM, BRANCH. 28800014 IF(ISN .EQ. 3 .AND. NPTR (1,31) .NE. NPTR (2,31)) GO TO 220 28900014 GO TO 9999 29000014 C START NEW GP AT FST OF ROUTINE 29100014 1090 IF(NDELM.EQ.NCOMA) GOTO 1005 29200014 GO TO 1069 29300014 C SET BEG + END FOR RANGE OF 29400014 1095 LETBG=NCDIN(NBEGPT) 29500014 C CALL GETWD 29600014 CALL IEKCGW 29700014 C CHAR 29800014 IF(LENGTH.EQ.0) GOTO 1099 29900014 1100 LETND=NCDIN(NBEGPT) 30000014 GOTO 1045 30100014 C SET COMPGOTO FOR LENGTH 30200014 C CALL GETWD 30300014 1105 CALL IEKCGW 30400014 C GET LENGTH 30500014 IF(LENGTH.EQ.0) GOTO 1114 30600014 C CONVERT LENGTH 30700014 C CALL LITCON 30800014 1115 CALLIEKCLC 30900014 IF(NNT.NE.1) GOTO 1039 31000014 NNT=0 31100014 IF(I.GE.5) GOTO 1119 31200014 1120 IF(NAME(4).EQ.ITBL(I+5)) I=I+9 31300014 GOTO 1030 31400014 1039 MSGNO = 79 31500014 GOTO 5000 31600014 C WRONG DELM 31700014 1069 MSGNO = 81 31800014 GOTO 5000 31900014 1079 MSGNO = 82 32000014 GOTO 5000 32100014 1099 MSGNO = 83 32200014 GOTO 5000 32300014 1110 MSGNO = 139 32400014 GOTO 5000 32500014 1114 MSGNO = 77 32600014 GOTO 5000 32700014 1119 MSGNO = 84 32800014 GOTO 5000 32900014 999 NPTR(1,8) = 0 33000014 9999 NERSW = 0 33100014 9998 RETURN 33200014 C 33300014 C IMPLICIT STATEMENT MUST BE APPLIED TO33400014 C THE PREVIOUS FUNCTION/SUBROUTINE 33500014 C STATEMENT 33600014 C 33700014 C OBTAIN POINTER TO NORMAL TEXT. 33800014 C 33900014 220 ITXTPT = NPTR (2,28) 34000014 C 34100014 C IF THE ADJECTIVE CODE INDICATES A 34200014 C SUBPROGRAM, BRANCH. 34300014 C 34400014 225 IF(ADJCD (ITXTPT) .EQ. 208) GO TO 240 34500014 C 34600014 C SET POINTER TO NEXT TEXT ENTRY. 34700014 C 34800014 230 ITXTPT = MOD24(TXTCHN(ITXTPT)) 34900014 C 35000014 C BRANCH TO CONTINUE SEARCH. 35100014 C 35200014 GO TO 225 35300014 C 35400014 C FUNCTION/SUBROUTINE ENTRY FOUND. 35500014 C 35600014 C IF THE LAST VARIABLE HAS BEEN 35700014 C PROCESSED, BRANCH. 35800014 C 35900014 240 IF (IEND.EQ.1) GO TO 9999 36000014 C OBTAIN POINTER TO THE NEXT TEXT 36100014 C ENTRY. 36200014 24010 ITXTPT = MOD24(TXTCHN(ITXTPT)) 36300014 C 36400014 C IF THE VARIABLE POINTED TO IS THE 36500014 C LAST VARIABLE ENTERED, SET 36600014 C INDICATOR. 36700014 C 36800014 24020 IF (TPTR(ITXTPT).EQ.IDCTPT) IEND = 1 36900014 C 37000014 C OBTAIN POINTER TO THE DICTIONARY 37100014 C ENTRY FOR THE SUBPROGRAM NAME OR 37200014 C ARGUMENT. 37300014 C 37400014 IVAREN = TPTR (ITXTPT) 37500014 C DO NOT TYPE IMPLICITLY 37520016 C IF ALREADY TYPED EXPLICITLY 37540016 IF(TBIT(BYA(IVAREN),7)) GO TO 240 37560016 C 37600014 C 37700014 C OBTAIN HIGH - ORDER WORD OF THE TWO 37800014 C WORD DICTIONARY NAME FIELD. 37900014 C 38000014 INAME=0 38040016 LNAME(1)=NAMBEG(IVAREN) 38080016 LNAME(2)=BNAM(IVAREN) 38120016 IF(LNAME(1).EQ.0.AND.LNAME(2).EQ.0) INAME=NAM4(IVAREN) 38160016 C 38200014 C IF THIS FIELD IS EQUAL TO ZERO, 38300014 C INDICATING THAT THE VARIABLE HAS A 38400014 C LENGTH OF 4 OR LESS, OBTAIN LOW - 38500014 C ORDER WORD. 38600014 C 38700014 IF(INAME .EQ. 0) INAME = NAM4 (IVAREN) 38800014 C 38900014 C INAME CONTAINS THE FIRST CHARACTER OF39000014 C THE VARIABLE. 39100014 C 39200014 C FOLLOWING SETS LPAD TO THE FIRST 39300014 C CHARACTER OF THE VARIABLE. 39400014 C 39500014 243 LPAD = LNAME (4) 39600014 C 39700014 IF(LNAME (3) .NE. 0) LPAD = LNAME (3) 39800014 C 39900014 IF(LNAME (2) .NE. 0) LPAD = LNAME (2) 40000014 C 40100014 IF(LNAME (1) .NE. 0) LPAD = LNAME (1) 40200014 C 40300014 C LPAD NOW CONTAINS THE 1ST CHARACTER. 40400014 C 40500014 C FOLLOWING DO - LOOP DETERMINES THE 40600014 C FIRST CHARACTER. 40700014 C 40800014 DO 245 I = 1, 26 40900014 C 41000014 IF(LPAD .EQ. NIMPCT (1,I)) GO TO 250 41100014 C 41200014 245 CONTINUE 41300014 C 41400014 C FIRST CHARACTER IS NOT IN IMPLICIT 41500014 C TABLE AND THEREFORE MUST BE A DOLLAR 41600014 C SIGN. 41700014 C 41800014 C SET NEW MODE TO THAT OF A DOLLAR SIGN41900014 C 42000014 NEWMOD = NMODET(8) 42100014 C 42200014 GO TO 255 42300014 C 42400014 C CHARACTER IN IMPLICIT TABLE. 42500014 C 42600014 C OBTAIN SECOND ELEMENT OF THE IMPLICIT42700014 C TABLE FOR THE GIVEN LETTER. THIS IS 42800014 C NOT THE MODE ITSELF BUT THE NUMBER OF42900014 C THAT ENTRY IN THE MODE TABLE WHICH 43000014 C DEFINES THE MODE. 43100014 C 43200014 250 MODSUB = NIMPCT (2,I) 43300014 C 43400014 C SET NEW MODE. 43500014 C 43600014 NEWMOD = NMODET(MODSUB) 43700014 C 43800014 C SET MODE INTO THE DICTIONARY ENTRY 43900014 C FOR THE VARIABLE. 44000014 C 44100014 255 MDD (IVAREN) = NEWMOD 44200014 C 44300014 C SET MODE INTO THE TEXT ENTRY FOR THE 44400014 C VARIABLE. 44500014 C 44600014 TMOD (ITXTPT) = NEWMOD 44700014 C 44800014 GO TO 240 44900014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 45000014 C FUNCTION - XDEFIL CHECKS SYNTAX AND GENERATES TEXT FOR THE C 45100014 C DEFINE FILE STATEMENT. C 45200014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 45300014 C C 45400014 C C 45500014 400 NPTR(1,8) = 15 45600014 IF(SLIMS(1,1)+12.GT.SLIMS(2,1))CALL IEKAGC(1) 45650018 C BRANCH IF NOT FIRST DEFINE FILE 45700014 IF (NPTR(1,26).NE.0) GO TO 4005 45800014 NAME(3) = NX1 45900014 NAME(4) = NX2 46000014 LENGTH = 6 46100014 C ENTER DIOCS= IN DICTIONARY 46200014 C CALL SYMTLU 46300014 CALL IEKCS2 46400014 TYP(IDCTPT) = 4 46500014 BYA(IDCTPT) = 66 46600014 NPTR(1,28) = IDCTPT 46700014 NPTR(1,23) = 1 46750014 NPTR (1,26) = SLIMS (1,1) 46800014 C ENTER UNIT NUMBER (ABSVAL) 46900014 4005 ADJCD (SLIMS (1,1)) = 251 47000014 C CALL GETWD 47100014 CALL IEKCGW 47200014 IF (NACCSV.NE.1) GO TO 4020 47300014 IF (NDELM.NE.NLFPR) GO TO 4030 47400014 C CALL LITCON 47500014 CALL IEKCLC 47600014 IF (NNT.NE.1) GO TO 4020 47700014 TPTR (SLIMS (1,1)) = NACCM 47800014 MTPSET = 1 47900014 C CALL PUTX 48000014 CALL IEKCPX 48100014 C ENTER NO. OF RECORDS AND 48200014 C MAXIMUM RECORD SIZE. 48300014 DO 4010 M = 1,2 48400014 C CALL GETWD 48500014 CALL IEKCGW 48600014 IF(NACCSV .NE. 1) GO TO 4035 48700014 C CALL CSORN 48800014 CALL IEKCCR 48900014 IF (MDD(IDCTPT).NE.5) GO TO 4035 49000014 ADJCD (SLIMS (1,1)) = 9 49100014 C CALL PUTX 49200014 CALL IEKCPX 49300014 IF(NDELM .NE. NCOMA) GO TO 4030 49400014 4010 CONTINUE