C ALGORITHM 605 COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.9, NO. 4, C DEC., 1983, P. 391-394. C*********************************************************************** C C PROGRAM PBASIC VERSION 2.2 SEPTEMBER 1981 C ------- C C AUTHOR T.R.HOPKINS C ------ C C ADDRESS THE COMPUTING LABORATORY, C ------- THE UNIVERSITY OF KENT AT CANTERBURY, C CANTERBURY, CT2 7NF, C KENT, ENGLAND. C C LANGUAGE PFORT - A PORTABLE SUBSET OF ANSI FORTRAN (1966) C -------- C C PURPOSE THIS PROGRAM TAKES AS ITS DATA A BASIC PROGRAM C ------- AND CHECKS IT FOR CONFORMANCE TO THE ANSI C MINIMAL BASIC STANDARD (ANSI X3.60-1978). C C THE PROGRAM CHECKS THAT C 1) EACH LINE ADHERES STRICTLY TO THE DEFINED SYNTAX C 2) THE BASIC PROGRAM CONTAINS NONE OF THE CONTEXT C SENSITIVE OR CONTEXT FREE ERRORS LISTED IN VOL. 1 C OF THE NBS MINIMAL BASIC TEST PROGRAMS - VERSION C 2, USERS MANUAL. C C THE OUTPUT PRODUCED CONSISTS OF C 1) A LISTING OF THE BASIC PROGRAM AS PRESENTED PLUS C ANY WARNINGS OR ERRORS MESSAGES C 2) CROSS REFERENCE TABLES C A) BY VARIABLE / FUNCTION NAME C B) BY STATEMENT TYPE C C) BY LINE NUMBERS USED AS TRANSFERS. C C RUNNING THE PROGRAM C ------------------- C THE PROGRAM EXPECTS THE BASIC PROGRAM TO BE CHECKED C TO BE ON CHANNEL NIN (DEFAULT = 5) C THE DATA MUST BE TERMINATED BY A RECORD CONTAINING C A FULL STOP IN CHARACTER POSITION 1. THIS C RESTRICTION MAY BE REMOVED BY CHANGING THE ROUTINE C INSTAT IN A NON-STANDARD WAY. C C THE BASIC PROGRAM LISTING + ERROR MESSAGES ARE OUTPUT C ON CHANNEL NOUT (DEFAULT = 6) C C THE CROSS REFERENCE TABLES ARE OUTPUT ON CHANNEL NTAB C (DEFAULT = 8) C C EFFICIENCY THE SPEED OF EXECUTION MAY BE IMPROVED CONSIDERABLY C ---------- BY PROVIDING A MACHINE DEPENDENT VERSION OF THE C INTEGER FUNCTION CODECH. THIS IS USED TO MAP THE C CHARACTERS OF THE BASIC PROGRAM INTO AN INTERNAL C CODE. TO EENSURE PORTABILITY THE PROVIDED ROUTINE C IMPLEMENTS A STRAIGHTFORWARD LINEAR SEARCH. C C PORTABILITY THE PROGRAM HAS BEEN SUCCESSFULLY RUN WITH A C ----------- MINIMAL NUMBER OF CHANGES (SEE ACCOMPANYING C DOCUMENTATION) ON C C (1) ICL 2960 UNDER EMAS - FORTE COMPILER C (2) CDC 7600 UNDER SCOPE 3.2 - FTN4 COMPILER C C*********************************************************************** C..LOCAL VARIABLES INTEGER CLASS, I, K1 LOGICAL WRERR C..FUNCTIONS INTEGER CODE LOGICAL EATSP C..COMMON BLOCKS C****CARFUN C ARSTAK - COL 1 HOLDS CODE OF ARRAY /FUNCTION (-1 IF NON-ANSI) C COL 2 HOLDS LEVEL OF PARENTHESIS AT WHICH ARRAY/FUNCTION O C COL 3 HOLDS NUMBER OF DIMENSIONS/ARGUMENTS C NEXT1 - NEXT AVAILABLE ROW IN ARSTAK C LPOPEN - CURRENT DEPTH OF OPEN (LEFT) PARENTHESES C DLPREQ - DEPTH OF OPEN (LEFT) PARENTHESES OF CURRENT ARRAY/FUNCTION C C ARPOS ROW OF ARSTAK AT PRESENT OPEN C C INTEGER ARPOS, ARSTAK, DLPREQ, LARST, LPOPEN, NEXT1 COMMON /CARFUN/ LARST, ARSTAK(40,3), NEXT1, LPOPEN, * DLPREQ, ARPOS C C****CCHAIN C LCHAIN - DECLARED LENGTH OF ARRAY CHAINS C NCHAIN - POINTER TO NEXT AVAILABLE LINK IN CHAIN C CHAIN - ARRAY OF REFERENCES TO VARIABLES AND STATEMENT NUMBERS C INTEGER LCHAIN, NCHAIN, CHAIN COMMON /CCHAIN/ LCHAIN, NCHAIN, CHAIN(5000) C C****CDO C LDO - MAXIMUM NUMBER OF OPEN FOR STATEMENTS ALLOWED C DOPEN - NUMBER OF CURRENTLY OPEN FOR STATEMENTS C DOSPEC - ARRAY HOLDING CONTROL VARIABLES OF OPEN FOR-LOOPS C IN CODE FORM C INTEGER LDO, DOPEN, DOSPEC COMMON /CDO/ LDO, DOPEN, DOSPEC(30) C C****CERROR C NUMST - NUMBER OF STATEMENTS PROCESSED C NUMERR - NUMBER OF ERROR MESSAGES PRINTED C ENDERR - BOOLEAN SET TRUE IF BASIC END STATEMENT FOUND ELSE FALSE C LABENO - CURRENT STATEMENT NUMBER C LABERR - BOOLEAN SET TRUE IF PROGRAM STATEMENT NUMBER ARE NOT IN C ORDER, FALSE OTHERWISE C INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR C C****CEXPR C TCODE - SEE COMMENTS IN SUBROUTINE EXPRES C TYPE - SEE COMMENTS IN SUBROUTINE EXPRES C ERR - TRUE IF SPACES INSIDE TOKEN, FALSE OTHERWISE C VCODE - VARIABLE CODE IF LEGAL VARIABLE, ZERO OTHERWISE C SIMPST - TRUE IF SIMPLE STRING FOUND FALSE OTHERWISE C ENDEXP - POSITION IN LINE OF END OF EXPRESSION C LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST C C****CFOR1 C LFOR - DECLARED LENGTH OF ARRAY FORNXT C NFOR - POSITION OF LAST ENTRIES IN FORNXT C FORNXT - ARRAY HOLDING STATEMENT NUMBERS OF FORS AND MATCHING NEXTS C LJUMP - DECLARED LENGTH OF ARRAY JUMPS C NJUMP - POSITION OF LAST ENTRIES IN JUMPS C JUMPS - ARRAY HOLDING STATEMENT NUMBERS AND DESTINATIONS OF C FORWARD TRANSFERS C ABNFOR - LOGICAL IF SET TRUE THEN CHECKING OF TRANSFER INTO FOR C BLOCKS IS ABANDONED - SET TRUE IF ILLEGAL NESTING OCCURS C LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR C C****CIO C NIN - INPUT CHANNEL FOR BASIC PROGRAM C NOUT - OUTPUT CHANNEL FOR VERIFIED PROGRAM AND ERROR MESSAGES C NTAB - OUTPUT CHANNEL FOR CROSS REFERENCE TABLES ETC. C ENDIN - BOOLEAN SET TRUE WHEN END OF INPUT FILE FOUND C INTEGER NIN, NOUT, NTAB LOGICAL ENDIN COMMON /CIO/ NIN, NOUT, NTAB, ENDIN C C****CKREF C LKEY - FIRST DIMENSION OF THE ARRAY KEYREF C KEYREF - ARRAY HOLDING POINTERS TO ARRAY CHAIN C Z - ARRAY OF STATEMENT NAMES FOR OUTPUT C INTEGER KEYREF, LKEY, Z COMMON /CKREF/ LKEY, KEYREF(21,2), Z(114) C C****CLINE C LLINE - DECLARED LENGTH OF ARRAY LINE SPECIFIES MAXIMUM LENGTH OF C EACH BASIC STATEMENT (DEPENDS ON THE BASIC IMPLEMENTATION) C NLINE - POSITION OF LAST NON-BLANK CHARACTER OF CURRENT LINE C MAXLIN - MAXIMUM LEGAL LENGTH OF A BASIC STATEMENT C (72 FOR ANSI) C LINE - ARRAY HOLDING CODED BASIC STATEMENT C INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) C C****CNXTCH C K3 - POSITION OF NEXT NON-BLANK IN LINE C ICODE - CODE OF NEXT NON-BLANK IN LINE C C NOTE: K3 IS SET -1 IF END OF LINE IS ENCOUNTERED C THESE VARIABLES ARE SET BY NEXTOK C INTEGER K3, JCODE COMMON /CNXTCH/ K3, JCODE C C****COPT C DIMYET - LOGICAL TRUE IF DIM STATEMENT HAS BEEN ENCOUNTERED C OPTYET - LOGICAL TRUE IF OPTION STATEMENT HAS BEEN ENCOUNTERED C OPTSET - CONTAINS SETTING OF FIRST OPTION STATEMENT ZERO OR ONE C LOGICAL DIMYET, OPTYET INTEGER OPTSET COMMON /COPT/ DIMYET, OPTYET, OPTSET C C****CREFER C NREF - NUMBER OF REFERENCES SAVED IN ARRAY REF C REF - ARRAY USED TO STORE REFERENCES TO BE ADDED C TO ARRAY CHAIN C INTEGER NREF, REF COMMON /CREFER/ NREF, REF(40) C C****CSARG C ARRDIM - ARRAY HOLDING SIZE OF ARRAYS DEFINED IN DIM STATEMENT C (IF MORE THAN TWO - FIRST TWO ONLY ARE KEPT) C ARRSUB - ARRAY HOLDING NUMBER OF SUBSCRIPTS OF EACH ARRAY C (POSITIVE IF VIA DIM STATEMENT, NEGATIVE IF BY REFERENCE) C ISFUN - ARRAY HOLDING CODED FORM OF STANDARD FUNCTIONS C FARG - ARRAY HOLDING NUMBER OF ARGUMENTS OF USER DEFINED FUNCTIONS C (-N-1 IF NOT FROM DEF, N IF FROM DEF, INITIALIZED -999) C INTEGER ARRDIM, ARRSUB, ISFUN, FARG COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) C C****CSTAT C LSTAT - DECLARED LENGTH OF ARRAYS STATNO AND STAREF C NSTAT - POSITION OF LAST ENTRIES IN STATNO AND STAREF C BNSTAT - NUMBER OF FORWARD REFERENCES C STATNO - ARRAY HOLDING STATEMENT NUMBERS C STAREF - ARRAY HOLDING POINTERS TO REFERENCE IN CHAIN C INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), * STAREF(500,2) C C****CTOKEN C LTOK - DECLARED LENGTH OF ARRAY TOKEN C NTOK - LENGTH OF CURRENT TOKEN C TOKEN - ARRAY HOLDING CURRENT TOKEN C INTEGER NTOK, LTOK, TOKEN COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) C C****CTREE C KALP - ARRAY HOLDING CODED BASIC KEYWORDS IN TREE FORM C KSUC - ARRAY HOLDING SUCCESSFUL MATCH LINKS C KFAL - ARRAY HOLDING FAILURE LINKS C INTEGER KALP, KFAL, KSUC COMMON /CTREE/ KALP(72), KSUC(72), KFAL(72) C C****CVAR C LVAR - TOTAL NUMBER OF VARIABLE REFERENCES, DECLARED LENGTH C OF IVAR C IVAR - ARRAY FOR POINTERS TO REFERENCE IN ARRAY CHAIN EACH C VARIABLE IS ACCESSED BY CODE NUMBER C INTEGER LVAR, IVAR COMMON /CVAR/ LVAR, IVAR(376,2) C C INITIALIZATION OF COMMON BLOCK VARIABLES C C C**BLOCK CARFUN C LARST = 40 DLPREQ = -1 ARPOS = 0 C C**BLOCK CCHAIN C LCHAIN = 5000 NCHAIN = 1 C C**BLOCK CDO C LDO = 30 DOPEN = 0 C C**BLOCK CERROR C NUMST = 0 NUMERR = 0 ENDERR = .FALSE. LABENO = 0 LABERR = .FALSE. C C**BLOCK CFOR1 C LFOR = 50 NFOR = 0 C INITIALIZE SECOND COLUMN OF FORNXT TO ZERO SO CAN TELL C WHETHER NEXT STATEMENT HAS BEEN FOUND DO 10 I=1,LFOR FORNXT(I,2) = 0 10 CONTINUE LJUMP = 500 NJUMP = 0 ABNFOR = .FALSE. C C**BLOCK CIO C NIN = 5 NOUT = 6 NTAB = 8 C C REWIND ALL I/O FILES C REWIND NIN REWIND NOUT REWIND NTAB ENDIN = .FALSE. C C**BLOCK CKREF C LKEY = 21 C MARK FIRST COLUMN OF KEYREF DO 20 I=1,LKEY KEYREF(I,1) = 0 20 CONTINUE C C**BLOCK CLINE C LLINE = 80 MAXLIN = 72 C C**BLOCK COPT C DIMYET = .FALSE. OPTYET = .FALSE. OPTSET = -1 C C**BLOCK CSARG C C INITIALIZE NUMBER OF ARRAY SUBSCRIPTS TO ZERO C MARK FIRST COLUMN OF ARRAY DIMENSIONS C MARK FARG ARRAY DO 30 I=1,26 ARRSUB(I) = 0 ARRDIM(I,1) = -1 FARG(I) = -999 30 CONTINUE C C**BLOCK CSTAT C LSTAT = 500 NSTAT = 0 BNSTAT = -1 C ZERO FIRST COLUMN OF STAREF DO 40 I=1,LSTAT STAREF(I,1) = 0 40 CONTINUE C C**BLOCK CTOKEN C LTOK = 72 C C**BLOCK CVAR C LVAR = 376 C ZERO FIRST COLUMN OF IVAR DO 50 I=1,LVAR IVAR(I,1) = 0 50 CONTINUE C C**LOCALS C WRERR = .FALSE. C READ IN A STATEMENT 60 CALL INSTAT C TEST FOR END OF INPUT - OUTPUT X-REF TABLES ETC. IF (ENDIN) GO TO 290 C CHECK THAT THE STATEMENT NUMBER CONFORMS TO THE STANDARD CALL CHKLAB C CHECK STATEMENT NUMBERS ARE IN ASCENDING ORDER IF (.NOT.LABERR) GO TO 70 CALL ERROR(19H****FATAL ERROR****, 19) CALL * ERROR( * 52HSTATEMENT NUMBERS NOT ORDERED - PROCESSING ABANDONED, * 52) GO TO 300 C TEST IF LABENO=-1 I.E. MISSING STATEMENT NUMBER 70 IF (-1.NE.LABENO) GO TO 80 CALL ERROR(42HSTATEMENT NUMBER MISSING STATEMENT IGNORED, * 42) GO TO 60 C TEST IF STATEMENT NUMBER ZERO 80 IF (0.NE.LABENO) GO TO 90 CALL ERROR(39HSTATEMENT NUMBER ZERO STATEMENT IGNORED, 39) GO TO 60 C TEST IF THERE IS ONLY A STATEMENT NUMBER ON THE LINE 90 IF (-1.NE.K3) GO TO 100 CALL ERROR(28HSTATEMENT LABEL ONLY ON LINE, 28) C GET NEXT KEY WORD GO TO 60 C CLASSIFY KEY WORD 100 CALL CLASFY(CLASS, ERR) CALL ADDREF(KEYREF, LKEY, LABENO, CLASS) IF (CLASS.LT.21) GO TO 110 CALL * ERROR(46HNON-STANDARD KEYWORD REST OF STATEMENT IGNORED, * 46) GO TO 60 C CHECK NO SPACES IN KEYWORD 110 IF (ERR) CALL ERROR(17HSPACES IN KEYWORD, 17) IF (.NOT.ENDERR .OR. WRERR) GO TO 120 WRERR = .TRUE. CALL ERROR(31HSTATEMENT FOLLOWS END STATEMENT, 31) C UNLESS KEYWORD CAN OCCUR ALONE ON THE LINE (END,STOP,RESTORE, C RANDOMIZE,PRINT,REM) CHECK AT LEAST ONE SPACE FOLLOWS. 120 IF (CLASS.EQ.4 .OR. CLASS.EQ.14 .OR. CLASS.EQ.15 .OR. * (CLASS.GE.17 .AND. CLASS.LE.20)) GO TO 140 K1 = K3 + 1 ERR = EATSP(K1,K3) IF (-1.NE.K3) GO TO 130 C AT END OF LINE OF OUTPUT ERROR AND GET NEXT LINE CALL ERROR(27HKEYWORD CANNOT APPEAR ALONE, 27) GO TO 60 130 IF (.NOT.ERR) CALL ERROR(24HNO SPACE FOLLOWS KEYWORD, 24) JCODE = CODE(K3) C C CHECK EACH PARTICULAR STATEMENT ADHERES TO ANSI-STANDARD C C 1. DATA 2. DEF 3. DIM 4. END C 5. FOR 6. GOSUB 7. GOTO 8. IF C 9. INPUT 10. LET 11. NEXT 12. ON C 13. OPTION 14. PRINT 15. RANDOMIZE 16. READ C 17. REM 18. RESTORE 19. RETURN 20. STOP C C 21. NON-ANSI KEYWORD C 140 GO TO (150, 160, 170, 180, 190, 200, 200, 210, 220, 230, * 240, 250, 260, 270, 180, 220, 280, 180, 180, 180), CLASS C DATA STATEMENT 150 CALL DATA GO TO 60 C DEF STATEMENT 160 CALL DEF GO TO 60 C DIM STATEMENT 170 CALL DIM GO TO 60 C END,RANDOMIZE,RESTORE,RETURN, OR STOP STATEMENT 180 CALL RSTEND(CLASS) GO TO 60 C FOR STATEMENT 190 CALL FORST GO TO 60 C GOTO OR GOSUB STATEMENT 200 CALL GOTOS GO TO 60 C IF STATEMENT 210 CALL IFST GO TO 60 C INPUT OR READ STATEMENT 220 CALL INREAD GO TO 60 C LET STATEMENT 230 CALL LETST GO TO 60 C NEXT STATEMENT 240 CALL NEXT GO TO 60 C ON STATEMENT 250 CALL ONSTAT GO TO 60 C OPTION BASE STATEMENT 260 CALL OPTSMT GO TO 60 C PRINT STATEMENT 270 CALL PRINT GO TO 60 C REM STATEMENT 280 CALL REM GO TO 60 C END OF FILE FOUND - TIDY UP, OUTPUT X-REF TABLES C FOR VARIABLES AND STATEMENT NUMBERS 290 CALL TIDYUP CALL XRSTNO CALL XRVARS CALL XRSTAT 300 STOP END C*** C BLOCK DATA ROUTINES C*** BLOCK DATA C C INITIALIZE STATEMENT NAMES IN ARRAY Z C THIS IS USED FOR OUTPUT OF TABLES C C..COMMON BLOCKS INTEGER KEYREF, LKEY, Z COMMON /CKREF/ LKEY, KEYREF(21,2), Z(114) DATA LKEY /21/ DATA Z(1) /4/ DATA Z(2) /1HD/ DATA Z(3) /1HA/ DATA Z(4) /1HT/ DATA Z(5) /1HA/ DATA Z(6) /3/ DATA Z(7) /1HD/ DATA Z(8) /1HE/ DATA Z(9) /1HF/ DATA Z(10) /3/ DATA Z(11) /1HD/ DATA Z(12) /1HI/ DATA Z(13) /1HM/ DATA Z(14) /3/ DATA Z(15) /1HE/ DATA Z(16) /1HN/ DATA Z(17) /1HD/ DATA Z(18) /3/ DATA Z(19) /1HF/ DATA Z(20) /1HO/ DATA Z(21) /1HR/ DATA Z(22) /5/ DATA Z(23) /1HG/ DATA Z(24) /1HO/ DATA Z(25) /1HS/ DATA Z(26) /1HU/ DATA Z(27) /1HB/ DATA Z(28) /4/ DATA Z(29) /1HG/ DATA Z(30) /1HO/ DATA Z(31) /1HT/ DATA Z(32) /1HO/ DATA Z(33) /2/ DATA Z(34) /1HI/ DATA Z(35) /1HF/ DATA Z(36) /5/ DATA Z(37) /1HI/ DATA Z(38) /1HN/ DATA Z(39) /1HP/ DATA Z(40) /1HU/ DATA Z(41) /1HT/ DATA Z(42) /3/ DATA Z(43) /1HL/ DATA Z(44) /1HE/ DATA Z(45) /1HT/ DATA Z(46) /4/ DATA Z(47) /1HN/ DATA Z(48) /1HE/ DATA Z(49) /1HX/ DATA Z(50) /1HT/ DATA Z(51) /2/ DATA Z(52) /1HO/ DATA Z(53) /1HN/ DATA Z(54) /6/ DATA Z(55) /1HO/ DATA Z(56) /1HP/ DATA Z(57) /1HT/ DATA Z(58) /1HI/ DATA Z(59) /1HO/ DATA Z(60) /1HN/ DATA Z(61) /5/ DATA Z(62) /1HP/ DATA Z(63) /1HR/ DATA Z(64) /1HI/ DATA Z(65) /1HN/ DATA Z(66) /1HT/ DATA Z(67) /9/ DATA Z(68) /1HR/ DATA Z(69) /1HA/ DATA Z(70) /1HN/ DATA Z(71) /1HD/ DATA Z(72) /1HO/ DATA Z(73) /1HM/ DATA Z(74) /1HI/ DATA Z(75) /1HZ/ DATA Z(76) /1HE/ DATA Z(77) /4/ DATA Z(78) /1HR/ DATA Z(79) /1HE/ DATA Z(80) /1HA/ DATA Z(81) /1HD/ DATA Z(82) /3/ DATA Z(83) /1HR/ DATA Z(84) /1HE/ DATA Z(85) /1HM/ DATA Z(86) /7/ DATA Z(87) /1HR/ DATA Z(88) /1HE/ DATA Z(89) /1HS/ DATA Z(90) /1HT/ DATA Z(91) /1HO/ DATA Z(92) /1HR/ DATA Z(93) /1HE/ DATA Z(94) /6/ DATA Z(95) /1HR/ DATA Z(96) /1HE/ DATA Z(97) /1HT/ DATA Z(98) /1HU/ DATA Z(99) /1HR/ DATA Z(100) /1HN/ DATA Z(101) /4/ DATA Z(102) /1HS/ DATA Z(103) /1HT/ DATA Z(104) /1HO/ DATA Z(105) /1HP/ DATA Z(106) /8/ DATA Z(107) /1HN/ DATA Z(108) /1HO/ DATA Z(109) /1HN/ DATA Z(110) /1H-/ DATA Z(111) /1HA/ DATA Z(112) /1HN/ DATA Z(113) /1HS/ DATA Z(114) /1HI/ END BLOCK DATA C C INITIALIZE TREE FOR IDENTIFICATION OF BASIC STATEMENTS C C..COMMON BLOCKS INTEGER KALP, KFAL, KSUC COMMON /CTREE/ KALP(72), KSUC(72), KFAL(72) DATA KALP(1), KALP(2), KALP(3), KALP(4), KALP(5), * KALP(6), KALP(7), KALP(8), KALP(9), KALP(10), KALP(11), * KALP(12), KALP(13), KALP(14), KALP(15), KALP(16), * KALP(17), KALP(18), KALP(19), KALP(20), KALP(21), * KALP(22), KALP(23), KALP(24), KALP(25), KALP(26), * KALP(27), KALP(28), KALP(29), KALP(30), KALP(31), * KALP(32), KALP(33), KALP(34), KALP(35), KALP(36), * KALP(37), KALP(38), KALP(39), KALP(40), KALP(41), * KALP(42), KALP(43), KALP(44), KALP(45), KALP(46), * KALP(47), KALP(48), KALP(49), KALP(50), KALP(51), * KALP(52), KALP(53), KALP(54), KALP(55), KALP(56), * KALP(57), KALP(58), KALP(59), KALP(60), KALP(61), * KALP(62), KALP(63), KALP(64) /21,14,29,18,15,23,25,30,29, * 15,24,27,16,24,27,14,22,10,13,29,30,27,23,28,29,24,27,14, * 10,23,13,24,22,18,35,14,25,27,18,23,29,23,14,33,29,13,10, * 29,10,14,15,18,22,14,23,13,28,29,24,25,24,23,25,29/ DATA KALP(65), KALP(66), KALP(67), KALP(68), KALP(69), * KALP(70), KALP(71), KALP(72) /18,24,23,28,30,11,29,24/ DATA KSUC(1), KSUC(2), KSUC(3), KSUC(4), KSUC(5), * KSUC(6), KSUC(7), KSUC(8), KSUC(9), KSUC(10), KSUC(11), * KSUC(12), KSUC(13), KSUC(14), KSUC(15), KSUC(16), * KSUC(17), KSUC(18), KSUC(19), KSUC(20), KSUC(21), * KSUC(22), KSUC(23), KSUC(24), KSUC(25), KSUC(26), * KSUC(27), KSUC(28), KSUC(29), KSUC(30), KSUC(31), * KSUC(32), KSUC(33), KSUC(34), KSUC(35), KSUC(36), * KSUC(37), KSUC(38), KSUC(39), KSUC(40), KSUC(41), * KSUC(42), KSUC(43), KSUC(44), KSUC(45), KSUC(46), * KSUC(47), KSUC(48), KSUC(49), KSUC(50), KSUC(51), * KSUC(52), KSUC(53), KSUC(54), KSUC(55), KSUC(56), * KSUC(57), KSUC(58), KSUC(59), KSUC(60), KSUC(61), * KSUC(62) /2,3,-10,5,-8,7,8,9,-9,11,12,-5,14,-21,16,17, * -17,19,-16,21,22,23,-19,25,26,27,28,-18,30,31,32,33,34, * 35,36,-15,38,39,40,41,-14,43,44,45,-11,47,48,49,-1,51,-2, * 53,-3,55,56,-4,58,59,60,-20,62,-12/ DATA KSUC(63), KSUC(64), KSUC(65), KSUC(66), KSUC(67), * KSUC(68), KSUC(69), KSUC(70), KSUC(71), KSUC(72) * /64,65,66,67,-13,69,70,-6,72,-7/ DATA KFAL(1), KFAL(2), KFAL(3), KFAL(4), KFAL(5), * KFAL(6), KFAL(7), KFAL(8), KFAL(9), KFAL(10), KFAL(11), * KFAL(12), KFAL(13), KFAL(14), KFAL(15), KFAL(16), * KFAL(17), KFAL(18), KFAL(19), KFAL(20), KFAL(21), * KFAL(22), KFAL(23), KFAL(24), KFAL(25), KFAL(26), * KFAL(27), KFAL(28), KFAL(29), KFAL(30), KFAL(31), * KFAL(32), KFAL(33), KFAL(34), KFAL(35), KFAL(36), * KFAL(37), KFAL(38), KFAL(39), KFAL(40), KFAL(41), * KFAL(42), KFAL(43), KFAL(44), KFAL(45), KFAL(46), * KFAL(47), KFAL(48), KFAL(49), KFAL(50), KFAL(51), * KFAL(52), KFAL(53), KFAL(54), KFAL(55), KFAL(56), * KFAL(57), KFAL(58), KFAL(59), KFAL(60), KFAL(61), * KFAL(62), KFAL(63), KFAL(64), KFAL(65), KFAL(66), * KFAL(67), KFAL(68), KFAL(69), KFAL(70), KFAL(71), * KFAL(72) /4,-21,-21,10,6,4*-21,13,2*-21,15,-21,37,29,18, * 20,-21,24,16*-21,42,4*-21,46,3*-21,54,50,2*-21,52,3*-21, * 57,2*-21,61,4*-21,63,5*-21,71,4*-21/ END BLOCK DATA C C INITIALIZE IMPLEMENTATION SUPPLIED FUNCTIONS IN ARRAY ISFUN(11,3) C C..COMMON BLOCKS INTEGER ARRDIM, ARRSUB, FARG, ISFUN COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) C ORDER ABS,ATN,COS,EXP,INT,LOG,RND,SGN,SIN,SQR,TAN DATA ISFUN(1,1), ISFUN(1,2), ISFUN(1,3) /10,11,28/ DATA ISFUN(2,1), ISFUN(2,2), ISFUN(2,3) /10,29,23/ DATA ISFUN(3,1), ISFUN(3,2), ISFUN(3,3) /12,24,28/ DATA ISFUN(4,1), ISFUN(4,2), ISFUN(4,3) /14,33,25/ DATA ISFUN(5,1), ISFUN(5,2), ISFUN(5,3) /18,23,29/ DATA ISFUN(6,1), ISFUN(6,2), ISFUN(6,3) /21,24,16/ DATA ISFUN(7,1), ISFUN(7,2), ISFUN(7,3) /27,23,13/ DATA ISFUN(8,1), ISFUN(8,2), ISFUN(8,3) /28,16,23/ DATA ISFUN(9,1), ISFUN(9,2), ISFUN(9,3) /28,18,23/ DATA ISFUN(10,1), ISFUN(10,2), ISFUN(10,3) /28,26,27/ DATA ISFUN(11,1), ISFUN(11,2), ISFUN(11,3) /29,10,23/ END C*** C SUBROUTINE ADDREF C*** SUBROUTINE ADDREF(ARRAY, LARRAY, REF, IPOS) C C ROUTINE TO ADD REFERENCE OF EITHER VARIABLE (ARRAY=IVAR) C OR STATEMENT (ARRAY=STATREF) TO THE ARRAY CHAIN. C C LARRAY IS THE LENGTH OF THE ARRAY (LVAR OR LSTAT) C REF IS THE INTEGER FORM OF THE STATEMENT NUMBER C IPOS IS THE POSITION OF THE VARIABLE/STATEMENT IN THE C ARRAY IVAR OR STATREF. C C..NOTE - THE ACTUAL ARGUMENT USED IN CALLS TO THIS ROUTINE MAY C BE CONTAINED WITHIN COMMON BLOCKS IN THE CALLING SUB- C PROGRAM - THIS IS FLAGGED AS AN UNSAFE REFERENCE BY C PFORT BUT IS ACTUALLY SAFE SINCE NONE OF THE ARGUMENTS C ARE CHANGED. C C..ARGUMENTS INTEGER IPOS, LARRAY, REF INTEGER ARRAY(LARRAY,2) C..LOCAL VARIABLES INTEGER I C..COMMON BLOCKS INTEGER LCHAIN, NCHAIN, CHAIN COMMON /CCHAIN/ LCHAIN, NCHAIN, CHAIN(5000) C TEST IF ENOUGH ROOM IN CHAIN TO ADD IN REFERENCE IF (NCHAIN.GT.LCHAIN) CALL SYSERR(2) C TEST IF THIS IS THE FIRST REFERENCE IF (ARRAY(IPOS,1).NE.0) GO TO 10 C ENTER FIRST LINK ARRAY(IPOS,1) = NCHAIN GO TO 20 C OTHERWISE UPDATE LINK IN CHAIN 10 I = ARRAY(IPOS,2) + 1 CHAIN(I) = NCHAIN C UPDATE LAST REFERENCE AND ADD NEW REFERENCE INTO CHAIN 20 ARRAY(IPOS,2) = NCHAIN CHAIN(NCHAIN) = REF NCHAIN = NCHAIN + 2 RETURN END C*** C SUBROUTINE ADDSTA C*** SUBROUTINE ADDSTA(REF) C C ADDS STATEMENT REFERENCE TO CHAIN - LABENO IS CURRENT STATEMENT NO. C REF IS THE REFERENCED STATEMENT NUMBER C STATNO ELEMENTS ARE NEGATIVE IF STATEMENT IS A REM C C..ARGUMENTS INTEGER REF C..LOCAL VARIABLES INTEGER I, IPOS, IREF, JPOS C..FUNCTIONS LOGICAL BINCHP C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), * STAREF(500,2) C TEST IF FORWARD REFERENCE FOUND IF (REF.GT.IABS(STATNO(NSTAT))) GO TO 10 C REFERENCE SHOULD ALREADY EXIST - BINARY CHOP IF (BINCHP(STATNO,1,NSTAT,REF,IPOS)) GO TO 60 CALL * ERROR(44HBACK REFERENCE TO UNDEFINED STATEMENT NUMBER, * 44) GO TO 70 C FORWARD REFERENCE FOUND 10 IF (-1.NE.BNSTAT) GO TO 20 C NO FORWARD REFERENCES ALREADY EXISTING IF (NSTAT.EQ.LSTAT) CALL SYSERR(1) BNSTAT = 0 IPOS = LSTAT GO TO 50 C CHECK FORWARD REFERENCE DOES NOT ALREADY EXIST 20 IF (BINCHP(STATNO,LSTAT-BNSTAT,LSTAT,REF,IPOS)) GO TO 60 C PUT REFERENCE INTO POSITION REORDERING IF NECESSARY IF (NSTAT.EQ.LSTAT-BNSTAT-1) CALL SYSERR(1) BNSTAT = BNSTAT + 1 IPOS = LSTAT - BNSTAT DO 30 I=1,BNSTAT IPOS = IPOS + 1 IF (REF.LT.IABS(STATNO(IPOS))) GO TO 40 JPOS = IPOS - 1 C SHIFT UP STATEMENTS AND POINTERS STATNO(JPOS) = STATNO(IPOS) STAREF(JPOS,1) = STAREF(IPOS,1) STAREF(JPOS,2) = STAREF(IPOS,2) 30 CONTINUE C PUT STATEMENT NUMBER IN END POSITION IPOS = LSTAT GO TO 50 C OTHERWISE INSERT AHEAD OF LAST POSITION 40 IPOS = IPOS - 1 50 STATNO(IPOS) = REF STAREF(IPOS,1) = 0 C ADD CURRENT STATEMENT NUMBER TO REFERENCE CHAIN 60 IREF = LABENO CALL ADDREF(STAREF, LSTAT, IREF, IPOS) 70 RETURN END C*** C SUBROUTINE ARWIND C*** SUBROUTINE ARWIND(WINDUP) C C ROUTINE FOR KEEPING TRACK ON NUMBER OF DIMENSIONS/VARIABLES C IN ARRAYS/FUNCTIONS C C ON ENTRY C WINDUP=.FALSE. MEANS LEFT PARENTHESIS FOUND OPEN UP NEW TOKEN C WINDUP=.TRUE. MATCHING RIGHT PAREN FOUND CLOSE DOWN CURRENTLY C OPEN TOKEN AND SEARCH FOR ANY OUTER NESTED ONES C C..ARGUMENTS LOGICAL WINDUP C..LOCAL VARIABLES INTEGER I, ICODE, J C..COMMON BLOCKS INTEGER ARPOS, ARSTAK, DLPREQ, LARST, LPOPEN, NEXT1 LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP COMMON /CARFUN/ LARST, ARSTAK(40,3), NEXT1, LPOPEN, * DLPREQ, ARPOS COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST IF (WINDUP) GO TO 10 IF (NEXT1.GT.LARST) CALL SYSERR(7) C ADD NEW FUNCTION / ARRAY TO ARSTAK ICODE = VCODE IF (VCODE.EQ.0) ICODE = -1 ARSTAK(NEXT1,1) = ICODE ARSTAK(NEXT1,2) = LPOPEN ARSTAK(NEXT1,3) = 1 ARPOS = NEXT1 NEXT1 = NEXT1 + 1 DLPREQ = LPOPEN GO TO 50 C WHEN RELEVANT CLOSING BRACKET FOUND I.E. LPOPEN=DLPREQ-1 C CLOSE THE ROW AT PRESENT OPEN C FIRST CHECK SUBSCRIPTS / ARGUMENTS 10 IF (NEXT1.EQ.1) GO TO 50 IF (ARSTAK(ARPOS,1).GT.0) CALL CHKSUB(ARSTAK(ARPOS,1), * ARSTAK(ARPOS,3)) ARSTAK(ARPOS,2) = 0 C LOOK IF ANY OTHERS OPEN - SEARCH BACKWARDS FROM ARPOS IF (ARPOS.EQ.1) GO TO 30 DO 20 I=2,ARPOS J = ARPOS + 1 - I IF (ARSTAK(J,2).GT.0) GO TO 40 20 CONTINUE C NOT FOUND SET DLPREQ TO -1 AND RETURN 30 DLPREQ = -1 ARPOS = 0 GO TO 50 C OTHERWISE SET NEXT OPEN ONE 40 ARPOS = J DLPREQ = ARSTAK(ARPOS,2) 50 RETURN END C*** C LOGICAL FUNCTION BINCHP C*** LOGICAL FUNCTION BINCHP(ARRAY, START, FIN, TARGET, IPOS) C C BINARY CHOP SORTED SEGMENT OF ARRAY (START - FIN) C LOOKING FOR INTEGER TARGET. C IF FOUND SET IPOS TO POSITION AND BINCHP TO TRUE C IF NOT SET IPOS TO ZERO AND BINCHP TO FALSE C C CHECK FIRST THAT TARGET IS S.T. C ARRAY(START) .LT. TARGET .LT. ARRAY(FIN) C C..ARGUMENTS INTEGER FIN, START, TARGET INTEGER ARRAY(FIN) C..LOCAL VARIABLES INTEGER IPOS, JPOS, KPOS, LPOS IF (IABS(ARRAY(START)).LE.TARGET .AND. * TARGET.LE.IABS(ARRAY(FIN))) GO TO 10 C TARGET IS NOT IN THE SORTED LIST BINCHP = .FALSE. IPOS = 0 GO TO 60 10 BINCHP = .TRUE. JPOS = START KPOS = 2*FIN - START IPOS = 0 20 LPOS = (JPOS+KPOS)/2 IF (LPOS.NE.IPOS) GO TO 30 C TARGET NOT FOUND BINCHP = .FALSE. IPOS = 0 GO TO 60 C LOOK IN NEXT POSITION 30 IPOS = LPOS IF (TARGET-IABS(ARRAY(IPOS))) 40, 60, 50 C TARGET LT PRESENT POSITION 40 KPOS = IPOS GO TO 20 C TARGET GT PRESENT POSITION 50 JPOS = IPOS GO TO 20 60 RETURN END C*** C LOGICAL FUNCTION CHKFOR C*** LOGICAL FUNCTION CHKFOR(BACK, STAT, DEST) C C CHKFOR = .TRUE. IF TRANSFER IS O.K. FALSE OTHERWISE C C ROUTINE CHECKS FOR ILLEGAL TRANSFER INTO FOR BLOCK C C IF BACK IS FALSE THEN IT IS CALLED FROM TIDYUP AND C FORNXT ARRAY IS COMPLETE C IF BACK IS TRUE THEN A BACKWARD REFERENCE IS BEING C PROCESSED AND OPEN FOR LOOPS NEED TO BE CONSIDERED C C..ARGUMENTS INTEGER DEST, STAT LOGICAL BACK C..LOCAL VARIABLES INTEGER I C..COMMON BLOCKS LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR CHKFOR = .TRUE. IF (ABNFOR) GO TO 60 C CHECK THERE ARE FOR LOOPS IN THE PROGRAM AT THIS STAGE IF (NFOR.EQ.0) GO TO 60 C BACKWARD REFERENCE IF (.NOT.BACK) GO TO 30 DO 20 I=1,NFOR C CHECK IF DESTINATION IS GREATER THAN FOR LABEL IF (DEST.LE.FORNXT(I,1)) GO TO 20 C TEST IF OPEN FOR IF (FORNXT(I,2).NE.0) GO TO 10 C INSIDE OPEN FOR CHECK STATEMENT LABEL IS ALSO IF (STAT.GE.FORNXT(I,1)) GO TO 20 GO TO 50 C CHECK IF DESTINATION LESS THAN NEXT LABEL 10 IF (DEST.GT.FORNXT(I,2)) GO TO 20 C STAT MUST LIE IN THE SAME RANGE IF (STAT.LT.FORNXT(I,1) .OR. STAT.GT.FORNXT(I,2)) GO TO * 50 20 CONTINUE RETURN C CALL FROM TIDYUP FORNXT ARRAY IS FULL 30 DO 40 I=1,NFOR IF (DEST.LE.FORNXT(I,1) .OR. DEST.GT.FORNXT(I,2)) GO TO * 40 C DEST IS IN RANGE STAT MUST BE IF (STAT.LT.FORNXT(I,1) .OR. STAT.GT.FORNXT(I,2)) GO TO * 50 40 CONTINUE RETURN C ERROR EXIT 50 CHKFOR = .FALSE. 60 RETURN END C*** C LOGICAL FUNCTION CHKKEY C*** LOGICAL FUNCTION CHKKEY(ARRAY, LENGTH, K1, K2) C C CHKKEY RETURNS TRUE IF KEYWORD IN ARRAY (1 - LENGTH) C IS FOUND IN THE ARRAY LINE AND FALSE OTHERWISE C C ON EXIT C K1 IS THE POINT AT WHICH THE KEYWORD STARTS C K2 IS THE POINT AT WHICH THE KEYWORD ENDS C C ON ENTRY C K1 DENOTES THE POINT AT WHICH THE SEARCH IS TO START C LENGTH IS ASSUMED GE 2 C C..ARGUMENTS INTEGER K1, K2, LENGTH INTEGER ARRAY(LENGTH) C..LOCAL VARIABLES INTEGER I, K, SPACE C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) DATA SPACE /44/ CHKKEY = .FALSE. I = K1 C LOOK FOR FIRST CHARACTER MATCH 10 IF (LINE(I).EQ.ARRAY(1)) GO TO 20 C NO MATCH GET NEXT CHARACTER I = I + 1 IF (I.GT.NLINE) GO TO 50 GO TO 10 C FIRST CHARACTER MATCH 20 K1 = I DO 40 K=2,LENGTH 30 I = I + 1 C TEST NOT AT END OF LINE IF (I.GT.NLINE) GO TO 50 C IGNORE SPACES IF (LINE(I).EQ.SPACE) GO TO 30 C CHECK NEXT CHARACTER C IF NO MATCH - RECHECK WITH ARRAY(1) IF (LINE(I).NE.ARRAY(K)) GO TO 10 40 CONTINUE C IF FALL OUT OF LOOP THEN MATCH FOUND K2 = I CHKKEY = .TRUE. 50 RETURN END C*** C SUBROUTINE CHKLAB C*** SUBROUTINE CHKLAB C C ROUTINE CHECKS THAT A STATEMENT NUMBER EXISTS AND THAT IT C CONFORMS TO THE STANDARD, CHECKS NEW STATEMENT NUMBER C GREATER THAN PREVIOUS, ADDS NUMBER TO LISTS CHECKING THAT NO C FORWARD REFERENCE EXISTS. C C..LOCAL VARIABLES INTEGER K, MAXSNO, SPACE LOGICAL ERR C..FUNCTIONS INTEGER CODE, LTOINT LOGICAL EATSP C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), * STAREF(500,2) DATA MAXSNO /9999/ DATA SPACE /44/ C EAT ANY LEADING SPACES - ERROR IF ANY SPACES FOUND IN POS1 ONWARDS IF (EATSP(1,K3)) CALL * ERROR(46HONE OR MORE SPACES PRECEEDING STATEMENT NUMBER, * 46) IF (CODE(K3).EQ.1) GO TO 10 C NON-NUMERIC FOUND LABENO = -1 GO TO 60 C GET INTEGER 10 CALL INTEG(ERR) C CHECK STATEMENT NUMBER DOES NOT CONTAIN SPACES IF (ERR) CALL ERROR(32HSTATEMENT NUMBER CONTAINS SPACES, * 32) C CONVERT STATEMENT NUMBER INTO DECIMAL AND TEST IF GREATER C THAN MAXSNO IF (LTOINT(K).GT.MAXSNO) CALL * ERROR(40HSTATEMENT NUMBER EXCEEDS MAXIMUM ALLOWED, 40) C TEST IF STATEMENT LABEL ZERO IF (K.NE.0) GO TO 20 LABENO = 0 GO TO 60 C TEST IF STATEMENT NUMBER GREATER THAN PREVIOUS LINE 20 IF (K.GT.LABENO) GO TO 30 C STATEMENTS NOT ORDERED - SET LABERR = TRUE AND RETURN LABERR = .TRUE. GO TO 60 30 LABENO = K C CHECK STATEMENT HAS NOT OCCURED AS A FORWARD REFERENCE 40 IF (BNSTAT.LT.0) GO TO 50 K = LSTAT - BNSTAT IF (LABENO.LT.IABS(STATNO(K))) GO TO 50 BNSTAT = BNSTAT - 1 NSTAT = NSTAT + 1 STATNO(NSTAT) = STATNO(K) STAREF(NSTAT,1) = STAREF(K,1) STAREF(NSTAT,2) = STAREF(K,2) C REINITIALIZE FORWARD REFERENCE POSITION STAREF(K,1) = 0 IF (LABENO.EQ.IABS(STATNO(K))) GO TO 60 C IF LABENO .GT. STATNO(K) FORWARD REFERENCE IS OUT OF ORDER C OR DOES NOT EXIST C SET STAREF(NSTAT,1) NEGATIVE STAREF(NSTAT,1) = -STAREF(NSTAT,1) GO TO 40 C ENTER CURRENT STATEMENT NUMBER INTO LIST 50 NSTAT = NSTAT + 1 C CHECK ENOUGH ROOM FOR NEW STATEMENT NUMBER IF (NSTAT+BNSTAT+1.GT.LSTAT) CALL SYSERR(4) STATNO(NSTAT) = LABENO IF (-1.EQ.K3) GO TO 60 C CHECK AT LEAST ONE SPACE AFTER STATEMENT NUMBER IF (LINE(K3-1).NE.SPACE) CALL * ERROR(35HNO SPACE FOLLOWING STATEMENT NUMBER, 35) 60 RETURN END C*** C SUBROUTINE CHKREF C*** SUBROUTINE CHKREF(STAT, DEST) C IF STAT=DEST TRANSFER IS TO THE SAME STATEMENT C C CHECKS A STATEMENT REFERENCE C C 1. IF DESTINATION = CURRENT STATEMENT THEN ERROR C 2. IF DESTINATION .LT. CURRENT STATEMENT THEN C CHECK NOT AN ILLEGAL TRANSFER INTO A FOR LOOP C 3. ELSE STORE FORWARD REFERENCE C C..NOTE - THE ACTUAL ARGUMENT USED IN CALLS TO THIS ROUTINE MAY C BE CONTAINED WITHIN COMMON BLOCKS IN THE CALLING SUB- C PROGRAM - THIS IS FLAGGED AS AN UNSAFE REFERENCE BY C PFORT BUT IS ACTUALLY SAFE SINCE NONE OF THE ARGUMENTS C ARE CHANGED. C C..ARGUMENTS INTEGER STAT, DEST C..LOCAL VARIABLES LOGICAL LTEMP C..FUNCTIONS LOGICAL CHKFOR IF (STAT.NE.DEST) GO TO 10 CALL ERROR(30HTRANSFER SETS UP INFINITE LOOP, 30) RETURN C IF STAT .GT. DEST WE HAVE A BACKWARD JUMP 10 IF (STAT.LT.DEST) GO TO 20 LTEMP=CHKFOR(.TRUE., STAT, DEST) IF (.NOT.LTEMP) CALL * ERROR(31HILLEGAL TRANSFER INTO FOR BLOCK, 31) RETURN C FORWARD JUMP STORE STAT AND DEST 20 CALL UPJUMP(STAT, DEST) RETURN END C*** C SUBROUTINE CHKSUB C*** SUBROUTINE CHKSUB(ICODE, NARGS) C C CHECKS ARRAY/FUNCTION REFERENCE HAS CORRECT NUMBER C OF SUBSCRIPTS/ARGUMENTS C C ICODE = CODE OF VARIABLE IN IVAR C NARGS = NUMBER OF SUBSCRIPTS/ARGUMENTS FOUND C C..ARGUMENTS INTEGER ICODE, NARGS C..LOCAL VARIABLES INTEGER INA, INB, IPOS, RND, UDB C..COMMON BLOCKS INTEGER ARRDIM, ARRSUB, ISFUN, FARG COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) DATA INA, INB, UDB, RND /313,338,364,371/ C NON-ANSI FUNCTION OR ARRAY IF (-1.EQ.ICODE) GO TO 90 C TEST FOR NUMERIC ARRAY IF (ICODE.GT.INB) GO TO 20 C ARRAY - GET POSITION IN ARRSUB C ERROR MESSAGE IF MORE THAN TWO SUBSCRIPTS IF (NARGS.GT.2) CALL * ERROR(43HARRAY MAY NOT HAVE MORE THAN TWO DIMENSIONS, 43) IPOS = ICODE - INA + 1 IF (ARRSUB(IPOS).NE.0) GO TO 10 C NOT SEEN BEFORE ARRSUB(IPOS) = -NARGS GO TO 90 C SEEN BEFORE CHECKS ARGS 10 IF (IABS(ARRSUB(IPOS)).NE.NARGS) GO TO 60 GO TO 90 C USER DEFINED FUNCTION 20 IF (ICODE.GT.UDB) GO TO 50 C ERROR MESSAGE IF MORE THAN ONE ARGUMENT IF (NARGS.GT.1) CALL * ERROR(38HFUNCTION MAY HAVE AT MOST ONE ARGUMENT, 38) IPOS = ICODE - INB C TEST IF IT HAS APPEARED BEFORE IF (-999.NE.FARG(IPOS)) GO TO 30 C NO FARG(IPOS) = -NARGS - 1 GO TO 70 C YES IS PRE DEF USAGE 30 IF (FARG(IPOS).GE.0) GO TO 40 C YES - AGAIN CHECK NO CLASH IF (NARGS.NE.(-FARG(IPOS)-1)) CALL * ERROR(43HINCONSISTENT NUMBER OF SUBSCRIPTS/ARGUMENTS, 43) GO TO 70 C NO - CHECK FOR CLASHES 40 IF (NARGS.NE.FARG(IPOS)) GO TO 60 GO TO 90 C CHECK STANDARD FUNCTIONS C TEST FOR RND 50 IF (ICODE.EQ.RND) GO TO 80 IF (NARGS.EQ.1) GO TO 90 GO TO 60 C ERROR EXITS C 1) INCONSISTENT NUMBER OF SUBSCRIPTS/ARGUMENTS 60 CALL ERROR(43HINCONSISTENT NUMBER OF SUBSCRIPTS/ARGUMENTS, * 43) GO TO 90 C 2)FUNCTION USED BEFORE IT APPEARS IN A DEF STATEMENT 70 CALL ERROR(34HFUNCTION USED BEFORE IT IS DEFINED, 34) GO TO 90 C 3) RND DOES NOT HAVE AN ARGUMENTS 80 CALL ERROR(27HRND SHOULD HAVE NO ARGUMENT, 27) 90 RETURN END C*** C SUBROUTINE CLASFY C*** SUBROUTINE CLASFY(CLASS, ERR) C C ROUTINE TO CLASIFY A BASIC STATEMENT BY ITS KEYWORD C IF NON-STANDARD KEYWORD THEN CLASS IS SET TO 21 C ERR IS SET .TRUE. IF SPACES OCCUR WITHIN THE KEYWORD C .FALSE. OTHERWISE C C..ARGUMENTS INTEGER CLASS LOGICAL ERR C..LOCAL VARIABLES INTEGER J, SPACE LOGICAL LTEMP C..FUNCTIONS LOGICAL EATSP C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER KALP, KFAL, KSUC COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CTREE/ KALP(72), KSUC(72), KFAL(72) DATA SPACE /44/ C START OF SEARCH FOR KEYWORDS ERR = .FALSE. J = 1 10 IF (LINE(K3).EQ.KALP(J)) GO TO 20 C NO MATCH - LOOK FOR NEXT NODE IN FAIL TREE J = KFAL(J) C IF J<0 THEN NON-ANSI KEYWORD IF (J) 60, 60, 10 C SUCCESSFUL MATCH - LOOK AT NEXT NODE IN SUCCESS TREE 20 J = KSUC(J) IF (J.LT.0) GO TO 50 C SUCCESSFUL MATCH - NEED TO LOOK AT NEXT NON-BLANK 30 K3 = K3 + 1 C RUN OUT OF LINE - ERROR EXIT IF (K3.LE.NLINE) GO TO 40 J = -21 GO TO 60 40 IF (LINE(K3).NE.SPACE) GO TO 10 C BLANK IN KEYWORD - SET ERROR FLAG AND GET NEXT CHARACTER ERR = .TRUE. GO TO 30 C SUCCESSFUL MATCH CHECK FOR GOTO OR GOSUB 50 IF (-21.NE.J) GO TO 60 C SPACES ARE ALLOWED BETWEEN GO AND TO AND GO AND SUB J = K3 + 1 LTEMP = EATSP(J,K3) J = 68 GO TO 10 C EXIT - NEGATE CLASS AND RETURN 60 CLASS = -J RETURN END C*** C INTEGER FUNCTION CODE C*** INTEGER FUNCTION CODE(I) C C RETURNS THE CODE OF THE CHARACTER IN LINE(I) C DIGIT=1 LETTER=2 SPECIAL CHARACTER=3 C C..ARGUMENTS INTEGER I C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) IF (LINE(I).GT.9) GO TO 10 C DIGIT CODE = 1 GO TO 30 10 IF (LINE(I).GT.35) GO TO 20 C LETTER CODE = 2 GO TO 30 C SPECIAL CHARACTER 20 CODE = 3 30 RETURN END C*** C INTEGER FUNCTION CODECH C*** INTEGER FUNCTION CODECH(CHAR, ERR) C C ROUTINE CODECH MAPS THE CHARACTER CHAR INTO ITS INTERNAL CODE C IF A NON-ANSI CHARACTER IS FOUND THE CODE IS SET TO SPACE C AND ERR IS SET TO .TRUE. C C..ARGUMENTS INTEGER CHAR LOGICAL ERR C..LOCAL VARIABLES INTEGER ICODE(60), LET(60) INTEGER I, LENGTH DATA LENGTH /60/ DATA LET(2), ICODE(2) /1H0,0/ DATA LET(5), ICODE(5) /1H1,1/ DATA LET(17), ICODE(17) /1H2,2/ DATA LET(21), ICODE(21) /1H3,3/ DATA LET(23), ICODE(23) /1H4,4/ DATA LET(20), ICODE(20) /1H5,5/ DATA LET(25), ICODE(25) /1H6,6/ DATA LET(32), ICODE(32) /1H7,7/ DATA LET(36), ICODE(36) /1H8,8/ DATA LET(28), ICODE(28) /1H9,9/ DATA LET(14), ICODE(14) /1HA,10/ DATA LET(26), ICODE(26) /1HB,11/ DATA LET(34), ICODE(34) /1HC,12/ DATA LET(19), ICODE(19) /1HD,13/ DATA LET(4), ICODE(4) /1HE,14/ DATA LET(15), ICODE(15) /1HF,15/ DATA LET(38), ICODE(38) /1HG,16/ DATA LET(27), ICODE(27) /1HH,17/ DATA LET(6), ICODE(6) /1HI,18/ DATA LET(42), ICODE(42) /1HJ,19/ DATA LET(29), ICODE(29) /1HK,20/ DATA LET(10), ICODE(10) /1HL,21/ DATA LET(22), ICODE(22) /1HM,22/ DATA LET(7), ICODE(7) /1HN,23/ DATA LET(8), ICODE(8) /1HO,24/ DATA LET(18), ICODE(18) /1HP,25/ DATA LET(44), ICODE(44) /1HQ,26/ DATA LET(9), ICODE(9) /1HR,27/ DATA LET(16), ICODE(16) /1HS,28/ DATA LET(3), ICODE(3) /1HT,29/ DATA LET(33), ICODE(33) /1HU,30/ DATA LET(41), ICODE(41) /1HV,31/ DATA LET(49), ICODE(49) /1HW,32/ DATA LET(30), ICODE(30) /1HX,33/ DATA LET(43), ICODE(43) /1HY,34/ DATA LET(39), ICODE(39) /1HZ,35/ C PLUS ASCII 2/11 DATA LET(40), ICODE(40) /1H+,36/ C MINUS ASCII 2/13 DATA LET(35), ICODE(35) /1H-,37/ C CLOSE ASCII 2/9 DATA LET(11), ICODE(11) /1H),38/ C EQUALS ASCII 3/13 DATA LET(13), ICODE(13) /1H=,39/ C PERIOD ASCII 2/14 DATA LET(47), ICODE(47) /1H.,40/ C OPEN ASCII 2/8 DATA LET(12), ICODE(12) /1H(,41/ C ASTERISK ASCII 2/10 DATA LET(31), ICODE(31) /1H*,42/ C SLANT ASCII 2/15 DATA LET(48), ICODE(48) /1H/,43/ C SPACE ASCII 2/0 DATA LET(1), ICODE(1) /1H ,44/ C LESS - THAN ASCII 3/12 DATA LET(46), ICODE(46) /1H<,45/ C GREATER - THAN ASCII 3/14 DATA LET(51), ICODE(51) /1H>,46/ C CIRCUMFLEX ASCII 5/14 DATA LET(58), ICODE(58) /1H?,47/ C QUOTE ASCII 2/2 DATA LET(24), ICODE(24) /1H",48/ C EXCLAMATION - POINT 2/1 DATA LET(53), ICODE(53) /1H],49/ C NUMBER - SIGN ASCII 2/3 DATA LET(55), ICODE(55) /1H#,50/ C DOLLAR ASCII 2/4 DATA LET(45), ICODE(45) /1H$,51/ C PERCENT ASCII 2/5 DATA LET(59), ICODE(59) /1H%,52/ C AMPERSAND ASCII 2/6 DATA LET(57), ICODE(57) /1H&,53/ C APOSTROPHE ASCII 2/7 DATA LET(54), ICODE(54) /1H',54/ C COLON ASCII 3/10 DATA LET(52), ICODE(52) /1H:,55/ C SEMI - COLON ASCII 3/11 DATA LET(50), ICODE(50) /1H;,56/ C QUESTION - MARK ASCII 3/15 DATA LET(60), ICODE(60) /1H?,57/ C UNDERLINE ASCII 5/15 DATA LET(56), ICODE(56) /1H?,58/ C COMMA ASCII 2/12 DATA LET(37), ICODE(37) /1H,,59/ C C LOOK FOR STANDARD CONFORMING CHARACTER C DO 10 I=1,LENGTH IF (LET(I).EQ.CHAR) GO TO 20 10 CONTINUE C C NOT FOUND SET TO SPACE AND RETURN BLANK C CODECH = 44 ERR = .TRUE. GO TO 30 C C FOUND C 20 CODECH = ICODE(I) 30 RETURN END C*** C INTEGER FUNCTION CODVAR C*** INTEGER FUNCTION CODVAR(ICODE) C C THIS FUNCTION CODES A VARIABLE STORED IN TOKEN(1 - NTOK) C GIVING ITS POSITION IN THE ARRAY IVAR C C ICODE = 1 - SIMPLE VARIABLE C 2 - STRING VARIABLE C 3 - NUMERICAL ARRAY C 4 - USER DEFINED FUNCTION C 5 - STANDARD FUNCTION C 6 - TAB FUNCTION C C..ARGUMENTS INTEGER ICODE C..LOCAL VARIABLES INTEGER TAB(4) INTEGER A, F, I, IS1, IS2, IS3, IS4, IT, J, N, NOFUN, * TABCOD, Z C..COMMON BLOCKS INTEGER ARRDIM, ARRSUB, ISFUN, FARG INTEGER NTOK, LTOK, TOKEN COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) DATA F, N, A, Z /15,23,10,35/ DATA TAB(1), TAB(2), TAB(3), TAB(4), TABCOD * /29,10,11,41,376/ DATA IS1, IS2, IS3, IS4 /287,313,339,365/ DATA NOFUN /11/ GO TO (10, 20, 30, 40, 50, 80), ICODE C SIMPLE VARIABLE 10 IF (NTOK.EQ.1) IT = -1 IF (NTOK.EQ.2 .AND. TOKEN(2).GT.9) GO TO 100 IF (NTOK.EQ.2) IT = TOKEN(2) CODVAR = (TOKEN(1)-10)*11 + IT + 2 GO TO 110 C STRING VARIABLE 20 CODVAR = IS1 + (TOKEN(1)-10) GO TO 110 C ARRAY VARIABLE 30 CODVAR = IS2 + (TOKEN(1)-10) GO TO 110 C FUNCTION C USER DEFINED (F=15,N=23) 40 IF (TOKEN(1).NE.F .OR. TOKEN(2).NE.N) GO TO 100 C NEXT LETTER MUST BE IN THE RANGE A-Z IF (TOKEN(3).LT.A .OR. TOKEN(3).GT.Z) GO TO 100 CODVAR = IS3 + (TOKEN(3)-10) GO TO 110 C SEARCH STANDARD FUNCTIONS 50 DO 70 I=1,NOFUN DO 60 J=1,3 IF (TOKEN(J).NE.ISFUN(I,J)) GO TO 70 60 CONTINUE C MATCH CODVAR = IS4 + I - 1 GO TO 110 70 CONTINUE GO TO 100 C TAB FUNCTION 80 IF (NTOK.NE.4) GO TO 100 DO 90 I=1,4 IF (TOKEN(I).NE.TAB(I)) GO TO 100 90 CONTINUE CODVAR = TABCOD GO TO 110 C NO MATCH 100 CODVAR = 0 110 RETURN END C*** C SUBROUTINE DATA C*** SUBROUTINE DATA C C CHECKS DATA STATEMENT C C THE DATA ROUTINE JUST CHECKS THAT EACH ITEM IN THE LIST C IS EITHER A QUOTED STRING OR AN UNQUOTED STRING. SINCE C IT IS NOT POSSIBLE TO KNOW WHETHER THE OBJECTS WILL BE C ASSIGNED TO NUMBERS OR NOT NO NUMERICAL CHECKS ARE PERFORMED C C..LOCAL VARIABLES INTEGER COMMA, K, K1, MAXLEN, QUOTE LOGICAL LTEMP C..FUNCTIONS INTEGER CODE, QSTRG LOGICAL EATSP C..COMMON BLOCKS INTEGER K3, JCODE INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CNXTCH/ K3, JCODE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) DATA COMMA, QUOTE /59,48/ C MAXLEN SPECIFIED MAX STRING LENGTH DATA MAXLEN /18/ 10 JCODE = CODE(K3) IF (LINE(K3).NE.QUOTE) GO TO 20 C QUOTED STRING IF (QSTRG(K).GT.MAXLEN) CALL * ERROR(54HWARNING QUOTED STRING EXCEEDS MAXIMUM SPECIFIED LENGTH, * 54) GO TO 30 C OTHERWISE ASSUME UNQUOTED STRING 20 CALL UQSTR 30 IF (-1.EQ.K3) GO TO 50 IF (LINE(K3).EQ.COMMA) GO TO 40 CALL * ERROR(53HNO COMMA WHERE ONE EXPECTED REST OF STATEMENT IGNORED, * 53) GO TO 50 C EAT COMMA AND LOOK FOR NEXT DATUM 40 K1 = K3 + 1 LTEMP = EATSP(K1,K3) C IF END OF LINE ERROR IF (-1.NE.K3) GO TO 10 CALL ERROR(32HDANGLING COMMA IN DATA STATEMENT, 32) 50 RETURN END C*** C SUBROUTINE DCODE C*** SUBROUTINE DCODE(CH, ICODE) C C GIVEN A VARIABLE / ARRAY / FUNCTION CODE - ICODE - RETURNS C A HOLLERITH STRING OF LENGTH THREE IN CH C C..ARGUMENTS INTEGER CH(3) INTEGER ICODE C..LOCAL VARIABLES INTEGER LET(26), NUM(10), U(7) INTEGER DOLLAR, I, IBLNK, ILET, JCODE C..COMMON BLOCKS INTEGER ARRDIM, ARRSUB, ISFUN, FARG COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) DATA LET(1), LET(2), LET(3), LET(4) /1HA,1HB,1HC,1HD/ DATA LET(5), LET(6), LET(7), LET(8) /1HE,1HF,1HG,1HH/ DATA LET(9), LET(10), LET(11), LET(12) /1HI,1HJ,1HK,1HL/ DATA LET(13), LET(14), LET(15), LET(16) /1HM,1HN,1HO,1HP/ DATA LET(17), LET(18), LET(19), LET(20) /1HQ,1HR,1HS,1HT/ DATA LET(21), LET(22), LET(23), LET(24) /1HU,1HV,1HW,1HX/ DATA LET(25), LET(26) /1HY,1HZ/ DATA NUM(1), NUM(2), NUM(3), NUM(4) /1H0,1H1,1H2,1H3/ DATA NUM(5), NUM(6), NUM(7), NUM(8) /1H4,1H5,1H6,1H7/ DATA NUM(9), NUM(10) /1H8,1H9/ DATA U(1), U(2), U(3), U(4), U(5), U(6), U(7) * /1,286,312,338,364,375,376/ DATA IBLNK /1H /, DOLLAR /1H$/ CH(3) = IBLNK CH(2) = IBLNK IF (ICODE.GT.U(2)) GO TO 10 C SIMPLE VARIABLE - CALCULATE LETTER AND DIGIT PARTS ILET = (ICODE-1)/11 CH(1) = LET(ILET+1) C BLANK IF REMAINDER IS -1 ILET = (ICODE-2) - ILET*11 IF (-1.NE.ILET) CH(2) = NUM(ILET+1) GO TO 70 C STRING VARIABLE 10 IF (ICODE.GT.U(3)) GO TO 20 JCODE = ICODE - U(2) CH(1) = LET(JCODE) CH(2) = DOLLAR GO TO 70 C NUMERICAL ARRAY 20 IF (ICODE.GT.U(4)) GO TO 30 JCODE = ICODE - U(3) CH(1) = LET(JCODE) GO TO 70 C USER DEFINED FUNCTION 30 IF (ICODE.GT.U(5)) GO TO 40 JCODE = ICODE - U(4) CH(3) = LET(JCODE) CH(2) = LET(14) CH(1) = LET(6) GO TO 70 C STANDARD FUNCTION 40 IF (ICODE.GT.U(6)) GO TO 60 ILET = ICODE - U(5) DO 50 I=1,3 JCODE = ISFUN(ILET,I) CH(I) = LET(JCODE-9) 50 CONTINUE GO TO 70 C TAB 60 CH(1) = LET(20) CH(2) = LET(1) CH(3) = LET(2) GO TO 70 70 RETURN END C*** C SUBROUTINE DEF C*** SUBROUTINE DEF C C SUBROUTINE ANALYSES DEF STATEMENTS C C..LOCAL VARIABLES INTEGER ARGS, COMMA, EQUALS, FCODE, I, INB, IPOS, K1, K2, * LPAREN, RPAREN LOGICAL LTEMP C..FUNCTIONS INTEGER CODE LOGICAL EATSP, FLSHCH C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER ARRDIM, ARRSUB, ISFUN, FARG INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF INTEGER NTOK, LTOK, TOKEN INTEGER LVAR, IVAR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), * STAREF(500,2) COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) COMMON /CVAR/ LVAR, IVAR(376,2) DATA INB, LPAREN, RPAREN, EQUALS, COMMA /338,41,38,39,59/ C GET FUNCTION NAME AND CHECK THAT IT IS LEGAL NREF = 0 ENDEXP = NLINE CALL NEXTOK IF (K3.GT.ENDEXP .OR. TCODE.NE.2) GO TO 160 IF (TYPE.EQ.4) GO TO 10 C ILEGAL FUNCTION NAME CALL ERROR(26HNON-STANDARD FUNCTION NAME, 26) C CHECK IF LEFT PAREN - IF SO CARRY ON CHECKING SUBSCRIPTS FCODE = 0 GO TO 20 C LEGAL FUNCTION NAME - SET VARIABLES - CHECK NO SPACES C SAVE FUNCTION CODE FOR ELEMENTARY RECURSION CHECK C VCODE = 0 IF FUNCTION IS ILLEGAL 10 IPOS = VCODE - INB FCODE = VCODE IF (ERR) CALL * ERROR(37HSPACES NOT PERMITTED IN VARIABLE NAME, 37) C ANALYZE ARGUMENT LIST IF ONE EXISTS 20 ARGS = 0 IF (TOKEN(NTOK).NE.LPAREN) GO TO 60 C NEXT TOKEN SHOULD BE A SIMPLE NUMERIC VARIABLE 30 CALL NEXTOK C IF NOT S.N. VARIABLE THEN FLUSH TO EQUALS IF (TYPE.EQ.1 .AND. TCODE.EQ.2) GO TO 40 C ERROR NOT A SIMPLE VARIABLE AS ARGUMENT - FLUSH TO EQUALS CALL ERROR(32HARGUMENT MUST BE SIMPLE VARIABLE, 32) GO TO 70 40 IF (ERR) CALL * ERROR(37HSPACES NOT PERMITTED IN VARIABLE NAME, 37) ARGS = ARGS + 1 C ADD DUMMY ARGUMENT TO CHAIN CALL REFCHK C CHECK FOR END OF LINE IF (K3.GT.NLINE) GO TO 160 C CHECK FOR END OF ARGUMENT LIST IF (LINE(K3).NE.RPAREN) GO TO 50 C END OF ARGUMENT LIST - EAT SPACES TO NEXT NON-BLANK K2 = K3 + 1 LTEMP = EATSP(K2,K3) IF (-1.EQ.K3) GO TO 160 GO TO 60 C CHECK IF COMMA NEXT - IF SO GET NEXT ARGUMENT (ILLEGAL) 50 IF (LINE(K3).NE.COMMA) GO TO 70 K2 = K3 + 1 LTEMP = EATSP(K2,K3) IF (-1.EQ.K3) GO TO 160 JCODE = CODE(K3) GO TO 30 C NEXT CHARACTER EQUALS - YES THEN CHECK EXPRESSION 60 IF (LINE(K3).EQ.EQUALS) GO TO 80 C OUTPUT ERROR MESSAGE AND FLUSH TO EQUALS 70 IF (.NOT.FLSHCH(K3,EQUALS)) GO TO 170 CALL ERROR(35HSYNTAX ERROR CHECKING RESTARTS AT =, 35) C EQUALS FOUND - GET NEXT NON-BLANK 80 K2 = K3 + 1 LTEMP = EATSP(K2,K3) IF (-1.EQ.K3) GO TO 160 IF (ARGS.GT.1) CALL * ERROR( * 48HONLY ONE ARGUMENT ALLOWED IN FUNCTION DEFINITION, 48) C CHECK IF FUNCTION REDEFINED (FARG(IPOS) POSITIVE) C OR USED BEFORE DEFINITION (FARG(IPOS) NOT EQUAL -999) C SKIP TESTS IF ILLEGAL FUNCTION HAS BEEN FOUND IF (FCODE.EQ.0) GO TO 110 IF (FARG(IPOS).LT.0) GO TO 90 CALL ERROR(29HFUNCTION MAY NOT BE REDEFINED, 29) GO TO 110 90 IF (-999.EQ.FARG(IPOS)) GO TO 100 CALL ERROR(40HFUNCTION HAS BEEN USED BEFORE DEFINITION, * 40) C IN THIS CASE TEST FOR CONFLICTING NUMBER OF ARGUMENTS IF (ARGS.NE.IABS(FARG(IPOS)+1)) CALL * ERROR( * 50HNUMBER OF ARGUMENTS IN PREVIOUS CALLS INCONSISTENT, * 50) C UPDATE FARG WITH DEFINED NUMBER OF ARGUMENTS (ARGS) 100 FARG(IPOS) = ARGS C NOW ANALYSE EXPRESSION 110 K1 = K3 CALL EXPRES(K1, NLINE, -1, .TRUE.) C CANNOT HAVE SIMPLE STRING ON R.H.S. IF (SIMPST) CALL * ERROR(37HILLEGAL R.H.S. OF FUNCTION DEFINITION, 37) C CHECK NO OBVIOUS RECURSION IF (FCODE.EQ.0 .OR. NREF.EQ.0) GO TO 130 DO 120 I=1,NREF IF (FCODE.EQ.REF(I)) CALL * ERROR(24HRECURSION IS NOT ALLOWED, 24) 120 CONTINUE C ADD REFERENCES TO CHAIN 130 IF (FCODE.EQ.0) GO TO 140 VCODE = FCODE CALL REFCHK 140 IF (NREF.EQ.0) GO TO 180 DO 150 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 150 CONTINUE GO TO 180 C ERRORS C 1)SYNTAX ERRORS - IGNORE REST OF STATEMENT 160 CALL ERROR(38HSYNTAX ERROR REST OF STATEMENT IGNORED, 38) GO TO 180 C 2)UNRECOVERABLE ERROR AFTER ATTEMPTED FLUSH TO EQUALS 170 CALL ERROR(26H= NOT FOUND WHERE EXPECTED, 26) CALL ERROR(25HREST OF STATEMENT IGNORED, 25) 180 RETURN END C*** C SUBROUITNE DIM C*** SUBROUTINE DIM C C ANALYZES DIM STATEMENTS C C..LOCAL VARIABLES INTEGER AROFST, COMMA, I, IPOS, K, K1, LPAREN, RPAREN, * SUBS LOGICAL ERR, LTEMP C..FUNCTIONS INTEGER CODE, LTOINT LOGICAL EATSP, FLSHRP C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL EXPERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE LOGICAL DIMYET, OPTYET INTEGER OPTSET INTEGER NREF, REF INTEGER ARRDIM, ARRSUB, ISFUN, FARG INTEGER NTOK, LTOK, TOKEN INTEGER LVAR, IVAR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, EXPERR, VCODE, ENDEXP, SIMPST COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /COPT/ DIMYET, OPTYET, OPTSET COMMON /CREFER/ NREF, REF(40) COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) COMMON /CVAR/ LVAR, IVAR(376,2) DATA LPAREN, RPAREN, COMMA /41,38,59/ DATA AROFST /312/ C INITIALIZATION DIMYET = .TRUE. NREF = 0 ENDEXP = NLINE 10 SUBS = 1 CALL NEXTOK IPOS = VCODE - AROFST C TEST IF NO OPENING BRACKET IF (TOKEN(NTOK).NE.LPAREN) GO TO 100 C TEST IF LEGAL ARRAY IF (TYPE.EQ.3) GO TO 20 C BRACKET IN TOKEN(NTOK) BUT NON-ANSI ARRAY C FLUSH TO MATCHING CLOSING BRACKET CALL ERROR(29HILLEGAL NAME IN DIM STATEMENT, 29) K1 = K3 IF (.NOT.FLSHRP(K1)) GO TO 90 GO TO 70 C HAVE GOT LEGAL NUMERIC ARRAY - ADD TO REFERENCE CHAIN 20 NREF = NREF + 1 REF(NREF) = VCODE C NOTE NEXTOK HAS MOVED K3 TO THE NEXT NON-BLANK C TEST FOR END OF LINE IF (K3.GT.NLINE) GO TO 110 C TEST IF NEXT IS A DIGIT 30 IF (JCODE.EQ.1) GO TO 40 C IF NOT FLUSH TO NEXT ) CALL ERROR(28HDIMENSION MUST BE AN INTEGER, 28) K1 = K3 IF (.NOT.FLSHRP(K1)) GO TO 90 GO TO 70 C GET INTEGER AND ADD TO ARRDIM 40 CALL INTEG(ERR) IF (ERR) CALL * ERROR(44HSPACES NOT PERMITTED WITHIN INTEGER CONSTANT, * 44) C ADD IN INTEGER TO ARRDIM IF SUBS LE 2 IF (SUBS.EQ.1 .AND. ARRDIM(IPOS,1).NE.(-1)) CALL * ERROR(37HREDIMENSIONING OF AN ARRAY IS ILLEGAL, 37) IF (SUBS.LE.2) ARRDIM(IPOS,SUBS) = LTOINT(K) C INTEG RETURNS NEXT NON-BLANK AND ITS CODE IF (-1.EQ.K3) GO TO 110 C TEST FOR COMMA IF (LINE(K3).NE.COMMA) GO TO 50 C YES - LOOK FOR ANOTHER DIMENSION SUBS = SUBS + 1 K1 = K3 + 1 LTEMP = EATSP(K1,K3) IF (-1.EQ.K3) GO TO 110 JCODE = CODE(K3) GO TO 30 C NO - END OF ARRAY - REQUIRE RIGHT PARENTHESIS 50 IF (LINE(K3).EQ.RPAREN) GO TO 60 C TRY TO FLUSH TO RIGHT PARENTHESIS CALL ERROR(28HNO ) OR , WHERE ONE EXPECTED, 28) K1 = K3 IF (.NOT.FLSHRP(K1)) GO TO 90 GO TO 70 C FINISHED RECORD NUMBER OF SUBSCRIPTS C CHECK ,IF USED BEFORE DIMENSIONING, NUMBER OF ARGUMENTS C IS CONSISTENT 60 IF (ARRSUB(IPOS).NE.0) CALL * ERROR(47HARRAY USED PRIOR TO APPEARANCE IN DIM STATEMENT, * 47) IF (ARRSUB(IPOS).LT.0 .AND. ARRSUB(IPOS).NE.(-SUBS)) CALL * ERROR(43HINCONSISTENT NUMBER OF SUBSCRIPTS/ARGUMENTS, 43) ARRSUB(IPOS) = SUBS IF (SUBS.GT.2) CALL * ERROR(37HARRAY MAY HAVE AT MOST TWO DIMENSIONS, 37) GO TO 80 C RECOVERABLE ERROR 70 K3 = K1 CALL ERROR(23HRECOVERED AT MATCHING ), 23) 80 K1 = K3 + 1 LTEMP = EATSP(K1,K3) C CLEAN EXIT IF (-1.EQ.K3) GO TO 120 C OTHERWISE NEED SEPARATOR , IF (LINE(K3).NE.COMMA) GO TO 110 C GET NEXT NON-BLANK K1 = K3 + 1 LTEMP = EATSP(K1,K3) IF (-1.EQ.K3) GO TO 110 JCODE = CODE(K3) C GET NEXT ARRAY GO TO 10 C ERROR EXITS C 1)UNRECOVERABLE ERROR 90 CALL ERROR(41HUNRECOVERABLE - REST OF STATEMENT IGNORED, * 41) GO TO 120 C 2)NON ARRAY 100 CALL * ERROR( * 52HNON-SUBSCRIPTED VARIABLE - REST OF STATEMENT IGNORED, * 52) GO TO 120 C 3) SYNTAX ERROR IN STATEMENT 110 CALL ERROR(37HDIM STATEMENT SYNTACTICALLY INCORRECT, 37) GO TO 120 C ADD REFERENCES TO CHAIN 120 IF (NREF.EQ.0) GO TO 140 DO 130 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 130 CONTINUE 140 RETURN END C*** C LOGICAL FUNCTION EATSP C*** LOGICAL FUNCTION EATSP(K1, K2) C C EATSP EATS SPACES C C ON ENTRY C K1 = POSITION OF START OF SEARCH IN ARRAY LINE C ON EXIT C K2 = POSITION OF FIRST NON-BLANK CHARACTER IN LINE C -1 IF NONE (I.E. REST OF LINE IS BLANK) C EATSP = .TRUE. IF SPACES FOUND C = .FALSE. IF NO SPACES HAVE BEEN FOUND C C..ARGUMENTS INTEGER K1, K2 C..LOCAL VARIABLES INTEGER J, K4, SPACE C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) DATA SPACE /44/ EATSP = .FALSE. C CHECK NOT AT END OF LINE IF (K1.GT.NLINE) GO TO 20 K2 = K1 IF (LINE(K1).NE.SPACE) GO TO 30 C AT LEAST ONE SPACE FOUND EATSP = .TRUE. K2 = K1 + 1 K4 = K2 DO 10 J=K4,NLINE IF (LINE(J).NE.SPACE) GO TO 30 K2 = K2 + 1 10 CONTINUE C END OF LINE IF FALL THROUGH DO LOOP EATSP = .FALSE. C COME HERE IF K1 .GT. NLINE (NOTE EATSP = .FALSE.) 20 K2 = -1 30 RETURN END C*** C SUBROUTINE ERROR C*** SUBROUTINE ERROR(MESS, NMESS) C C OUTPUT ROUTINE FOR ERROR MESSAGES C NOUT IS THE OUTPUT CHANNEL NUMBER C NUMERR IS THE NUMBER OF ERROR MESSAGES SO FAR OUTPUT C MACHINE DEPENDENT CONSTANT , NOCHAR , THE NUMBER OF C CHARACTERS STORED IN AN INTEGER. C A CHANGE IN THE VALUE OF NOCHAR WILL ALSO NECESSITATE C A CHANGE IN THE FORMAT STATEMENT 99999 C A MORE REFINED OUTPUT MAY BE OBTAINED BY INCLUDING THE COMMON BLOCK C COMMON /CNXTCH/ K3,JCODE C IN THE EVENT OF AN ERROR K3 USUALLY HOLDS THE CHARACTER POSITION C IN THE LINE CLOSE TO WHERE THE ERROR OCCURRED. C C..ARGUMENTS INTEGER MESS(20) INTEGER NMESS C..LOCAL VARIABLES INTEGER I, NOCHAR, NWORD C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER NIN, NOUT, NTAB LOGICAL ENDIN COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CIO/ NIN, NOUT, NTAB, ENDIN DATA NOCHAR /4/ NUMERR = NUMERR + 1 NWORD = NMESS/NOCHAR IF (NWORD*NOCHAR.NE.NMESS) NWORD = NWORD + 1 WRITE (NOUT,99999) (MESS(I),I=1,NWORD) RETURN 99999 FORMAT (1H , 3H***, 20A4) END C*** C SUBROUTINE EXPRES C*** SUBROUTINE EXPRES(K1, K2, LEVEL, STRING) C C ANALYZES A BASIC EXPRESSION STARTING AT LINE(K1) AND C ENDING AT LINE(K2). IF LEVEL IS SET POSITIVE EXIT IS C MADE FROM THE ROUTINE WHEN THAT LEVEL OF CLOSING C PARENTHESIS IS ENCOUNTERED. C IF STRING IS SET TRUE ON ENTRY - A SEARCH IS INITIALLY C MADE FOR A SIMPLE STRING VARIABLE OR A QUOTED STRING - C ALL THAT IS ALLOWED AS A STRING EXPRESSION - IN ANSI C BASIC. C THE ROUTINE ATTEMPTS TO ANALYSE AS MUCH OF THE EXPRESSION C AS POSSIBLE. C C..ARGUMENTS INTEGER K1, K2, LEVEL LOGICAL STRING C..LOCAL VARIABLES INTEGER COMMA, I, ICH, ICODE, K, K4, KCODE, KEEP, LPAREN, MAXLEN, * MINUS, PERIOD, PLUS, QUOTE, RND, RPAREN, SLASH, SPACE, STAR, * STUSED, WORRA LOGICAL ERR, LTEMP C..FUNCTIONS INTEGER CODE, QSTRG LOGICAL EATSP C..COMMON BLOCKS INTEGER ARPOS, ARSTAK, DLPREQ, LARST, LPOPEN, NEXT1 LOGICAL ERREXP, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NTOK, LTOK, TOKEN COMMON /CARFUN/ LARST, ARSTAK(40,3), NEXT1, LPOPEN, DLPREQ, ARPOS COMMON /CEXPR/ TCODE, TYPE, ERREXP, VCODE, ENDEXP, SIMPST COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) C MAXLEN IS MAXIMUM STRING LENGTH DATA RND, MAXLEN, PERIOD /371,18,40/ DATA QUOTE, PLUS, MINUS, SPACE, LPAREN /48,36,37,44,41/ DATA STAR, WORRA, SLASH, RPAREN, COMMA /42,47,43,38,59/ SIMPST = .FALSE. ERR = .FALSE. C INITIALIZE ENDEXP = K2 IF (LEVEL.LT.0) NEXT1 = 1 LPOPEN = 0 IF (LEVEL.GT.0) LPOPEN = LEVEL STUSED = 0 C SAVE K3 AND JCODE AND FIND FIRST NON-BLANK IN EXPRESSION KEEP = K3 KCODE = JCODE LTEMP = EATSP(K1,K3) IF (K3.GT.K2 .OR. (-1).EQ.K3) GO TO 250 JCODE = CODE(K3) C IF STRING EXPRESSION REQUIRED - KEEP STARTING POSITION IF (.NOT.STRING) GO TO 40 K4 = K3 ICODE = JCODE C IF JCODE.EQ.3 IT MUST BE A QUOTE - ELSE TRY MORE COMPLEX EXPRESSION IF (JCODE.NE.3) GO TO 20 IF (LINE(K3).NE.QUOTE) GO TO 30 I = QSTRG(K) C K4+K+1 IS THE POSITION OF THE FINAL QUOTE C IF CLOSING QUOTE NOT FOUND IN EXPRESSION RANGE - GIVE UP C NOTE - ERROR MESSAGE HAS ALREADY BEEN OUTPUT FROM QSTRG IF ((-1.EQ.K3 .AND. K.LT.0) .OR. (K4+K+1.GT.K2)) GO TO 220 C CHECK AT END OF EXPRESSION IF (-1.EQ.K3) GO TO 10 IF (K3.LE.K2) GO TO 30 C SUCCESSFUL STRING EXPRESSION - CHECK MAXLEN 10 IF (K.GT.MAXLEN) CALL * ERROR(54HWARNING QUOTED STRING EXCEEDS MINIMAL SPECIFIED LENGTH, * 54) SIMPST = .TRUE. GO TO 280 C IF JCODE.EQ.1 - NUMBER - CANNOT BE STRING 20 IF (JCODE.EQ.1) GO TO 30 C ALPHABETIC - NEXT TOKEN CALL NEXTOK C MUST BE A LEGAL STRING VARIABLE AND AT END OF EXPRESSION IF (TYPE.NE.2 .OR. K3.NE.K2+1) GO TO 30 C LEGAL STRING PREPARE FOR EXIT - ERROR MESSAGE C IF SPACES IN STRING VARIABLE IF (ERREXP) CALL ERROR(37HSPACES NOT PERMITTED IN VARIABLE NAME, * 37) C ADD REFERENCE TO REFERENCE ARRAY CALL REFCHK SIMPST = .TRUE. GO TO 280 C RESET START OF EXPRESSION AND TREAT AS COMPLEX EXPRESSION 30 K3 = K4 JCODE = ICODE C EAT UP SIGN AND OPENING BRACKETS 40 IF (LINE(K3).NE.PLUS .AND. LINE(K3).NE.MINUS) GO TO 70 C EAT IT AND SPACES 50 K3 = K3 + 1 IF (K3.GT.K2) GO TO 220 IF (LINE(K3).NE.SPACE) GO TO 60 GO TO 50 60 JCODE = CODE(K3) C OPENING BRACKET 70 IF (LINE(K3).NE.LPAREN) GO TO 90 LPOPEN = LPOPEN + 1 C EAT SPACES 80 K3 = K3 + 1 IF (K3.GT.K2) GO TO 220 IF (LINE(K3).EQ.SPACE) GO TO 80 JCODE = CODE(K3) GO TO 40 C TEST IF QUOTED STRING 90 IF (LINE(K3).NE.QUOTE) GO TO 100 C IF ALREADY HAD A QUOTED STRING OR OTHER STRING THEN GIVE UP K4 = K3 C TEST IF QUOTED STRING IS LEGAL I = QSTRG(K) IF ((-1.EQ.K) .OR. (K4+K+1.GT.K2)) GO TO 220 C CHECK MAX LENGTH IF (K.GT.MAXLEN) CALL * ERROR(46HQUOTED STRING EXCEEDS MINIMAL SPECIFIED LENGTH, 46) STUSED = STUSED + 1 C CHECK IF END OF LINE GO TO 130 C TEST IF PERIOD COULD BE A NUMBER 100 IF (LINE(K3).EQ.PERIOD) GO TO 110 C IF JCODE.EQ.3 NOW THEN ERROR IF (JCODE.EQ.3) GO TO 230 C GET NEXT TOKEN 110 CALL NEXTOK IF (ERREXP .OR. (ERR .AND. TCODE.EQ.1)) CALL * ERROR(53HSPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME, * 53) ERR = .FALSE. C TEST IF STRING (TCODE=2 AND TYPE=2) AND ARPOS.NE.0 (ARRAY C SUBSCRIPT OR FUNCTION ARGUMENT BEING PARSED) IF ((TCODE.EQ.2 .AND. TYPE.EQ.2) .AND. ARPOS.NE.0) CALL * ERROR(29HILLEGAL SUBSCRIPT OR ARGUMENT, 29) C TEST IF NUMBER IF (TCODE.EQ.1 .AND. TYPE.EQ.(-1)) GO TO 220 IF (TCODE.EQ.1) GO TO 130 C TEST IF ILLEGAL VARIABLE / FUNCTION IF (TYPE.LT.0) CALL ERROR(30HILLEGAL VARIABLE/FUNCTION NAME, 30) C TEST IF SIMPLE VARIABLE - NO ( IN TOKEN(NTOK) IF (TOKEN(NTOK).NE.LPAREN) GO TO 120 C ADD TOKEN TO ARSTAK LPOPEN = LPOPEN + 1 CALL ARWIND(.FALSE.) IF (VCODE.GT.0) CALL REFCHK C CAN NOW HAVE AN EXPRESSION AS ARRAY SUBSCRIPT OR FUNCTION C ARGUMENT. N.B. JCODE AND K3 HAVE BEEN SET BY NEXTOK GO TO 40 C SIMPLE VARIABLE CHECK C ADD CODE INTO ARRAY REF IF IT DOESNOT ALREADY EXIST 120 IF (TYPE.GT.0) CALL REFCHK C CHECK IF FUNCTION WITH NO ARGUMENTS THAT THIS IS CONSISTENT AND C THAT FUNCTION HAS BEEN PREVIOUSLY DEFINED IF (TCODE.EQ.2 .AND. (TYPE.EQ.3 .OR. TYPE.EQ.4)) CALL * CHKSUB(VCODE, 0) C CHECK THAT IF TYPE=5 THE FUNCTION IS RND C NO OTHER STANDARD FUNCTIONS HAVE NO ARGUMENTS IF (TYPE.EQ.5 .AND. VCODE.NE.RND) CALL * ERROR(42HSTANDARD FUNCTION CALLED WITHOUT ARGUMENTS, 42) C CHECK IF STRING LEGAL OR OTHERWISE IF (IABS(TYPE).EQ.2) STUSED = STUSED + 1 C CHECK IF END OF EXPRESSION 130 IF (K3.GT.K2 .OR. (-1).EQ.K3) GO TO 260 C CHECK FOR CLOSING BRACKET - EATING SPACES IF (LINE(K3).NE.SPACE) GO TO 140 K3 = K3 + 1 GO TO 130 140 IF (LINE(K3).NE.RPAREN) GO TO 170 C CLOSING BRACKET FOUND LPOPEN = LPOPEN - 1 C CHECK MISMATCHED PARENTHESES IF (LPOPEN.GE.0) GO TO 150 CALL ERROR(22HMISMATCHED PARENTHESES, 22) GO TO 240 C CLOSE DOWN ARRAY/FUNCTION AS NECESSARY 150 IF (LPOPEN.EQ.DLPREQ-1) CALL ARWIND(.TRUE.) C EXIT IF MATCHING BRACKET FOUND IF (LPOPEN.EQ.LEVEL-1) GO TO 160 C CHECK FOR MORE RIGHT PARENTHESES K3 = K3 + 1 GO TO 130 C MATCHING RIGHT PAREN IN LINE(K3) - FIND NEXT NON BLANK AND EXIT 160 K4 = K3 + 1 LTEMP = EATSP(K4,K3) IF (-1.NE.K3) JCODE = CODE(K3) GO TO 290 C TEST IF PLUS,MINUS,UP ARROW ,STAR OR SLASH 170 ICH = LINE(K3) IF (ICH.NE.PLUS .AND. ICH.NE.MINUS .AND. ICH.NE.STAR .AND. * ICH.NE.SLASH .AND. ICH.NE.WORRA) GO TO 190 C EAT IT BUT CANT HAVE END OF LINE 180 K3 = K3 + 1 IF (K3.GT.K2) GO TO 220 IF (LINE(K3).EQ.SPACE) GO TO 180 JCODE = CODE(K3) GO TO 70 C COMMA 190 IF (LINE(K3).NE.COMMA) GO TO 220 C UPDATE NUMBER OF SUBSCRIPTS / ARGUMENTS C IF NONE OPEN THEN ERROR IF (ARPOS.NE.0) GO TO 200 CALL ERROR(48HCOMMA FOUND BUT NO ARRAYS/FUNCTIONS OPEN-IGNORED, * 48) GO TO 40 200 ARSTAK(ARPOS,3) = ARSTAK(ARPOS,3) + 1 210 K3 = K3 + 1 IF (K3.GT.K2) GO TO 220 IF (LINE(K3).EQ.SPACE) GO TO 210 JCODE = CODE(K3) GO TO 40 C ERROR EXIT - MISPLACED DELIMITER OF OPERATOR 220 K3 = K2 230 CALL ERROR(42HMISPLACED OR ILLEGAL DELIMITER OR OPERATOR, 42) 240 CALL ERROR(26HREST OF EXPRESSION IGNORED, 26) GO TO 270 250 CALL ERROR(37HEXPRESSION MISSING WHERE ONE EXPECTED, 37) GO TO 270 C CLEAN EXIT CHECK FOR MISMATCHED PARENTHESES 260 IF (LPOPEN.NE.0) CALL ERROR(25HMISSING RIGHT PARENTHESES, 25) 270 IF (STUSED.GT.1) CALL * ERROR(44HNON-STANDARD USE OF STRING VARIABLE/FUNCTION, 44) 280 K3 = KEEP JCODE = KCODE 290 RETURN END C*** C LOGICAL FUNCTION FLSHCH C*** LOGICAL FUNCTION FLSHCH(K1, CHAR) C C TRUE IF CHAR FOUND - POSITION IN K1 C FALSE IF NOT FOUND C K1 IS START OF SEARCH POSITION ON ENTRY C C..ARGUMENTS INTEGER CHAR, K1 C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) FLSHCH = .TRUE. 10 IF (K1.GT.NLINE) GO TO 20 IF (LINE(K1).EQ.CHAR) GO TO 30 K1 = K1 + 1 GO TO 10 20 FLSHCH = .FALSE. 30 RETURN END C*** C LOGICAL FUNCTION FLSHRP C*** LOGICAL FUNCTION FLSHRP(K1) C C TRUE IF MATCHING RIGHT PARENTHESIS FOUND C POSITION IN K1 - FALSE IF NOT FOUND C K1 IS THE POSITION OF START OF SEARCH C C..ARGUMENTS INTEGER K1 C..LOCAL VARIABLES INTEGER LPAREN, LPOPEN, RPAREN C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) DATA LPAREN, RPAREN /41,38/ LPOPEN = 1 FLSHRP = .TRUE. 10 IF (K1.GT.NLINE) GO TO 40 IF (LINE(K1).NE.RPAREN) GO TO 20 C CLOSING BRACKET LPOPEN = LPOPEN - 1 IF (LPOPEN.EQ.0) GO TO 50 GO TO 30 C OPEN BRACKETS 20 IF (LINE(K1).NE.LPAREN) GO TO 30 LPOPEN = LPOPEN + 1 30 K1 = K1 + 1 GO TO 10 40 FLSHRP = .FALSE. 50 RETURN END C*** C SUBROUTINE FORST C*** SUBROUTINE FORST C C CHECK FOR STATEMENT C C..LOCAL VARIABLES INTEGER STEP(5), TO(3) INTEGER EQUALS, I, IREF, K1, K2, K4, SPACE LOGICAL ERR, LSPACE, LTEMP C..FUNCTIONS INTEGER CODVAR LOGICAL CHKKEY, EATSP C..COMMON BLOCKS INTEGER LDO, DOPEN, DOSPEC INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERREXP, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER LVAR, IVAR COMMON /CDO/ LDO, DOPEN, DOSPEC(30) COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERREXP, VCODE, ENDEXP, SIMPST COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CVAR/ LVAR, IVAR(376,2) DATA EQUALS, SPACE /39,44/ DATA TO(1), TO(2), TO(3) /29,24,2/ DATA STEP(1), STEP(2), STEP(3), STEP(4), STEP(5) * /28,29,14,25,4/ C INITIALIZE ERR = .FALSE. LSPACE = .FALSE. NREF = 0 C USE NEXTOK TO PICK UP NEXT TOKEN ENDEXP = NLINE CALL NEXTOK C CHECK SIMPLE VARIABLE IF (TCODE.EQ.2 .AND. TYPE.EQ.1) GO TO 40 C NOT A SIMPLE VARIABLE CALL * ERROR(45HSIMPLE NUMERIC VARIABLE MUST CONTROL FOR LOOP, * 45) C FLUSH TO = (39) IN AN ATTEMPT TO RECOVER C CHECK RETURN FROM NEXTOK NOT AT END OF STATEMENT IF (K3.GT.NLINE) GO TO 20 K1 = K3 DO 10 I=K1,NLINE IF (LINE(I).EQ.EQUALS) GO TO 30 10 CONTINUE C NO = FOUND GIVE UP 20 CALL ERROR(41HUNRECOVERABLE - REST OF STATEMENT IGNORED, * 41) GO TO 150 C RECOVER START AT = SIGN JUMP DOSPEC 30 CALL ERROR(22HCHECKING RESTARTS AT =, 22) K3 = I GO TO 80 C SIMPLE VARIABLE FOUND - CHECK NO SPACES 40 NREF = 1 REF(NREF) = CODVAR(1) IF (ERREXP) CALL * ERROR(37HSPACES NOT PERMITTED IN VARIABLE NAME, 37) C ADD VARIABLE TO DOSPEC ARRAY C CHECK VARIABLE HAS NOT BEEN USED MORE THAN ONCE C IN NESTED FOR-LOOPS IF (DOPEN.EQ.0) GO TO 60 IREF = REF(NREF) DO 50 I=1,DOPEN IF (DOSPEC(I).NE.IREF) GO TO 50 CALL * ERROR(42HNESTED FOR-LOOP CONTROL VARIABLES THE SAME, * 42) GO TO 70 50 CONTINUE C CHECK NOT MORE THAN LDO ALREADY OPEN IF (LDO.EQ.DOPEN) CALL SYSERR(3) 60 DOPEN = DOPEN + 1 DOSPEC(DOPEN) = REF(NREF) C ADD LABEL INTO FORNXT ARRAY NFOR = NFOR + 1 IF (NFOR.GT.LFOR) CALL SYSERR(6) FORNXT(NFOR,1) = LABENO C NEXTOK HAS RETURNED A SIMPLE VARIABLE BUT NO MORE CHARACTERS ON LINE 70 IF (K3.GT.NLINE) GO TO 110 C CHECK = SIGN (39) IF (LINE(K3).NE.EQUALS) GO TO 110 80 K1 = K3 + 1 LTEMP = EATSP(K1,K3) IF (-1.EQ.K3) GO TO 100 C CHECK KEYWORD EXISTS IF (.NOT.(CHKKEY(TO,TO(3),K1,K2))) GO TO 120 C CHECK PRECEDED BY A SPACE IF (LINE(K1-1).NE.SPACE) ERR = .TRUE. C CHECK DOES NOT CONTAIN SPACES IF (K2-K1.NE.1) LSPACE = .TRUE. C IF AT END OF LINE - ERROR - NO EXPRESSION FOLLOWS KEYWORD OR = IF (K2.EQ.NLINE) GO TO 100 C CHECK SPACE FOLLOWS KEYWORD IF (LINE(K2+1).NE.SPACE) ERR = .TRUE. C CHECK EXPRESSION FROM AFTER = (K3) TO KEYWORD K4 = K3 CALL EXPRES(K4, K1-1, -1, .FALSE.) C OUTPUT ANY ERRORS REGARDING KEYWORD TO K3 = K2 - 1 IF (ERR) CALL * ERROR(38HSPACES MUST PRECEDE AND FOLLOW KEYWORD, 38) IF (LSPACE) CALL * ERROR(33HSPACES NOT ALLOWED WITHIN KEYWORD, 33) C REINITIALIZE SPACE AND ERR LSPACE = .FALSE. ERR = .FALSE. C K2 POINTS AT END OF TO - LOOK FOR STEP KEYWORD K1 = K2 + 1 IF (.NOT.(CHKKEY(STEP,STEP(5),K1,K4))) GO TO 90 C KEYWORD APPEARS CHECK SPACES IF (LINE(K1-1).NE.SPACE) ERR = .TRUE. IF (K4-K1.NE.3) LSPACE = .TRUE. C IF AT END OF LINE ERROR AS WITH TO IF (K4.EQ.NLINE) GO TO 100 IF (LINE(K4+1).NE.SPACE) ERR = .TRUE. C CHECK EXPRESSION FOLLOWING TO CALL EXPRES(K2+1, K1-1, -1, .FALSE.) C OUTPUT ANY SPACE ERRORS IN STEP K3 = K4 - 1 IF (LSPACE) CALL * ERROR(33HSPACES NOT ALLOWED WITHIN KEYWORD, 33) IF (ERR) CALL * ERROR(38HSPACES MUST PRECEDE AND FOLLOW KEYWORD, 38) C CHECK EXPRESSION FOLLOWING STEP CALL EXPRES(K4+1, NLINE, -1, .FALSE.) GO TO 130 C NO STEP KEYWORD JUST CHECK TO EXPRESSION 90 CALL EXPRES(K2+1, NLINE, -1, .FALSE.) GO TO 130 C ERROR EXITS C 1)FOR MISSING KEYWORDS - MAY HAVE REFERENCES 100 CALL ERROR(34HNO EXPRESSION FOLLOWS KEYWORD OR =, 34) GO TO 130 C 2)MISSING = SIGN 110 CALL * ERROR(47HDELIMITER = MISSING - REST OF STATEMENT IGNORED, * 47) GO TO 150 C 3)KEYWORD TO MISSING 120 CALL ERROR(39HKEYWORD TO ABSENT - STATEMENT ABANDONED, 39) GO TO 150 C ADD VARIABLE REFERENCES TO CHAIN 130 IF (NREF.EQ.0) GO TO 150 DO 140 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 140 CONTINUE 150 RETURN END C*** C SUBROUTINE GOTOS C*** SUBROUTINE GOTOS C C CHECKS GOTO (7) AND GOSUB(6) STATEMENTS TO ENSURE C A)SPACE FOLLOWS KEYWORD C B)STATEMENT NUMBER ONLY ON REST OF LINE C C K3 CONTAINS THE POSITION OF THE NEXT NON-BLANK C AND JCODE ITS CODE C C..LOCAL VARIABLES INTEGER K, MAXSNO, REF LOGICAL ERR C..FUNCTIONS INTEGER LTOINT C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE DATA MAXSNO /9999/ C CHECK NEXT DIGIT AN INTEGER IF (JCODE.NE.1) GO TO 10 C INTEGER - GET NUMERICAL STRING CALL INTEG(ERR) C SPACES IN STATEMENT NUMBER IF (ERR) CALL * ERROR(38HSPACES NOT ALLOWED IN STATEMENT NUMBER, 38) REF = LTOINT(K) IF (REF.GT.MAXSNO) CALL * ERROR(44HSTATEMENT NUMBER EXCEEDS MINIMAL REQUIREMENT, * 44) IF (REF.EQ.0) GO TO 10 CALL ADDSTA(REF) CALL CHKREF(LABENO, REF) C TEST NO MORE INFO ON LINE IF (-1.NE.K3) CALL * ERROR( * 53HEXTRANEOUS INFORMATION FOLLOWING GOTO/GOSUB STATEMENT, * 53) GO TO 20 10 CALL ERROR(35HMISSING OR ILLEGAL STATEMENT NUMBER, 35) 20 RETURN END C*** C SUBROUTINE IFST C*** SUBROUTINE IFST C C C ANALYZES IF STATEMENTS OF THE FORM C C IF EXPR1 REL. OP. EXPR2 THEN INTEGER C C..LOCAL VARIABLES INTEGER THEN(5) INTEGER EQUALS, GREAT, I, K, K1, K2, K4, LESS, LL, SPACE LOGICAL ERR, LTEMP, STRING C..FUNCTIONS INTEGER CODE, LTOINT LOGICAL CHKKEY, EATSP C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERREXP, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF INTEGER LVAR, IVAR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERREXP, VCODE, ENDEXP, SIMPST COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), STAREF(500,2) COMMON /CVAR/ LVAR, IVAR(376,2) DATA THEN(1), THEN(2), THEN(3), THEN(4), THEN(5) /29,17,14,23,4/ DATA GREAT, LESS, EQUALS, SPACE /46,45,39,44/ C FIRST NON-BLANK (START OF EXPR1) IN K1 C THEN LOOK FOR RELATIONAL OPERATOR NREF = 0 K1 = K3 K2 = K3 10 LL = LINE(K2) IF (LL.EQ.GREAT .OR. LL.EQ.EQUALS .OR. LL.EQ.LESS) GO TO 20 K2 = K2 + 1 IF (K2.GT.NLINE) GO TO 100 GO TO 10 C RELATIONAL FOUND - ANALYZE EXPRESSION 1 (K2-1 IS PREVIOUS C CHARACTER TO REL. OP.) 20 K2 = K2 - 1 CALL EXPRES(K1, K2, -1, .TRUE.) C SAVE SIMPST STRING = SIMPST .AND. LL.EQ.EQUALS LTEMP = EATSP(K2+2,K3) IF (-1.EQ.K3) GO TO 100 IF (LL.EQ.EQUALS) GO TO 50 C NOW CHECK FOR SECOND OPERATOR IF (LL.NE.GREAT) GO TO 30 C COULD HAVE EQUALS FOLLOWING IF (LINE(K3).EQ.EQUALS) GO TO 40 C COULD HAVE EQUALS OR GREATER FOLLOWING LESS 30 IF (LINE(K3).NE.EQUALS .AND. LINE(K3).NE.GREAT) GO TO 50 C IF SIMPLE STRING THEN REQUIRE EITHER EQUALITY OR NON-EQUALITY STRING = (LL.EQ.LESS .AND. LINE(K3).EQ.GREAT .AND. SIMPST) .OR. * (STRING) C SECOND OPERATOR HAS BEEN FOUND - OUTPUT ERROR MESSAGE IF SPACES C EXIST WITHIN THE OPERATOR (LTEMP) 40 IF (LTEMP) CALL * ERROR( * 58HSPACES NOT ALLOWED WITHIN MULTICHARACTER RELATIONAL SYMBOL, * 58) C SET K3 FOR START OF NEW EXPRESSION - TEST FOR FOLLOWING SPACE K3 = K3 + 1 C LOOK FOR THEN KEYWORD - K1 IS START OF EXPR2 50 K1 = K3 K2 = K3 IF (.NOT.CHKKEY(THEN,THEN(5),K2,K4)) GO TO 100 C ANALYZE EXPR2 CALL EXPRES(K1, K2-1, -1, .TRUE.) C FINISH LEGAL STRING COMPARISON CHECK C IF STRING AND SIMPST BOTH TRUE OR BOTH FALSE THEN LEGAL STRING IF ((STRING .AND. SIMPST) .OR. ((.NOT.STRING) .AND. * (.NOT.SIMPST))) GO TO 60 CALL ERROR(25HILLEGAL STRING EXPRESSION, 25) C ADD REFERENCES TO CHAIN 60 IF (NREF.NE.0) GO TO 70 CALL ERROR(48HWARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS, * 48) GO TO 90 70 DO 80 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 80 CONTINUE C CHECK SPACES EITHER SIDE OF THEN BUT NONE INSIDE 90 IF (K4+1.GT.NLINE) GO TO 100 LTEMP = EATSP(K4+1,K3) IF (LINE(K2-1).NE.SPACE .OR. (.NOT.LTEMP)) CALL * ERROR(38HSPACES MUST PRECEDE AND FOLLOW KEYWORD, 38) IF (K4-K2+1.NE.THEN(5)) CALL * ERROR(33HSPACES NOT ALLOWED WITHIN KEYWORD, 33) C SPACES ALREADY EATEN BY EATSP ABOVE JCODE MUST BE 1 NOW IF (CODE(K3).NE.1) GO TO 110 CALL INTEG(ERR) IF (ERR) CALL ERROR(38HSPACES NOT ALLOWED IN STATEMENT NUMBER, 38) C CHECK AT END OF STATEMENT IF (-1.NE.K3) CALL * ERROR(47HEXTRANEOUS INFORMATION FOLLOWS STATEMENT NUMBER, 47) C ADD INTEGER TO CHAIN AND EXIT (SUCCESSFULLY) C CHECK TRANSFER IS LEGAL K1 = LTOINT(K) CALL ADDSTA(K1) CALL CHKREF(LABENO, K1) GO TO 120 C ERROR EXITS C 1) SYNTAX ERROR IN STATEMENT 100 CALL ERROR(25HSYNTAX ERROR IN STATEMENT, 25) GO TO 120 C 2) STATEMENT NUMBER DOES NOT FOLLOW THEN 110 CALL ERROR(33HSTATEMENT NUMBER MUST FOLLOW THEN, 33) 120 RETURN END C*** C SUBROUTINE INREAD C*** SUBROUTINE INREAD C C ANALYSES INPUT AND READ STATEMENTS C C..LOCAL VARIABLES INTEGER COMMA, I, K1, K2, LPAREN, OPEN, RPAREN LOGICAL ERR1, LTEMP C..FUNCTIONS INTEGER CODE LOGICAL EATSP C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER NTOK, LTOK, TOKEN INTEGER LVAR, IVAR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) COMMON /CVAR/ LVAR, IVAR(376,2) DATA LPAREN, RPAREN, COMMA /41,38,59/ NREF = 0 C GET A VARIABLE FROM THE LIST 10 K1 = K3 ERR1 = .FALSE. ENDEXP = NLINE CALL NEXTOK C TEST IF LEGAL - IF DOESNOT START WITH A LETTER GIVE UP IF (TCODE.NE.2) GO TO 110 IF (TYPE.EQ.1 .OR. TYPE.EQ.2 .OR. TYPE.EQ.3) GO TO 20 C ILLEGAL VARIABLE FLUSH TO NEXT TOP LEVEL COMMA CALL ERROR(35HILLEGAL VARIABLE IN INPUT/READ LIST, 35) K2 = K1 ERR1 = .TRUE. OPEN = 0 GO TO 30 C DEAL WITH SUBSCRIPT ETC 20 IF (TOKEN(NTOK).NE.LPAREN) GO TO 70 OPEN = 1 K2 = K3 - 1 C FLUSH TO NEXT TOP LEVEL COMMA 30 K2 = K2 + 1 IF (OPEN.NE.0) GO TO 40 IF (K2.GT.NLINE) GO TO 50 IF (LINE(K2).EQ.COMMA) GO TO 50 C COMMA NOT FOUND - TEST FOR OPENING AND CLOSING BRACKETS 40 IF (K2.GT.NLINE) GO TO 100 IF (LINE(K2).EQ.LPAREN) OPEN = OPEN + 1 IF (LINE(K2).EQ.RPAREN) OPEN = OPEN - 1 GO TO 30 C FOUND - IF NO ERROR FLAG SET THEN ANALYZE EXPRESSION FROM START (K1) C SUBSCRIPTED VARIABLE IS THUS ADDED TO LIST 50 IF (ERR1) GO TO 60 CALL EXPRES(K1, K2-1, -1, .FALSE.) 60 LTEMP = EATSP(K2,K3) IF (-1.EQ.K3) GO TO 120 GO TO 80 C SIMPLE VARIABLE ADD TO REF AND CHECK SPACES 70 CALL REFCHK IF (ERR) CALL * ERROR(37HSPACES NOT PERMITTED IN VARIABLE NAME, 37) IF (K3.GT.NLINE) GO TO 120 C NEXT SHOULD BE A COMMA - ELSE FLUSH TO NEXT TOP LEVEL COMMA 80 IF (LINE(K3).EQ.COMMA) GO TO 90 C OTHERWISE FLUSH TO COMMA CALL ERROR(32HSYNTAX ERROR FLUSH TO NEXT COMMA, 32) K2 = K3 ERR1 = .TRUE. OPEN = 0 GO TO 30 C GET NEXT NON-BLANK - CANNOT BE END OF LINE 90 LTEMP = EATSP(K3+1,K3) IF (-1.EQ.K3) GO TO 110 JCODE = CODE(K3) GO TO 10 C ERRORS C 1) SYNTAX ERRORS 100 K3 = K2 110 CALL ERROR(40HSYNTAX ERROR - REST OF STATEMENT IGNORED, * 40) 120 IF (NREF.EQ.0) GO TO 140 DO 130 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 130 CONTINUE 140 RETURN END C*** C SUBROUTINE INSTAT C*** SUBROUTINE INSTAT C C INSTAT READS IN A STATEMENT ,CHECKS FOR END OF INPUT, C OUTPUTS THE STATEMENT,CODES THE STATEMENT AND OUTPUTS C ANY ERROR MESSAGES CONCERNING NON-STANDARD CHARACTERS C C..LOCAL VARIABLES INTEGER I, IDOT, MXLIN1, SPACE LOGICAL ERR C..FUNCTIONS INTEGER CODECH C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER NIN, NOUT, NTAB LOGICAL ENDIN INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CIO/ NIN, NOUT, NTAB, ENDIN COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE DATA IDOT, SPACE /1H.,44/ C C END OF INFORMATION IS DENOTED BY A . IN COLUMN 1 C MOST VERSIONS OF FORTRAN ALLOW THIS RESTRICTION TO BE LIFTED C BY THE USE OF AN EXTENDED READ STATEMENT OF THE FORM C C 10 READ(NIN,99999,END=40)LINE C 10 READ (NIN,99999) LINE IF (LINE(1).EQ.IDOT) GO TO 40 WRITE (NOUT,99998) LINE C UP STATEMENT COUNTER NLINE = 0 ERR = .FALSE. NUMST = NUMST + 1 C CODE LINE - KEEP LAST NON-BLANK POSITION IN NLINE C NOTE NON-STANDARD CHARACTERS ARE TREATED AS BLANKS DO 20 I=1,MAXLIN LINE(I) = CODECH(LINE(I),ERR) IF (LINE(I).NE.SPACE) NLINE = I C TEST NON-STANDARD CHARACTER IF (.NOT.ERR) GO TO 20 K3 = I CALL ERROR(41HSTATEMENT CONTAINS NON-STANDARD CHARACTER, * 41) ERR = .FALSE. 20 CONTINUE MXLIN1 = MAXLIN + 1 DO 30 I=MXLIN1,LLINE IF (CODECH(LINE(I),ERR).EQ.SPACE) GO TO 30 CALL * ERROR(44HNON-BLANK CHARACTERS OCCUR AFTER POSITION 72, * 44) GO TO 50 30 CONTINUE C TEST FOR BLANK LINE IF (NLINE.NE.0) GO TO 50 CALL ERROR(39HBLANK LINE ENCOUNTERED IN INPUT-IGNORED, 39) GO TO 10 C SET ENDIN FLAG 40 ENDIN = .TRUE. 50 RETURN 99999 FORMAT (80A1) 99998 FORMAT (1H , 80A1) END C*** C SUBROUTINE INTEG C*** SUBROUTINE INTEG(ERR) C C LINE(K3) CONTAINS A DIGIT C INTEG SCANS A LINE UNTIL A NON-DIGIT IS FOUND C C ON EXIT C ERR = .TRUE. IF SPACES OCCUR WITHIN THE DIGIT STRING C = .FALSE. OTHERWISE C C K3 AND JCODE ARE THE POSITION AND CODE RESPECTIVELY C OF THE NEXT NON-BLANK CHARACTER C C..ARGUMENTS LOGICAL ERR C..LOCAL VARIABLES INTEGER K1 LOGICAL SPACE C..FUNCTIONS INTEGER CODE LOGICAL EATSP C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NTOK, LTOK, TOKEN COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) C INITIALIZE ERR = .FALSE. SPACE = .FALSE. NTOK = 1 TOKEN(NTOK) = LINE(K3) C LOOK FOR NEXT NON-BLANK 10 K1 = K3 + 1 IF (EATSP(K1,K3)) SPACE = .TRUE. IF (-1.EQ.K3) GO TO 30 C IF LINE(K3) NOT A DIGIT THEN EXIT IF (CODE(K3).NE.1) GO TO 20 C DIGIT FOUND NTOK = NTOK + 1 TOKEN(NTOK) = LINE(K3) IF (SPACE) ERR = .TRUE. GO TO 10 20 JCODE = CODE(K3) 30 RETURN END C*** C SUBROUTINE LETST C*** SUBROUTINE LETST C C ANALYZE LET STATEMENT C C..LOCAL VARIABLES INTEGER EQUALS, I, K1, K2, LPAREN LOGICAL STRING C..COMMON BLOCKS INTEGER ARPOS, ARSTAK, DLPREQ, LARST, LPOPEN, NEXT1 INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER NTOK, LTOK, TOKEN INTEGER LVAR, IVAR COMMON /CARFUN/ LARST, ARSTAK(40,3), NEXT1, LPOPEN, * DLPREQ, ARPOS COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) COMMON /CVAR/ LVAR, IVAR(376,2) DATA LPAREN, EQUALS /41,39/ C GET L.H.S ENDEXP = NLINE CALL NEXTOK STRING = .FALSE. NREF = 0 C TEST IF LEGAL L.H.S IF (TCODE.NE.2 .OR. TYPE.GT.3 .OR. TYPE.LT.0) CALL * ERROR(38HNON-ANSI L.H.S IN ASSIGNMENT STATEMENT, 38) IF (TCODE.EQ.2 .AND. TYPE.LE.3) GO TO 10 K3 = K3 - 1 GO TO 50 C ADD TO REFERENCE CHAIN 10 IF (VCODE.NE.0) CALL REFCHK IF (IABS(TYPE).NE.2) GO TO 20 IF (TYPE.EQ.2) STRING = .TRUE. C IF STRING ARRAY ANALYZE SUBSCRIPTS IF (TOKEN(NTOK).NE.LPAREN) GO TO 40 GO TO 30 C COME HERE IF NUMERICAL ARRAY 20 IF (IABS(TYPE).NE.3) GO TO 40 30 K1 = K3 K2 = NLINE NEXT1 = 1 LPOPEN = 1 CALL ARWIND(.FALSE.) CALL EXPRES(K1, K2, 1, .FALSE.) C TEST IF END OF LINE IF (-1.EQ.K3) GO TO 70 C FINISHED L.H.S = SHOULD BE NEXT CHARACTER 40 IF (LINE(K3).EQ.EQUALS) GO TO 60 C NO - SCAN FOR EQUALS IN THE HOPE OF RECOVERING CALL ERROR(36HDELIMITER = NOT FOUND WHERE EXPECTED, 36) 50 K3 = K3 + 1 IF (K3.GT.NLINE) GO TO 80 IF (LINE(K3).NE.EQUALS) GO TO 50 CALL ERROR(22HCHECKING RESTARTS AT =, 22) C CHECK EXPRESSION ON R.H.S 60 K1 = K3 + 1 K2 = NLINE CALL EXPRES(K1, K2, -1, .TRUE.) C ILLEGAL USE OF STRING VARIABLE IF ((STRING .AND. (.NOT.SIMPST)) .OR. (.NOT.STRING .AND. * SIMPST)) CALL ERROR(22HILLEGAL USE OF STRINGS, 22) GO TO 90 C ERROR EXITS C 2) DELIMITER MISSING 70 CALL * ERROR(47HDELIMITER = MISSING - REST OF STATEMENT IGNORED, * 47) GO TO 90 C 3) UNRECOVERABLE 80 CALL ERROR(41HUNRECOVERABLE - REST OF STATEMENT IGNORED, * 41) C ADD REFERENCES TO CHAIN 90 IF (NREF.EQ.0) GO TO 110 DO 100 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 100 CONTINUE 110 RETURN END C*** C INTEGER FUNCTION LTOINT C*** INTEGER FUNCTION LTOINT(K) C C FUNCTION RETURNS VIA ITS NAME AND ARGUMENT K C THE INTEGER VALUE OF THE LABEL STORED IN TOKEN(1-NTOK) C C..ARGUMENTS INTEGER K C..LOCAL VARIABLES INTEGER I C..COMMON BLOCKS INTEGER NTOK, LTOK, TOKEN COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) C INITIALIZE K K = TOKEN(1) IF (NTOK.EQ.1) GO TO 20 DO 10 I=2,NTOK K = 10*K + TOKEN(I) 10 CONTINUE 20 LTOINT = K RETURN END C*** C SUBROUTINE NEXT C*** SUBROUTINE NEXT C C ANALYZE NEXT STATEMENT C C..LOCAL VARIABLES INTEGER I, J, K C..COMMON BLOCKS INTEGER LDO, DOPEN, DOSPEC INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER LVAR, IVAR COMMON /CDO/ LDO, DOPEN, DOSPEC(30) COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CVAR/ LVAR, IVAR(376,2) C CHECK THAT AT LEAST ONE FOR LOOP IS OPEN IF (DOPEN.EQ.0) GO TO 60 C GET NEXT TOKEN - SEARCH SHOULD BE COMPLETED AT END OF LINE ENDEXP = NLINE CALL NEXTOK C CHECK CORRECT TYPE - SIMPLE VARIABLE IF (TYPE.NE.1 .OR. TCODE.NE.2) GO TO 50 C O.K. ADD VARIABLE REFERENCE TO CHAIN CALL ADDREF(IVAR, LVAR, LABENO, VCODE) C OUTPUT SPACES ERROR IF (ERR) CALL ERROR(37HSPACES NOT PERMITTED IN VARIABLE NAME, 37) C CHECK AT END OF LINE IF (K3.NE.ENDEXP+1) CALL * ERROR(32HEXTRANEOUS END TO NEXT STATEMENT, 32) C CHECK VARIABLE CLOSES LAST OPENED FOR LOOP IF (VCODE.NE.DOSPEC(DOPEN)) GO TO 20 DOPEN = DOPEN - 1 C BACKTRACK UP COLUMN 2 OF ARRAY FORNXT LOOKING FOR FIRST ZERO K = NFOR + 1 10 K = K - 1 IF (FORNXT(K,2).NE.0) GO TO 10 FORNXT(K,2) = LABENO GO TO 70 C NO MATCH LOOK FOR MATCH FURTHER DOWN THE ARRAY 20 CALL ERROR(38HFOR-NEXT STATEMENTS INCORRECTLY NESTED, 38) ABNFOR = .TRUE. IF (DOPEN.LT.2) GO TO 70 DO 30 I=2,DOPEN J = DOPEN + 1 - I IF (DOSPEC(J).EQ.VCODE) GO TO 40 30 CONTINUE C NO MATCH RETURN GO TO 70 C MATCH FOUND UNWIND DOSPEC TO THAT POINT 40 DOPEN = J GO TO 70 C ERROR EXITS C 1)NOT A SIMPLE VARIABLE 50 CALL * ERROR( * 56HONLY SIMPLE NUMERIC VARIABLE MAY OCCUR IN NEXT STATEMENT, 56) ABNFOR = .TRUE. GO TO 70 C 2)NO FOR LOOPS OPEN 60 CALL ERROR(26HNEXT FOUND BUT NO FOR OPEN, 26) ABNFOR = .TRUE. 70 RETURN END C*** C SUBROUTINE NEXTOK C*** SUBROUTINE NEXTOK C C ROUTINE NEXTOK GETS THE NEXT TOKEN, CLASIFIES IT AND PLACES C IT IN TOKEN C C TCODE= 1(NUMBER), 2(ALPHANUMERIC), 3(NON-ALPHANUMERIC) C TYPE C NUMBER 1(INTEGER), 2(REAL), -1(ERROR) C ALPHANUMERIC 1(SIMPLE VARIABLE), 2(STRING), 3(SUBSCRIPTED NUMERIC) C 4(USER DEFINED FUNCTION), 5(STANDARD FUNCTION) C -1(ILLEGAL SIMPLE VARIABLE) C -2(ILLEGAL STRING VAR/ARRAY/FUNCTION) C -3(ILLEGAL FUNCTION/ARRAY) C C C..LOCAL VARIABLES INTEGER DOLLAR, K2, LPAREN, PERIOD, SPACE LOGICAL LTEMP C..FUNCTIONS INTEGER CODE, CODVAR LOGICAL EATSP C..COMMON BLOCKS LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NTOK, LTOK, TOKEN COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) DATA SPACE, PERIOD, DOLLAR, LPAREN /44,40,51,41/ C IT IS ASSUMED NEXT NON-BLANK IS IN K3 CODE = JCODE C INITIALIZATION NTOK = 1 VCODE = 0 TOKEN(NTOK) = LINE(K3) ERR = .FALSE. C JCODE = 3 IF (JCODE.NE.3) GO TO 10 C IF A PERIOD THEN PICK UP NUMBER IF (LINE(K3).EQ.PERIOD) GO TO 20 C RESET K3 AND JCODE TCODE = 3 GO TO 210 C NEXT TOKEN A NUMBER 10 IF (JCODE.NE.1) GO TO 30 20 CALL NUMBER(TYPE, ERR) TCODE = 1 GO TO 220 C ALPHABETIC CHARACTER 30 LTEMP = .FALSE. TCODE = 2 C PICK UP ALPHANUMERIC STRING 40 K3 = K3 + 1 IF (K3.GT.ENDEXP) GO TO 100 C IGNORE SPACES IF (LINE(K3).NE.SPACE) GO TO 50 LTEMP = .TRUE. GO TO 40 C EXIT FROM ALPHA STRING IF CODE=3 50 IF (CODE(K3).EQ.3) GO TO 60 C ELSE ADD INTO TOKEN AND SET ERR IF SPACES IF (LTEMP) ERR = .TRUE. NTOK = NTOK + 1 TOKEN(NTOK) = LINE(K3) GO TO 40 C EXIT HERE WHEN ALPHA STRING FINISHED C TEST IF DOLLAR FOLLOWS - STRING 60 IF (LINE(K3).NE.DOLLAR) GO TO 90 C IF SPACES BETWEEN CHARACTER AND DOLLAR THEN ERROR IF (LTEMP) ERR = .TRUE. NTOK = NTOK + 1 TOKEN(NTOK) = DOLLAR C GET NEXT NON-BLANK 70 K3 = K3 + 1 IF (K3.GT.ENDEXP) GO TO 80 C CAN IGNORE SPACES HERE IF (LINE(K3).EQ.SPACE) GO TO 70 C TEST IF OPENING BRACKET IF (LINE(K3).NE.LPAREN) GO TO 80 C YES - ILLEGAL STRING ARRAY OR FUNCTION NTOK = NTOK + 1 TOKEN(NTOK) = LPAREN GO TO 150 C IF NOT CHECK LENGTH FOR LEGAL STRING C ADJUST K3 FOR EXIT 80 K3 = K3 - 1 C IF NTOK.GT.2 THEN ILLEGAL STRING IF (NTOK-2) 170, 170, 150 C NO DOLLAR LOOK FOR AN OPENING BRACKET 90 IF (LINE(K3).EQ.LPAREN) GO TO 120 C LOOK FOR SIMPLE VARIABLE - ADJUST K3 HERE 100 K3 = K3 - 1 C SIMPLE VARIABLE (LENGTH.LE.2) C FUNCTION CHECK (LENGTH.EQ.3) C ILLEGAL VARIABLE (LENGTH.GT.3) COULD BE AN ILLEGAL FUNCTION C WITH NO ARGUMENT IF (NTOK-3) 110, 130, 140 C TEST SIMPLE VARIABLE 110 VCODE = CODVAR(1) C VCODE=0 TYPE=-1 ILLEGAL VARIABLE IF (VCODE.EQ.0) GO TO 140 C OTHERWISE OUT TYPE = 1 GO TO 210 C OPENING BRACKET - ADD INTO TOKEN 120 NTOK = NTOK + 1 TOKEN(NTOK) = LPAREN C NUMERICAL ARRAY IF (NTOK.EQ.2) GO TO 180 C ILLEGAL FUNCTION OR ARRAY IF (NTOK.NE.4) GO TO 160 C CHECK IF USER DEFINED OR STANDARD FUNCTION 130 VCODE = CODVAR(5) C STANDARD FUNCTION EXIT IF (VCODE.NE.0) GO TO 200 C TRY USER DEFINED VCODE = CODVAR(4) C EXIT EITHER WITH CODE OR ILLEGAL IF (VCODE) 160, 160, 190 C ILLEGAL NUMERICAL VARIABLE 140 TYPE = -1 GO TO 210 C ILLEGAL STRING 150 TYPE = -2 GO TO 210 C ILLEGAL ARRAY/FUNCTION NUMERICAL 160 TYPE = -3 GO TO 210 C LEGAL STRING 170 TYPE = 2 VCODE = CODVAR(2) GO TO 210 C LEGAL ARRAY 180 TYPE = 3 VCODE = CODVAR(3) GO TO 210 C USER FUNCTION 190 TYPE = 4 GO TO 210 C STANDARD FUNCTION 200 TYPE = 5 210 K2 = K3 + 1 LTEMP = EATSP(K2,K3) 220 IF (-1.NE.K3) GO TO 230 K3 = ENDEXP + 1 GO TO 240 230 JCODE = CODE(K3) 240 RETURN END C*** C SUBROUTINE NUMBER C*** SUBROUTINE NUMBER(TYPE, ERR) C C START WITH LINE(K3) EITHER A PERIOD OR A DIGIT C AND SCAN LINE UNTIL A COMPLETE NUMERICAL CONSTANT C HAS BEEN FOUND C C RETURN K3 AND JCODE AS POSITION AND CODE OF NEXT C NON-BLANK CHARACTER C C ERR = .FALSE. IF NO BLANKS IN CONSTANT C = .TRUE. IF BLANKS PRESENT C C TYPE = 1 FOR INTEGER C = 2 FOR REAL C = -1 FOR ERROR C C..ARGUMENTS INTEGER TYPE LOGICAL ERR C..LOCAL VARIABLES INTEGER E, K, K1, MAXEXP, MINUS, PERIOD, PLUS LOGICAL LSPACE C..FUNCTIONS INTEGER CODE, LTOINT LOGICAL EATSP C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE DATA PERIOD, E, PLUS, MINUS, MAXEXP /40,14,36,37,38/ LSPACE = .FALSE. ERR = .FALSE. TYPE = 1 C TEST IF PERIOD IF (LINE(K3).NE.PERIOD) GO TO 10 C NEXT CHARACTER MUST BE A DIGIT ELSE ERROR TYPE = 2 K1 = K3 + 1 IF (EATSP(K1,K3)) LSPACE = .TRUE. IF (-1.EQ.K3) GO TO 40 IF (CODE(K3).NE.1) GO TO 40 C EAT DIGITS 10 IF (LSPACE) ERR = .TRUE. CALL INTEG(LSPACE) IF (LSPACE) ERR = .TRUE. C END OF LINE RETURN EITHER INTEGER OR .INTEGER IF (-1.EQ.K3) GO TO 50 C TEST FOR PERIOD (40) IF (LINE(K3).NE.PERIOD) GO TO 20 C IF TYPE=2 THEN ERROR - TWO DECIMAL POINTS IN NUMBER IF (TYPE.EQ.2) GO TO 40 C NOT AN INTEGER TYPE = 2 K1 = K3 + 1 C LOOK FOR A DIGIT IF (EATSP(K1,K3)) LSPACE = .TRUE. IF (-1.EQ.K3) GO TO 50 C MAYBE AN EXPONENT IF (CODE(K3).NE.1) GO TO 20 C FRACTIONAL PART - EAT IT AND ANY OTHERS IF (LSPACE) ERR = .TRUE. CALL INTEG(LSPACE) IF (LSPACE) ERR = .TRUE. IF (-1.EQ.K3) GO TO 50 C IS EXPONENT PRESENT - IF NOT EXIT 20 IF (LINE(K3).NE.E) GO TO 50 C E FOUND TYPE = 2 K1 = K3 + 1 IF (EATSP(K1,K3)) LSPACE = .TRUE. C ERROR IF END OF LINE HERE IF (-1.EQ.K3) GO TO 40 C TEST FOR + OR - SIGN IF (LINE(K3).NE.PLUS .AND. LINE(K3).NE.MINUS) GO TO 30 C EAT SIGN IF PRESENT K1 = K3 + 1 IF (EATSP(K1,K3)) LSPACE = .TRUE. IF (-1.EQ.K3) GO TO 40 C LOOK FOR INTEGER EXPONENT 30 JCODE = CODE(K3) C ERROR IF NOT INTEGER IF (JCODE.NE.1) GO TO 40 C EAT EXPONENT IF (LSPACE) ERR = .TRUE. CALL INTEG(LSPACE) IF (LTOINT(K).GT.MAXEXP) CALL * ERROR( * 50HWARNING EXPONENT VALUE EXCEEDS MINIMAL REQUIREMENT, * 50) IF (LSPACE) ERR = .TRUE. GO TO 50 40 TYPE = -1 IF (-1.NE.K3) JCODE = CODE(K3) 50 RETURN END C*** C SUBROUTINE OCHAIN C*** SUBROUTINE OCHAIN(IST, IEND, ICODE) C..ARGUMENTS INTEGER ICODE, IEND, IST C..LOCAL VARIABLES INTEGER L INTEGER CH(3), TEMP(6) INTEGER J, K LOGICAL FIRST, ENDCH C..COMMON BLOCKS INTEGER LCHAIN, NCHAIN, CHAIN INTEGER NIN, NOUT, NTAB LOGICAL ENDIN COMMON /CCHAIN/ LCHAIN, NCHAIN, CHAIN(5000) COMMON /CIO/ NIN, NOUT, NTAB, ENDIN FIRST = .TRUE. ENDCH = .FALSE. 10 DO 30 J=1,6 K = J TEMP(K) = CHAIN(IST) IF (IST.NE.IEND) GO TO 20 ENDCH = .TRUE. GO TO 40 C PICK UP NEXT REFERENCE 20 IST = CHAIN(IST+1) 30 CONTINUE 40 IF (.NOT.FIRST) GO TO 50 FIRST = .FALSE. CALL DCODE(CH, ICODE) WRITE (NTAB,99999) (CH(L),L=1,3), (TEMP(L),L=1,K) GO TO 60 50 WRITE (NTAB,99998) (TEMP(L),L=1,K) C CHECK IF END OF CHAIN 60 IF (.NOT.ENDCH) GO TO 10 RETURN 99999 FORMAT (4X, 3A1, 8X, 1H-, 4X, 6I8) 99998 FORMAT (20X, 6I8) END C*** C SUBROUTINE ONSTAT C*** SUBROUTINE ONSTAT C C ROUTINE CHECKS ON - GOTO STATEMENT C C..LOCAL VARIABLES INTEGER GOKEY(5) INTEGER COMMA, I, IREF, JREF, K, K1, K2, K4, SPACE LOGICAL ERR, LSPACE, LTEMP C..FUNCTIONS INTEGER CODE, LTOINT LOGICAL CHKKEY, EATSP C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER LVAR, IVAR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CVAR/ LVAR, IVAR(376,2) DATA GOKEY(1), GOKEY(2), GOKEY(3), GOKEY(4), GOKEY(5) * /16,24,29,24,2/ DATA SPACE, COMMA /44,59/ C INITIALIZE LSPACE = .FALSE. ERR = .FALSE. NREF = 0 IREF = 0 C K3 HOLDS NEXT NON-BLANK K1 = K3 C LOOK FOR GOTO - NOTE CAN HAVE SPACES BETWEEN GO AND TO IF (.NOT.(CHKKEY(GOKEY,GOKEY(5),K1,K2))) GO TO 80 C FOUND IT - CHECK PRECEDED BY SPACE IF (LINE(K1-1).NE.SPACE) ERR = .TRUE. C CHECK LENGTH = 2 IF (K2-K1.NE.1) LSPACE = .TRUE. C EAT ANY SPACES BETWEEN GO AND TO K2 = K2 + 1 LTEMP = EATSP(K2,K4) C IF END OF LINE KEYWORD IS MISING IF (-1.EQ.K4) GO TO 80 C CHECK TO IS THERE IF (.NOT.(CHKKEY(GOKEY(3),GOKEY(5),K4,K2))) GO TO 80 C IF END OF LINE - NO STATEMENT LABELS IF (K2.EQ.NLINE) GO TO 90 C YES - CHECK SPACE AFTER IF (LINE(K2+1).NE.SPACE) ERR = .TRUE. C AND DOES NOT CONTAIN SPACES IF (K2-K4.NE.1) LSPACE = .TRUE. C CHECK EXPRESSION BETWEEN K3 AND K1-1 K4 = K3 CALL EXPRES(K4, K1-1, -1, .FALSE.) C ADD REFERENCES TO VARIABLES IN CHAIN IF (NREF.GT.0) GO TO 10 CALL * ERROR(46HWARNING - NO VARIABLE CONTROLLING ON STATEMENT, * 46) GO TO 30 10 DO 20 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 20 CONTINUE C REZERO NREF TO HOLD STATEMENT NUMBERS NREF = 0 C NOW OUTPUT ANY ERRORS CONCERNING KEYWORDS 30 IF (ERR) CALL * ERROR(38HSPACES MUST PRECEDE AND FOLLOW KEYWORD, 38) IF (LSPACE) CALL * ERROR(33HSPACES NOT ALLOWED WITHIN KEYWORD, 33) C COLLECT STATEMENT NUMBERS K2 = K2 + 1 40 LTEMP = EATSP(K2,K3) C ERROR IF END OF LINE HERE EITHER LINE ENDS IN COMMA OR C NO REFERENCES IF (-1.EQ.K3) GO TO 90 C NEXT NON-BLANK MUST BE NUMERIC IF (CODE(K3).NE.1) GO TO 100 C EAT INTEGER CALL INTEG(ERR) IF (ERR) CALL * ERROR(38HSPACES NOT ALLOWED IN STATEMENT NUMBER, 38) C TRANSLATE REFERENCE INTO DECIMAL FORM JREF = LTOINT(K) C CHECK TO SEE IF REFERENCE ALREADY EXISTS C NO REFERENCES YET IF (NREF.EQ.0) GO TO 60 C CHECK PRESENT LIST DO 50 I=1,NREF IF (REF(I).EQ.JREF) GO TO 70 50 CONTINUE C ADD TO END OF LIST 60 NREF = NREF + 1 REF(NREF) = JREF C CHECK FOR END OF LINE OR A COMMA C NOTE END OF LINE WOULD HAVE BEEN SET BY INTEG C THIS IS THE CLEAN EXIT 70 IF (-1.EQ.K3) GO TO 120 C TEST FOR COMMA IF (LINE(K3).NE.COMMA) GO TO 110 C GET NEXT STATEMENT NUMBER K2 = K3 + 1 GO TO 40 C ERROR EXITS C KEY WORD MISSING OR WRONG 80 CALL ERROR(31HKEYWORD MISSING OR NON-STANDARD, 31) GO TO 140 C STATEMENT NUMBER MISSING 90 IF (IREF.GT.0) GO TO 100 CALL ERROR(34HNO STATEMENT NUMBER FOLLOWING GOTO, 34) GO TO 140 C END WITH A COMMA 100 CALL ERROR(31HSTATEMENT NUMBER MUST FOLLOW , , 31) GO TO 120 C NO COMMA WHERE ONE EXPECTED 110 CALL ERROR(42HILLEGAL DELIMITER IN STATEMENT NUMBER LIST, * 42) C ADD REFERENCES TO CHAIN 120 DO 130 I=1,NREF CALL ADDSTA(REF(I)) CALL CHKREF(LABENO, REF(I)) 130 CONTINUE 140 RETURN END C*** C SUBROUTINE OPTSMT C*** SUBROUTINE OPTSMT C C CHECKS THE OPTION BASE STATEMENT C ON ENTRY K3 AND JCODE POINT TO THE NEXT NON-BLANK CHARACTER C C..LOCAL VARIABLES INTEGER BASE(5) INTEGER AEND, ASTART, I, K1, K2, ONE, SPACE, ZERO LOGICAL ERR C..FUNCTION LOGICAL EATSP, CHKKEY C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE LOGICAL DIMYET, OPTYET INTEGER OPTSET INTEGER LVAR, IVAR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /COPT/ DIMYET, OPTYET, OPTSET COMMON /CVAR/ LVAR, IVAR(376,2) DATA SPACE, ZERO, ONE, ASTART, AEND /44,0,1,313,338/ DATA BASE(1), BASE(2), BASE(3), BASE(4), BASE(5) * /11,10,28,14,4/ C IF JCODE .NE. 2 (LETTER) THEN KEYWORD IS NON-ANSI IF (JCODE.NE.2) GO TO 70 C CHECK BASE KEYWORD PRESENT K1 = K3 IF (.NOT.(CHKKEY(BASE,BASE(5),K1,K2))) GO TO 70 C OUTPUT ERROR FOR ENCLOSED BLANKS K3 = K2 IF (K3+1-K1.NE.BASE(5)) CALL ERROR(17HSPACES IN KEYWORD, * 17) C NO PARAMETER FOLLOWS IF (K2.EQ.NLINE) GO TO 30 K3 = K3 + 1 IF (LINE(K3).EQ.SPACE) GO TO 10 CALL ERROR(24HNO SPACE FOLLOWS KEYWORD, 24) GO TO 20 C EAT SPACES UP TO NEXT NON-BLANK 10 K1 = K3 + 1 ERR = EATSP(K1,K3) IF (-1.EQ.K3) GO TO 30 C TEST FOR CORRECT PARAMETER 20 IF (LINE(K3).EQ.ZERO .OR. LINE(K3).EQ.ONE) GO TO 40 30 CALL ERROR(41HILLEGAL OR MISSING PARAMETER IN STATEMENT, * 41) GO TO 80 C TEST AT END OF STATEMENT 40 IF (K3.NE.NLINE) GO TO 60 C HAVE A LEGAL OPTIONBASE STATEMENT - DO TESTS C 1) TEST IF THERE HAS BEEN A DIM STATEMENT PRIOR TO OPTION IF (DIMYET) CALL ERROR(28HOPTION STATEMENT FOLLOWS DIM, * 28) C 2) TEST IF THERE HAS ALREADY BEEN AN OPTION STATEMENT IF (OPTYET) CALL * ERROR(32HMULTIPLE USE OF OPTION STATEMENT, 32) OPTSET = LINE(K3) OPTYET = .TRUE. C 3) SEE IF OPTION STATEMENT FOLLOWS ARRAY REFERENCE C I.E. ARE ANY ELEMENTS OF IVAR(.,I) NON-ZERO DO 50 I=ASTART,AEND IF (IVAR(I,1).EQ.0) GO TO 50 CALL ERROR(40HOPTION STATEMENT FOLLOWS ARRAY REFERENCE, * 40) GO TO 80 50 CONTINUE C NO ARRAY REFERENCES - RETURN GO TO 80 60 CALL * ERROR( * 49HEXTRANEOUS INFORMATION FOLLOWING OPTION STATEMENT, 49) GO TO 80 70 CALL * ERROR(46HNON-STANDARD KEYWORD REST OF STATEMENT IGNORED, * 46) 80 RETURN END C*** C SUBROUTINE PRINT C*** SUBROUTINE PRINT C C ANALYZES PRINT STATEMENT C C..LOCAL VARIABLES INTEGER COMMA, I, K, K1, K2, LPAREN, OPEN, QUOTE, RPAREN, * SCOLON, SPACE, TABCOD LOGICAL ERR1 C..FUNCTIONS INTEGER CODE, QSTRG C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, CODVAR, VCODE, ENDEXP INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER NREF, REF INTEGER NTOK, LTOK, TOKEN INTEGER LVAR, IVAR COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CREFER/ NREF, REF(40) COMMON /CTOKEN/ LTOK, NTOK, TOKEN(72) COMMON /CVAR/ LVAR, IVAR(376,2) DATA QUOTE /48/ DATA COMMA, SCOLON, LPAREN, RPAREN, SPACE /59,56,41,38,44/ DATA TABCOD /376/ C PRINT STATEMENT MAY OCCUR ALONE IF (K3+1.GT.NLINE) GO TO 120 NREF = 0 IF (LINE(K3+1).NE.SPACE) CALL * ERROR(38HSPACES MUST PRECEDE AND FOLLOW KEYWORD, 38) C OTHERWISE EAT ALL SPACES, COMMAS AND SEMI-COLONS 10 K3 = K3 + 1 IF (K3.GT.NLINE) GO TO 100 IF (LINE(K3).EQ.SPACE .OR. LINE(K3).EQ.COMMA .OR. * LINE(K3).EQ.SCOLON) GO TO 10 C TEST FOR QUOTED STRING IF (LINE(K3).NE.QUOTE) GO TO 20 I = QSTRG(K) IF (-1.EQ.K .OR. (-1.EQ.K3)) GO TO 100 C NEXT MUST BE A PRINT DELIMITER - ELSE ERROR IF (LINE(K3).EQ.COMMA .OR. LINE(K3).EQ.SCOLON) GO TO 10 CALL ERROR(40HPRINT DELIMITER NOT FOUND WHERE EXPECTED, * 40) CALL ERROR(25HREST OF STATEMENT IGNORED, 25) C TEST FOR TAB FUNCTION 20 K1 = K3 JCODE = CODE(K3) IF (JCODE.NE.2) GO TO 30 ENDEXP = NLINE CALL NEXTOK IF (CODVAR(6).NE.TABCOD) GO TO 30 VCODE = TABCOD IF (ERR) CALL * ERROR(37HSPACES NOT PERMITTED IN FUNCTION NAME, 37) C SCAN TO MATCHING CLOSING BRACKETS TAB ARGUMENT = EXPRESSION CALL REFCHK K1 = NLINE K2 = K3 CALL EXPRES(K2, K1, 1, .FALSE.) C NOTE NOW K3 HOLDS NEXT NON-BLANK POSITION OR -1 C TAB MUST BE FOLLOWED BY COMMA, SEMI-COLON OR END OF LINE IF (-1.EQ.K3) GO TO 100 IF (LINE(K3).EQ.COMMA .OR. LINE(K3).EQ.SCOLON) GO TO 10 K2 = K3 - 1 CALL * ERROR(44HTAB FUNCTION MUST BE FOLLOWED BY A DELIMITER, * 44) CALL ERROR(29HFLUSH TO NEXT PRINT DELIMITER, 29) ERR1 = .TRUE. GO TO 40 C LOOK FOR NEXT DELIMITER AND ANALYZE CONTAINED EXPRESSION (NOT TAB) 30 K2 = K1 - 1 ERR1 = .FALSE. 40 OPEN = 0 C WANT NEXT COMMA OR SCOLON NOT IN PARENTHESES 50 K2 = K2 + 1 IF (OPEN.NE.0) GO TO 60 IF (K2.GT.NLINE) GO TO 70 IF (LINE(K2).EQ.COMMA .OR. LINE(K2).EQ.SCOLON) GO TO 70 C NOT FOUND - TEST IF OPENING OR CLOSING BRACKET 60 IF (K2.GT.NLINE) GO TO 90 IF (LINE(K2).EQ.LPAREN) OPEN = OPEN + 1 IF (LINE(K2).EQ.RPAREN) OPEN = OPEN - 1 GO TO 50 C FOUND - ANALYZE EXPRESSION IF ERR1 = .FALSE. ELSE SKIP 70 IF (ERR1) GO TO 80 CALL EXPRES(K1, K2-1, -1, .FALSE.) 80 K3 = K2 C EXIT IF AT END OF LINE IF (K2.GT.NLINE) GO TO 100 GO TO 10 C ERROR - MISMATCH PARENTHESES IN EXPRESSION 90 K3 = K2 CALL ERROR(26HSYNTAX ERROR IN EXPRESSION, 26) GO TO 100 C WRITE REFERENCES TO CHAIN 100 IF (NREF.EQ.0) GO TO 120 DO 110 I=1,NREF CALL ADDREF(IVAR, LVAR, LABENO, REF(I)) 110 CONTINUE 120 RETURN END C*** C INTEGER FUNCTION QSTRG C*** INTEGER FUNCTION QSTRG(K) C C K3 IS ASSUMED TO POINT AT THE OPENING QUOTE (48) C C ON EXIT C QSTRG=K=LENGTH OF STRING SET NEGATIVE IF ERROR OCCURS C K3 AND JCODE ARE THE POSITION AND CODE OF THE NEXT NON-BLANK C NULL STRING IS ANSI STANDARD C C..ARGUMENTS INTEGER K C..LOCAL VARIABLES INTEGER K1, QUOTE LOGICAL LTEMP C..FUNCTIONS INTEGER CODE LOGICAL EATSP C..COMMON BLOCKS INTEGER K3, JCODE INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CNXTCH/ K3, JCODE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) DATA QUOTE /48/ K = 0 10 K3 = K3 + 1 IF (K3.GT.NLINE) GO TO 20 C CHECK FOR CLOSING QUOTE IF (LINE(K3).EQ.QUOTE) GO TO 30 C OTHERWISE UPDATE LENGTH AND GET NEXT CHARACTER K = K + 1 GO TO 10 C ERROR EXIT 20 CALL ERROR(35HNO MATCHING CLOSING QUOTE IN STRING, 35) K = -1 K3 = -1 GO TO 40 30 K1 = K3 + 1 LTEMP = EATSP(K1,K3) IF (-1.EQ.K3) GO TO 40 JCODE = CODE(K3) 40 QSTRG = K RETURN END C*** C SUBROUTINE REFCHK C*** SUBROUTINE REFCHK C C ROUTINE CHECKS WHETHER VCODE OCCURS IN REF(1-NREF) C IF NOT IT IS ADDED IN C C..LOCAL VARIABLES INTEGER I C..COMMON BLOCKS LOGICAL ERR, SIMPST INTEGER TCODE, TYPE, VCODE, ENDEXP INTEGER NREF, REF COMMON /CEXPR/ TCODE, TYPE, ERR, VCODE, ENDEXP, SIMPST COMMON /CREFER/ NREF, REF(40) IF (NREF.EQ.0) GO TO 20 DO 10 I=1,NREF IF (REF(I).EQ.VCODE) GO TO 30 10 CONTINUE C REFERENCE DOES NOT OCCUR 20 NREF = NREF + 1 REF(NREF) = VCODE 30 RETURN END C*** C SUBROUTINE REM C*** SUBROUTINE REM C C ROUTINE DEALS WITH REM STATEMENTS C CHECK SPACE FOLLOWS KEYWORD UNLESS REM OCCURS ALONE ON C THE LINE. C NEGATE STATNO SO REFERENCES TO REM STATEMENTS MAY BE NOTED C C..LOCAL VARIABLES INTEGER K1 C..FUNCTIONS LOGICAL EATSP C..COMMON BLOCKS INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), * STAREF(500,2) C NEGATE PRESENT STATEMENT REFERENCE STATNO(NSTAT) = -STATNO(NSTAT) C CHECK IF REM ONLY APPEARS ON LINE K1 = K3 + 1 IF (K1.GT.NLINE) GO TO 10 C ELSE CHECK AT LEAST ONE SPACE IF (.NOT.EATSP(K1,K3)) CALL * ERROR(24HNO SPACES FOLLOW KEYWORD, 24) 10 RETURN END C*** C SUBROUTINE RSTEND C*** SUBROUTINE RSTEND(CLASS) C C ROUTINE FOR END (CODE 4), RANDOMIZE (CODE 15), RESTORE (CODE 18), C RETURN (CODE 19), AND STOP (CODE 20) STATEMENTS. K3 (IN CNXTCH) C GIVES THE POSITION IN THE ARRAY LINE OF THE LAST CHARACTER C OF THE KEYWORD. THIS SHOULD EQUAL NLINE FOR THE FOUR CASES C TESTED HERE. C C..ARGUMENTS INTEGER CLASS C..COMMON BLOCKS INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR INTEGER LLINE, NLINE, MAXLIN, LINE INTEGER K3, JCODE COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) COMMON /CNXTCH/ K3, JCODE C IF END STATEMENT SET ENDERR TRUE IF (CLASS.EQ.4) ENDERR = .TRUE. C K3 SHOULD BE EQUAL TO NLINE FOR THESE 4 CASES IF (K3.EQ.NLINE) GO TO 10 C OTHERWISE OUTPUT ERROR MESSAGES FOR EXTRANEOUS END OF STATEMENT IF (CLASS.EQ.4) CALL * ERROR(46HEXTRANEOUS INFORMATION FOLLOWING END STATEMENT, * 46) IF (CLASS.EQ.15) CALL * ERROR( * 52HEXTRANEOUS INFORMATION FOLLOWING RANDOMIZE STATEMENT, * 52) IF (CLASS.EQ.18) CALL * ERROR( * 50HEXTRANEOUS INFORMATION FOLLOWING RESTORE STATEMENT, * 50) IF (CLASS.EQ.19) CALL * ERROR( * 49HEXTRANEOUS INFORMATION FOLLOWING RETURN STATEMENT, 49) IF (CLASS.EQ.20) CALL * ERROR(47HEXTRANEOUS INFORMATION FOLLOWING STOP STATEMENT, * 47) 10 RETURN END C** C SUBROUTINE SYSERR C** SUBROUTINE SYSERR(IERROR) C C TERMINAL ERRORS CAUSED BY ARRAY OVERFLOWS C IF THESE ERRORS OCCUR THE OFFENDING ARRAY MUST BE LENGTHENED C IN THE CORRESPONDING COMMON BLOCK IN ALL PARTS OF THE PROGRAM C THE VALUE OF THE MAXIMUM LENGTH OF THIS ARRAY MUST ALSO BE C CHANGED IN THE MAIN PROGRAM. C C..ARGUMENTS INTEGER IERROR C THE FOLLOWING STATEMENT IS NECESSARY TO SURPRESS ERROR C MESSAGES FROM THE IBM H-EXTENDED (ENHANCED) COMPILER C WHICH OBJECTS TO EITHER NO RETURN STATEMENT OR AN C UNLABELLED RETURN FOLLOWING THE STOP. C N.B. THE CONDITION I=0 CANNOT OCCUR IF(I.EQ.0)GOTO 90 CALL ERROR(26H******TERMINAL ERROR******, 26) GO TO (10, 20, 30, 40, 50, 60, 70), IERROR 10 CALL ERROR(39HARRAY STATNO OVERFLOW IN ROUTINE ADDSTA, 39) GO TO 80 20 CALL ERROR(38HARRAY CHAIN OVERFLOW IN ROUTINE ADDREF, 38) GO TO 80 30 CALL ERROR(38HARRAY DOSPEC OVERFLOW IN ROUTINE FORST, 38) GO TO 80 40 CALL ERROR(39HARRAY STATNO OVERFLOW IN ROUTINE CHKLAB, 39) GO TO 80 50 CALL ERROR(38HARRAY JUMPS OVERFLOW IN ROUTINE UPJUMP, 38) GO TO 80 60 CALL ERROR(38HARRAY FORNXT OVERFLOW IN ROUTINE FORST, 38) GO TO 80 70 CALL ERROR(39HARRAY ARSTAK OVERFLOW IN ROUTINE ARWIND, 39) 80 STOP 90 RETURN END C*** C SUBROUTINE TIDYUP C*** SUBROUTINE TIDYUP C C TIDY UP LOOSE ENDS AND OUTPUT STATISTICS C C..LOCAL VARIABLES INTEGER CH(3) INTEGER I, IST, ISUBS, J, KEYARR, KEYSNV LOGICAL ONE C..FUNCTIONS LOGICAL CHKFOR C..COMMON BLOCKS INTEGER LDO, DOPEN, DOSPEC INTEGER NUMST, NUMERR, LABENO LOGICAL ENDERR, LABERR LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS INTEGER NIN, NOUT, NTAB LOGICAL ENDIN LOGICAL DIMYET, OPTYET INTEGER OPTSET INTEGER ARRDIM, ARRSUB, ISFUN, FARG INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF INTEGER LVAR, IVAR COMMON /CDO/ LDO, DOPEN, DOSPEC(30) COMMON /CERROR/ NUMST, NUMERR, ENDERR, LABENO, LABERR COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR COMMON /CIO/ NIN, NOUT, NTAB, ENDIN COMMON /COPT/ DIMYET, OPTYET, OPTSET COMMON /CSARG/ ARRDIM(26,2), ARRSUB(26), ISFUN(11,3), * FARG(26) COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), * STAREF(500,2) COMMON /CVAR/ LVAR, IVAR(376,2) C CHECK PROGRAM CONTAINED AN END STATEMENT . C N.B. ERROR MESSAGE ALREADY IF STATEMENTS FOLLOW AN END IF (.NOT.ENDERR) CALL * ERROR(41HPROGRAM DOES NOT CONTAIN AN END STATEMENT, 41) C CHECK IF OPTION STATEMENT HAS BEEN USED THAT OPTION BASE 1 C DOES NOT OCCUR WITH A ZERO DIMENSIONING IF (OPTSET.NE.1) GO TO 30 DO 20 I=1,26 C POSITIVE VALUE IN ARRSUB(I) INDICATES REFERENCE IN DIM STAT IF (ARRSUB(I).LE.0 .OR. ARRSUB(I).GT.2) GO TO 20 C CHECK SUBSCRIPTS ISUBS = ARRSUB(I) DO 10 J=1,ISUBS IF (ARRDIM(I,J).EQ.0) CALL * ERROR( * 48HARRAY DIMENSIONED LENGTH ZERO WITH OPTION BASE 1, * 48) 10 CONTINUE 20 CONTINUE C CHECK THAT THERE ARE NO CLASHES OF ARRAY AND SIMPLE C NUMERIC VARIABLE NAMES. C ARRAY CODES ARE 313-338 (INC.) C SIMPLE NUMERIC VARIABLES 1 TO 276 STEP 11 30 KEYSNV = 1 KEYARR = 313 ONE = .FALSE. DO 60 I=1,26 IF (IVAR(KEYSNV,1).EQ.0 .OR. IVAR(KEYARR,1).EQ.0) GO TO * 50 C CLASH FOUND - IF FIRST ONE THEN OUTPUT TITLE IF (ONE) GO TO 40 ONE = .TRUE. WRITE (NOUT,99998) 40 CALL DCODE(CH, KEYSNV) WRITE (NOUT,99994) CH 50 KEYSNV = KEYSNV + 11 KEYARR = KEYARR + 1 60 CONTINUE C CHECK ALL FORWARD REFERENCES HAVE OCCURRED IF (-1.EQ.BNSTAT) GO TO 70 WRITE (NOUT,99997) IST = LSTAT - BNSTAT WRITE (NOUT,99996) (STATNO(I),I=IST,LSTAT) C CHECK NO ILLEGAL TRANSFER INTO FOR BLOCKS 70 IF (.NOT.ABNFOR) GO TO 80 WRITE (NOUT,99991) GO TO 110 C FOR BLOCK TRANSFER CHECKS 80 ONE = .FALSE. IF (NJUMP.EQ.0) GO TO 110 DO 100 I=1,NJUMP IF (CHKFOR(.FALSE.,JUMPS(I,1),JUMPS(I,2))) GO TO 100 C ILLEGAL JUMP IF (ONE) GO TO 90 C OUTPUT TITLE WRITE (NOUT,99990) ONE = .TRUE. 90 WRITE (NOUT,99999) JUMPS(I,1), JUMPS(I,2) 100 CONTINUE C CHECK ALL FOR STATEMENTS HAVE MATCHING NEXT 110 IF (DOPEN.EQ.0) GO TO 130 WRITE (NOUT,99995) DO 120 I=1,DOPEN CALL DCODE(CH, DOSPEC(I)) WRITE (NOUT,99994) CH 120 CONTINUE C OUTPUT NUMBER OF STATEMENTS PROCESSED AND NUMBER OF ERROR MESSAGES 130 WRITE (NOUT,99993) NUMST WRITE (NOUT,99992) NUMERR RETURN 99999 FORMAT (6X, 15HFROM STATEMENT , I6, 13H TO STATEMENT, I6) 99998 FORMAT (1X, 40H***ARRAY AND SIMPLE NUMERIC NAME CLASHES) 99997 FORMAT (46H ***FOLLOWING STATEMENT NUMBERS ARE REFERENCED, * 4H BUT, 13H DO NOT OCCUR) 99996 FORMAT (1H , 6I8) 99995 FORMAT (46H ***NEXT STATEMENTS MISSING FOR FOLLOWING CONT, * 4HROL , 9HVARIABLES) 99994 FORMAT (1H , 3A1) 99993 FORMAT (1H , I6, 22H STATEMENTS PROCESSED) 99992 FORMAT (1H , I6, 23H ERROR MESSAGES OUTPUT) 99991 FORMAT (46H *** ILLEGAL JUMPS INTO FOR BLOCKS-CHECKS ABAN, * 5HDONED) 99990 FORMAT (37H *** ILLEGAL TRANSFER INTO FOR BLOCKS) END C*** C SUBROUTINE UPJUMP C*** SUBROUTINE UPJUMP(STAT, DEST) C C UPDATES JUMPS ARRAY CONTAINING FORWARD REFERENCES C STAT = CURRENT STATEMENT NUMBER C DEST = DESTINATION STATEMENT C C..ARGUMENTS INTEGER DEST, STAT C..COMMON BLOCKS LOGICAL ABNFOR INTEGER LFOR, NFOR, FORNXT, LJUMP, NJUMP, JUMPS COMMON /CFOR1/ LFOR, NFOR, FORNXT(50,2), LJUMP, NJUMP, * JUMPS(500,2), ABNFOR C RETURN IF ABNFOR IS TRUE IF (ABNFOR) GO TO 10 C CHECK ENOUGH ROOM NJUMP = NJUMP + 1 IF (NJUMP.GT.LJUMP) CALL SYSERR(5) C UPDATE JUMPS(NJUMP,1) = STAT JUMPS(NJUMP,2) = DEST 10 RETURN END C*** C SUBROUTINE UQSTR C*** SUBROUTINE UQSTR C C IGNORE ALL LEADING AND TRAILING SPACES C ASSUME K3 POINTS AT THE FIRST NON-BLANK AND THAT C THE STRING IS TO BE TERMINATED BY A COMMA (59) OR C THE END OF THE LINE C C A WARNING IS OUTPUT IF THE LENGTH OF THE STRING C EXCLUDING LEADING AND TRAILING SPACES IS GREATER C THAN 18 (MAXLEN) C C..LOCAL VARIABLES INTEGER UQ(4) INTEGER COMMA, I, ICH, K1, K2, MAXLEN, NUM, SPACE C..FUNCTIONS INTEGER CODE C..COMMON BLOCKS INTEGER K3, JCODE INTEGER LLINE, NLINE, MAXLIN, LINE COMMON /CNXTCH/ K3, JCODE COMMON /CLINE/ LLINE, NLINE, MAXLIN, LINE(80) DATA NUM, COMMA, MAXLEN, SPACE /4,59,18,44/ DATA UQ(1), UQ(2), UQ(3), UQ(4) /44,36,37,40/ C LET K1 POINT TO THE FIRST CHARACTER IN THE STRING K1 = K3 C UNQUOTED STRING CANNOT BE NULL IF (LINE(K1).EQ.COMMA) GO TO 50 C EAT LETTERS AND DIGITS 10 JCODE = CODE(K3) IF (JCODE.NE.3) GO TO 30 C CHECK NOT AT END OF STRING IF (LINE(K3).EQ.COMMA) GO TO 60 C ELSE SPACE IF (LINE(K3).EQ.SPACE) GO TO 40 C OTHER CHARACTER ICH = LINE(K3) DO 20 I=1,NUM IF (ICH.EQ.UQ(I)) GO TO 30 20 CONTINUE CALL ERROR(41HNON-STANDARD CHARACTER IN UNQUOTED STRING, 41) C LETTER,DIGIT,OR LEGAL JCODE=3 30 K2 = K3 40 K3 = K3 + 1 IF (K3.LE.NLINE) GO TO 10 K3 = -1 GO TO 70 C NULL STRING ILLEGAL 50 CALL ERROR(51HNULL OR BLANK STRING NOT ALLOWED AS UNQUOTED STRING, * 51) GO TO 70 60 IF (K2-K1+1.GT.MAXLEN) CALL * ERROR( * 56HWARNING UNQUOTED STRING EXCEEDS MINIMAL SPECIFIED LENGTH, 56) 70 RETURN END C*** C SUBROUTINE XRSTAT C*** SUBROUTINE XRSTAT C C ROUTINE TO PRINT OUT X-REF TABLES OF STATEMENT TYPES C C..LOCAL VARIABLES INTEGER ZT(9), TEMP(6) INTEGER I, IBLNK, IEND, II, IST, J, K, KEND, KST, L, SIX LOGICAL FIRST, ENDCH C..COMMON BLOCKS INTEGER LCHAIN, NCHAIN, CHAIN INTEGER NIN, NOUT, NTAB LOGICAL ENDIN INTEGER KEYREF, LKEY, Z COMMON /CCHAIN/ LCHAIN, NCHAIN, CHAIN(5000) COMMON /CIO/ NIN, NOUT, NTAB, ENDIN COMMON /CKREF/ LKEY, KEYREF(21,2), Z(114) C SIX CONTROLS THE NUMBER OF REFERENCES OUTPUT/LINE C IF CHANGED THEN FORMAT STATEMENTS 102 AND 103 C NEED CHANGING ACCORDINGLY DATA SIX, IBLNK /6,1H / WRITE (NTAB,99999) KEND = 0 DO 100 II=1,LKEY C CALCULATE INDEXES IN Z ARRAY KST = KEND + 1 KEND = KST + Z(KST) KST = KST + 1 C TEST IF STATEMENT TYPE OCCURS IN PROGRAM IST = KEYREF(II,1) IF (IST.EQ.0) GO TO 100 C INITIALIZE OTHER VARIABLE IEND = KEYREF(II,2) FIRST = .TRUE. ENDCH = .FALSE. C COLLECT REFERENCES SIX AT A TIME 10 DO 30 J=1,SIX K = J TEMP(K) = CHAIN(IST) C CHECK IF LAST REFERENCE IF (IST.NE.IEND) GO TO 20 ENDCH = .TRUE. GO TO 40 C PICK UP NEXT REFERENCE 20 IST = CHAIN(IST+1) 30 CONTINUE 40 IF (.NOT.FIRST) GO TO 80 FIRST = .FALSE. C PICK UP NAME AND PAD WITH BLANKS I = 0 DO 50 L=KST,KEND I = I + 1 ZT(I) = Z(L) 50 CONTINUE IF (I.EQ.9) GO TO 70 I = I + 1 DO 60 L=I,9 ZT(L) = IBLNK 60 CONTINUE 70 WRITE (NTAB,99998) (ZT(I),I=1,9), (TEMP(I),I=1,K) GO TO 90 80 WRITE (NTAB,99997) (TEMP(I),I=1,K) 90 IF (.NOT.ENDCH) GO TO 10 100 CONTINUE RETURN 99999 FORMAT (16X, 36HSTATEMENT TYPE CROSS REFERENCE TABLE/16X, * 36H------------------------------------) 99998 FORMAT (4X, 9A1, 2X, 1H-, 4X, 6I8) 99997 FORMAT (20X, 6I8) END C*** C SUBROUTINE XRSTNO C*** SUBROUTINE XRSTNO C C ROUTINE TO PRINT OUT X-REF TABLES FOR LINE NUMBERS C REFERENCED REMS ARE DENOTED BY A STAR FOLLOWING THE STATEMENT C NUMBER C C..LOCAL VARIABLES INTEGER TEMP(6) INTEGER I, IBLNK, IEND, IREM, IST, ISTAR, ISTAT, J, K, L, SIX LOGICAL ENDCH, FIRST C..COMMON BLOCKS INTEGER LCHAIN, NCHAIN, CHAIN INTEGER NIN, NOUT, NTAB LOGICAL ENDIN INTEGER LSTAT, NSTAT, BNSTAT, STATNO, STAREF COMMON /CCHAIN/ LCHAIN, NCHAIN, CHAIN(5000) COMMON /CIO/ NIN, NOUT, NTAB, ENDIN COMMON /CSTAT/ LSTAT, NSTAT, BNSTAT, STATNO(500), STAREF(500,2) DATA ISTAR, IBLNK /1H*,1H /, SIX /6/ WRITE (NTAB,99999) C LOOP THROUGH ALL STATEMENTS DO 90 I=1,NSTAT C TEST IF STATEMENTS REFERENCED IST = STAREF(I,1) IF (IST.EQ.0) GO TO 90 IF (IST.GT.0) GO TO 10 C REFERENCE NOT APPEARING AS STATEMENT IN PROGRAM CALL * ERROR( * 54HFOLLOWING STATEMENT NUMBER APPEARS ONLY AS A REFERENCE, 54) IST = -IST C TEST IF REM STATEMENT 10 IREM = IBLNK ISTAT = STATNO(I) IF (ISTAT.GT.0) GO TO 20 IREM = ISTAR ISTAT = IABS(ISTAT) C INITIALIZE OTHER VARIABLES 20 IEND = STAREF(I,2) FIRST = .TRUE. ENDCH = .FALSE. C COLLECT REFERENCES SIX AT A TIME 30 DO 50 J=1,SIX K = J TEMP(K) = CHAIN(IST) C CHECK IF LAST REFERENCE IF (IST.NE.IEND) GO TO 40 ENDCH = .TRUE. GO TO 60 C PICK UP NEXT REFERENCE 40 IST = CHAIN(IST+1) 50 CONTINUE 60 IF (.NOT.FIRST) GO TO 70 FIRST = .FALSE. WRITE (NTAB,99998) ISTAT, IREM, (TEMP(L),L=1,K) GO TO 80 70 WRITE (NTAB,99997) (TEMP(L),L=1,K) C CHECK IF END OF CHAIN 80 IF (.NOT.ENDCH) GO TO 30 90 CONTINUE RETURN 99999 FORMAT (17X, 33HLINE NUMBER CROSS REFERENCE TABLE/17X, 8H--------, * 25H-------------------------) 99998 FORMAT (6X, I5, 1X, A1, 2X, 1H-, 4X, 6I8) 99997 FORMAT (20X, 6I8) END C*** C SUBROUTINE XRVARS C*** SUBROUTINE XRVARS C C ROUTINE TO PRINT OUT X-REF TABLE FOR VARIABLES , ARRAYS C AND FUNCTIONS. C C..LOCAL VARIABLES INTEGER U(2,6) INTEGER I, ICODE, IE, IEND, IS, IST, K LOGICAL ONE C..COMMON BLOCKS INTEGER NIN, NOUT, NTAB LOGICAL ENDIN INTEGER LVAR, IVAR COMMON /CIO/ NIN, NOUT, NTAB, ENDIN COMMON /CVAR/ LVAR, IVAR(376,2) DATA U(1,1), U(2,1), U(1,2), U(2,2), U(1,3), U(2,3), * U(1,4), U(2,4), U(1,5), U(2,5), U(1,6), U(2,6) * /1,286,287,312,313,338,339,364,365,375,376,376/ WRITE (NTAB,99999) C LOOP THROUGH DIFFERENT TYPES DO 100 K=1,6 ONE = .FALSE. IS = U(1,K) IE = U(2,K) DO 90 I=IS,IE IF (IVAR(I,1).EQ.0) GO TO 90 IF (ONE) GO TO 80 C WRITE HEADING GO TO (10, 20, 30, 40, 50, 60), K 10 WRITE (NTAB,99998) GO TO 70 20 WRITE (NTAB,99997) GO TO 70 30 WRITE (NTAB,99996) GO TO 70 40 WRITE (NTAB,99995) GO TO 70 50 WRITE (NTAB,99994) GO TO 70 60 WRITE (NTAB,99993) 70 ONE = .TRUE. 80 IST = IVAR(I,1) IEND = IVAR(I,2) ICODE = I CALL OCHAIN(IST, IEND, ICODE) 90 CONTINUE 100 CONTINUE RETURN 99999 FORMAT (12X, 41HVARIABLES AND FUNCTION CROSS REFERENCE TA, * 3HBLE/12X, 42H------------------------------------------, * 2H--) 99998 FORMAT (//17H SIMPLE VARIABLES) 99997 FORMAT (//17H STRING VARIABLES) 99996 FORMAT (//15H NUMERIC ARRAYS) 99995 FORMAT (//23H USER DEFINED FUNCTIONS) 99994 FORMAT (//19H STANDARD FUNCTIONS) 99993 FORMAT (//13H TAB FUNCTION) END 1 REM TEST PROGRAM 2 REMARK OTHER FORM OF REM 4 PRINT "TEST GOS" 5 LET A=0 0006GO TO0008 7 PRINT "GO ERROR" 8 DEF FNV=3 9 GOTO 14 12 GO TO17 14 DIM V(3) 15 GOTO 12 17 LET A=A+1 18 IF A<4 THEN 6 20 GO SUB 24 21 GOTO 30 24 REM SUBROUTINE 25 RETURN 30 PRINT "TEST CONSTANTS" 32 PRINT 0.0; 1; 2.0; 03.0; 4E0; " SB 0 THRU 4" 00033 PRINT .5E+1;600E-2;0.07E2;-(-8),.0000000009E10; " SB 5 THRU 9" 34 PRINT 25.678900000000000000000000000000000234; " SB 25.6789" 35 PRINT-1.1*(-1.2);" SB 1.32" 36 PRINT 26070000000000000000123E-21;" SB 26.07" 37 PRINT - 36 ^ .5; -7; - ( + 8 ); " IS -6 THRU -8" 38 PRINT 1E-38;1E+38; " ARE 1E-38 AND 1E+38" 39 PRINT 100E322,.001E-322; " ARE TOO LARGE AND TOO SMALL" 40 REM TEST PRINT FORMATS 41 PRINT"A "; "B"; "C"; "D "; "E SB A BCD E" 42 PRINT "1 TAB";TAB(.6);"3 TABS";TAB(3);"ENDTABS" 43 PRINT "1 TAB","3 TABS",;,,;;; 44 PRINT "ENDTABS" 45 PRINT "A"; 46 PRINT;;; 47 PRINT;;"B SB AB" 48 PRINT;;, 49 PRINT"SB IDENTED ONE TAB" 50PRINT"LONGESTPOSSIBLE................................................" 51 PRINT "20 TABS";TAB(4*5) 52 LET X=1/3 53 PRINT "TOOLONG",X,X,X,X,X,X,X,X,X,X,X,X,X,X,X,X 54 PRINT "Y" ; "" ; "E" ; 55PRINT"";"S"; " SB YES (WITH NO SPACES IN IT)" 60 PRINT "TEST DEF" 61 GOTO 63 62 DEF FNA=1 63DEFFNB ( X ) = X + 1 64 DEF FNZ(Z9) =Z9*2+FNA+FNB(1+1) 65 DEF FNK(X)=X+FNB(X)+X 68 LET X=3 70PRINTFNA,FNB (1),FNB(-(-1-1)), FNB(FNB(2)), 71 PRINT FNZ(1/2),X+FNB(1)*FNB(1)-1,X+4 72IFFNA<>FNATHEN 78 73 PRINT 8;" SB 1 THRU 8" 74 IF FNK(FNK (10) + FNK(20) -1) =274 THEN 78 75 PRINT "FUNCTION ERROR 1 WITH:",FNK(FNK(10)+FNK(20)-1) 78 PRINT "TEST ON" 81 LET X3=3 82 ON 1 GOTO 85 83 PRINT "ON ERROR 1" 85 ON X3+6-6 GOTO 86,86,87,86 86 PRINT "ON ERROR 2" 87ON(SGN(RND))GOTO 88,89 88 ON 2*X3/X3+X3 GOTO 89,89,89,89,90 89 PRINT "ON ERROR 3" 90 PRINT "END ON TESTS" 100 REM IF TESTS (FIRST NON-JUMPS) 101 IF 1<>1 THEN 103 102 PRINT 1 103 IF 1=1+1 THEN 105 104 PRINT 2 105 IF1>1 THEN 107 106 PRINT 3 107 IF 1<=6*0 THEN 109 108 PRINT 4 109 IF 6<6 THEN 111 110 PRINT 5 111 IF 1>2 THEN 113 112 PRINT 6 113 IF 1<0 THEN 115 114 PRINT 7 115 IF 1 + 1 >= 1 + 2 THEN 117 116 PRINT 8 117 REM END NON-JUMPS NOW TRY JUMPS 120 PRINT " SB 1 THRU 8" 121 IF 1+1=2 THEN 123 122 PRINT -1 123 IF1<>2 THEN 125 124 PRINT-2 125 IF1>0THEN127 126 PRINT-3 127IF1>=1E0THEN129 128 PRINT-4 129 IF-1*1 >=-1-1 THEN 131 130 PRINT-5 131 IF -2<-1 THEN 133 132 PRINT-6 133 IF 0<=0 THEN 135 134 PRINT-7 135 IF 1<3/1 THEN 139 136 PRINT-8 139 GOTO 200 150 REM USE ALL VARIABLE NAMES 151 PRINT A,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9 152 PRINT B,B1,B2,B3,B4,B5,B6,B7,B8,B9 153 PRINT C,C1,C2,C3,C4,C5,C6,C7,C8,C9 154 PRINT D,D0,D1,D2,D3,D4,D5,D6,D7,D8,D9 155 PRINT E9,E8,E7,E6,E5,E4,E3,E2,E1,E 156 PRINT F,F1,F2,F3,F4,F5,F6,F7,F8,F9 157 PRINT G,G1,G2,G3,G4,G5,G6,G7,G8,G9 158 PRINT H,H1,H2,H3,H4,H5,H6,H7,H8,H9 159 PRINT I,I1,I2,I3,I4,I5,I6,I7,I8,I9 160 PRINT J,J1,J2,J3,J4,J5,J6,J7,J8,J9 161 PRINT K1,K2,K3,K4,K5,K6,K7,K8,K9 162 PRINT L,L1,L2,L3,L4,L5,L6,L7,L8,L9 163 PRINT N,N1,N2,N3,N4,N5,N6,N7,N8,N9 164 PRINT M,M1,M2,M3,M4,M5,M6,M7,M8,M9 165 PRINT O,O1,O2,O3,O4,O5,O6,O7,O8,O9 166 PRINT P,P1,P2,P3,P4,P5,P6,P7,P8,P9 167 PRINT Q,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9 168 PRINT S,S1,S2,S3,S4,S5,S6,S7,S8,S9 169 PRINT T,T0,T1,T2,T3,T4,T5,T6,T7,T8,T9 170 PRINT U,U1,U2,U3,U4,U5,U6,U7,U8,U9,U0 171 PRINT V,V0,V1,V2,V3,V4,V5,V6,V7,V8,V9 172 PRINT W1,W,W0,W2,W3,W4,W5,W6,W7,W8,W9 174 PRINT X,X0,X1,X2,X3,X4,X5,X6,X7,X8,X9 175 PRINT Y,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9 176 PRINT Z,Z1,Z0,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9 180 PRINT A$,B$,C$,D$,E$,F$,G$ 181 PRINT H$,I$,J$,K$,L$,M$,N$ 182 PRINT O$,P$,Q$,R$,S$,T$ 184 PRINT V$,W$,X$,Y$,Z$ 185 PRINT R,R0,R1,R2,R3,R4,R5,R6,R7,R8,R9 186 PRINT B0,C0,E0,F0,G0,H0,I0,J0,K0,K,L0 187 PRINT M0,N0,O0,P0,U$,Q0,S0,Y0 200 PRINT "GOSUB TESTS" 202 GOSUB 500 204 GOSUB 210 206 REM THIS SUBROUTINE NEVER RETURNS 210 GOSUB 500 212 PRINT" SB XX" 214 LET X1=9 216 LET X2=5*2 218 GOSUB 600 220 PRINT " SB 987654321" 222 PRINT F;" SB 90" 240 PRINT "TEST FORS" 242 FOR I=1 TO 3 244 PRINT I, 246 NEXT I 248 PRINT " SB 1 THRU 3" 252 LET E=2 254 FOR A=0 TO E 255 DEF FNY=-1 256 FOR Z9=-FNY-2 TO 3*(-1) STEP -(-FNY) 258 PRINT 3*A-Z9 260 NEXT Z9 261 LET E=0 262 NEXT A 264 PRINT " SB 123456789" 266 PRINT A," SB 3",Z9;" SB -4" 268 LET P=0 270 FORA=1TO3-PSTEPP 272 LET P=P+1 274 PRINT A+P; 276 IF P>4 THEN 280 278 NEXT A 280 PRINT " SB 23456" 286 FOR V=20 TO 16 STEP -1 288 IF V=18 THEN 300 290 REM RETURN HERE ON GOSUB MUCH LATER 291 IF V>18 THEN 294 292 PRINT V; 294 NEXT V 296 PRINT V;" SB 18 THRU 15" 298 RETURN 300 FOR I=1 TO 7 STEP 3 302 GO SUB 330 304 GOTO 320 306 PRINT I,X1,FNY*FNY*X2; 308 FOR J=4 TO 2 STEP-9 310 GOTO 314 312 NEXT J 314 NEXT I 316 PRINT " SB 123456789" 318 GO TO 350 320 LET X1=I+1 322 GOTO 306 330 LET X2=I+2 332 RETURN 350 FOR I=1 TO 0 352 PRINT "FOR ERROR 1" 354 NEXT I 356 FOR I=1 TO 2 STEP-1 358 PRINT "FOR ERROR 2" 360 NEXT I 362 FOR K=0 TO 0 364 PRINT K; 366 NEXT K 368 FOR I=0 TO 0 STEP -(-FNY) 370 PRINT I+1; 372 NEXT I 374 PRINT" SB 01" 376 LET P=0 378 FOR I=1 TO 2 380 LET P=P+1 382 IF P<5000 THEN 378 384 NEXT I 386 PRINT I,P," SB 3,5001" 388 LET P=10 389 LET Q=1 390 FOR I=1 TO P STEP Q 392 PRINT I; 394 LET P=3 396 LET I=I+P 398 LET Q=0 399 NEXT I 400 PRINT I; "SB 1,5,9,13" 410 FOR I=1 TO 3 412 FOR I=6 TO 9 414 PRINT I; 416 NEXT I 418 GOTO 422 420 NEXT I 422 PRINT I;" SB 6 THRU 10" 430 PRINT "10 NESTED FORS -- NB V IS STILL ACTIVE AT 286" 432 FOR A=1 TO 1 434 FOR B=2 TO 2 436 FOR C=-3 TO -3 438 FOR D=4 TO 4 STEP -1 440 FOR E=5 TO 5 STEP-1 444 PRINT A;B; -C;D;E; 446 FOR F=-6 TO -6 STEP -1 448 FOR G=7 TO 7 450 FOR H=8 TO 8 452 FOR I=9 TO 9 454 PRINT -F; G; H; I; " SB 1 THRU 9" 456 NEXT I 458 NEXT H 460 NEXT G 462 NEXT F 464 NEXT E 466 NEXT D 468 NEXT C 470 NEXT B 472 NEXT A 480 GOSUB 290 498 PRINT "END FOR TESTS" 499 GOTO 640 500 REM SUBROUTINE 1 502 PRINT "X" ; 504 RETURN 600 REM RECURSIVE MULTIPLY SUBROUTINE : X1*X2 605 DEF FNO=1 610 PRINT X1; 615 IF X1=FNO THEN 630 618 LET X1=X1-FNO 620 GOSUB 605 622 LET F=F+X2 624 RETURN 630 LET F=X2 632 RETURN 640 PRINT "TEST RANDOM NUMBERS" 641 PRINT RND,RND," SHOULD BE THE SAME 2 VALUES EVERY RUN" 642 RANDOMIZE 643 PRINT RND,RND," SHOULD BOTH CHANGE (ALMOST) EVERY RUN" 644 RANDOMIZE 645 PRINT RND,RND," SHOULD BOTH CHANGE (ALMOST) EVERY RUN" 646 LET E=9 647 LET A=9 650 LET E$="EIGHTEEN CHAR STRI" 652 LET N$="" 654 LET F$=E$ 655 IF A<>E THEN 658 656 LET G$="NG" 658 PRINT F$;""; N$; G$; " SB EIGHTEEN CHAR STRING" 670 PRINT "COMPARISON OF STRINGS" 672 IF E$<>E$ THEN 674 673 PRINT "A"; 674 IF N$<>"" THEN 676 675 PRINT "B"; 676 IF "PIG"<>"PIG" THEN 678 677 PRINT "C"; 678 IF"" = " " THEN 680 679 PRINT "D"; 680 IF "PIG"="PIT" THEN 682 681 PRINT "E"; 682 IF G$="EIGHTEEN CHAR PTRI" THEN 684 683 PRINT "F"; 684 IF E$ > E$ THEN 686 685 PRINT "G"; 686 IF E$"B" THEN 690 689 PRINT "I"; 690 PRINT " SB ABCDEFGHI" 691 PRINT "J"; 692 IF"A">="A:" THEN 694 693 PRINT "K"; 694 IF "A:"<="A" THEN 696 695 PRINT "L"; 696 IF E$<="EIGHTEEN CHAR STRG" THEN 698 697 PRINT "M"; 698 IF":"<""THEN 700 699 PRINT "N"; 700 IF "2"<"1" THEN 710 701 PRINT "O"; 710IFE$=F$THEN712 711 PRINT " STRING ERROR 1" 712 IF "" ="" THEN 714 713 PRINT " STRING ERROR 2" 714 IF E$<>"EIGHTEEN CHAR STRG" THEN 716 715 PRINT " STRING ERROR 3" 716 IF E$ >"EIGHTEEN CHAR STRG" THEN 718 717 PRINT " STRING ERROR 4" 718 IF":"> "" THEN 720 719 PRINT " STRING ERROR 5" 720 IF "EIGHTEEN CHAR STRG" =E$ THEN 726 725 PRINT " STRING ERROR 8" 726 IF E$<=E$ THEN 728 727 PRINT " STRING ERROR 9" 728 IF "012345678901"<="012345678911" THEN 730 729 PRINT " STRING ERROR 10" 730 IF ":">="" THEN 732 731 PRINT " STRING ERROR 11" 732 PRINT "P SB JKLMNOP" 750 PRINT "EXPRESSION EVALUATION TESTS" 752 PRINT 3-1-1; 1+2*.5; 15-4*3; 56/7/2; " SB 1 THRU 4" 754 DEF FNU(X)=X+1*1 756 LET U(3,4)=2 758 PRINT (2+8)/2; (((4))+(-(-(2))));FNU(4+6/3); U(6/3+1,3*2-2)^4-8; 760 PRINT " SB 5 THRU 8" 762 PRINT3-(2+U(-5+4*2,6 + FNU(3^2+6)-18) ) +6; " SB 5", 2^3^4; " SB 4 764 PRINT-2^2,-(+1+2^2);-2*9^.5;-56/2^3; " SB -4 THRU -7" 766 PRINT(1E38+1E-38)-(1E38-1E-38)+5.7; " SB 5.7" 768 IF 1+2*3^4=168-125/5^2 THEN 770 769 PRINT "EXPRESSION EVALUATION ERROR" 770 PRINT 6*10/4; 2^2*4; 3/3*17; 1*3*1*3*2*1/1; " SB 15 THRU 18" 772 PRINT-3^2; -4*2,-8+1; -(+(-(+(-5))))-1; " SB -9 THRU -6" 800 PRINT "ARRAY TESTS" 802 DIM A(1),B(1,2),C(3,4), D(5,11) 804 LET A(0)=1 806 LET A(1)=2 808 LET B(0,0)=3 810 LET B(A(0),2)=4 812 LET X(0)=5 814 LET X(10)=6 816 LET Y(0,0)=7 818 LET Y(10,10)=Y(0,0)+A(0) 820 PRINT A(0);A(A(A(0))-1);B(0,0);B(1,3-1); " SB 1 THRU 4" 822 PRINT X(0); X(10); Y(2*0,0);Y(10,10); " SB 5 THRU 8" 824 DEF FNC=M(N+M+N(0,A(0)-1)-2) 826 LET N(0,0)=10 828 LET M(10)=9 829 LET M=5 830 LET N=-M+2 832 LET M(0)=N(0,0)-2 834 PRINT FNC;M(.49); M(10.49)-2; 836 LET X(9)=10.4 838 PRINT M(X(M(X( FNC+1-1)-.3))+1-SGN(N(0,0)))^.5*2; " SB 9 THRU 6" 850 FOR I=1 TO 3 852 FOR J=0 TO 4 854 GOTO 856 856 DIM Q(3,4) 858 DEF FNF=2 859 LET Q(I,J)=FNF^(I-1) 860 IF I=1 THEN 862 861 LET Q(I,J)=Q(I,J)+Q(I-1,J) 862 FOR K=1 TO J 864 LET Q(I,K)=Q(I,K)+Q(I,K-1) 866 NEXT K 868 NEXT J 870 NEXT I 872 PRINT 2^Q(1,2); Q(1,4); Q(2,4); Q(3,4); " SB 8192,23,156,642 " 874 LET X(FNC+X(3*3)-INT(11.9)-RND*.4)= 11 876 PRINT X(N(0,0)^A(0)-2)^A(1); " SB 121" 900 PRINT "TEST DATA AND INPUT" 902 GOTO 904 904 DATA 3 , "EIGHTEEN CHAR STRI", EIGHTEEN CHAR STRI 906 LET E$="EIGHTEEN CHAR STRI" 908 READ X 910 GO SUB 1050 918DATA"" 926 DATA 3.0,4.0 , .05E2 ,600E-02,.007E+3,8.00000001 928 FOR I=1 TO 6 930 READ J 932 PRINT J; 934 NEXT I 936 PRINT " SB 3 THRU 8" 938DATA -4,+5,-60E-1,2,10,4 940 READ A,B,C 942 PRINT A,-B,C," SB -4 THRU -6" 944 LET I=3 946 READ I,X(I),X ( X ( I ) ) 948 PRINT I,X(2),X(10)," SB 2,10,4" 950 READ I,J,I,J,X(2),X(J) 952 DATA 20,200,1,2 953 DATA 2000,.30 954 PRINT I,J,X(2)*10, " IS 1 THRU 3" 956 DEF FNH(I)=X(I+1)-14 958 LET X(6)=20 960 READ J,X(FNH(J)) 962 DATA 5,10 964 PRINT J,X(6)," SB 5,10" 966 DATA" ", . ,",..." 968 READ A$,B$,C$ 970 PRINT "+.+" ; A$ ; "+";B$;"+";C$; " SB +.+ +.+,..." 972 DATA AZ09* ):$ , =<>-å(..+E;/. 974 DATA"AZ09* ):$" , "=<>-å(..+E;/." 976 READ A$,B$,Y$,Z$ 978 PRINT A$;B$;Y$;Z$ 979 PRINT " SB AZ09* ):$=<>-å(..+E;/. (REPEATED TWICE)" 980 RESTORE 982 READ Y 984 PRINT X,Y," SB 3,3" 985 GOSUB 1050 986 FOR I=1 TO 20 988 RESTORE 990 NEXT I 992 FOR J=1 TO 9 994 READ C$ 996 NEXT J 998 PRINT C$," SB .007E+3" 1000 GO TO 1100 1050 REM SUBROUTINE TO CHECK STRING INPUT 1052 READ F$,G$ 1053 READ N$ 1054 GO TO 1058 1056 INPUT F$,G$ 1057 INPUT N$ 1058 IF F$<>G$ THEN 1066 1060 IF F$=E$ THEN 1068 1066 PRINT " DATA ERROR 1 WITH:";F$,G$ 1068 IF N$="" THEN 1072 1070 PRINT " DATA ERROR 2 WITH:";N$ 1072 LET F$="RUBBISH1" 1074 LET G$="RUBBISH2" 1076 LET N$="RUBBISH3" 1078 RETURN 1100 PRINT "NOW REPEAT USING INPUT FOR READ" 1108 INPUT X0 1110 GOSUB 1056 1128 INPUT J1,J2,J3,J4,J5,J6 1130 PRINT J1,J2,J3 1134 PRINT J4,J5,J6 1136 PRINT " IS 3 THRU 8" 1140 INPUT A,B,C 1142 PRINT A,-B,C," IS -4 THRU -6" 1146 INPUT I,X(I),X(X(I)) 1148 PRINT I,X(2),X(10)," IS 2,10,4" 1150 INPUT I,J0,I,J0,R(2),R(J0) 1154 PRINT I,J0,R(2)*10, " IS 1 THRU 3" 1158 LET X(6)=20 1160 INPUT J0,X(FNH(J0)) 1164 PRINT J0,X(6)," IS 5,10" 1166 LET C$="1234567890123456" 1168 INPUT A$,B$,C$ 1170PRINT "+.+" ; A$ ; "+";B$;"+";C$; " SB +.+ +.+,..." 1176 INPUT A$,B$ 1177 INPUT P$,Q$ 1178 PRINT A$ ; B$;P$;Q$ 1179PRINT " SB AZ09* ):$=<>-å(..+E;/. (REPEATED TWICE)" 1184 PRINT X0,X,Y," IS 3,3,3" 1190 REM NOW INTERMIX READ WITH INPUT 1192 RESTORE 1194 READ X 1196 INPUT X0 1198 READ F$ 1200 INPUT S$,T$ 1201 INPUT G$ 1202 READ G$,N$ 1204 GOSUB 1058 1206 PRINT X,X0,S$,T$," IS 3 THRU 6" 5000 REM TEST SPACING ERRORS 5001 DEF FN L=1 5002 DEF F ND=1 5003 RANDOMIZ E 5004 PRINT A $ 5005 LET A 1=3 5006 PRINT SI N(X) 5007 DEF FNJ=RN D 5008 G O TO 5009 5009 IF A> =3 THEN 5010 5010 IF S< > S THEN 5011 5011 FOR A1=1 TO 3 STE P 6 5013 NEXT A 1 5014 PRINT FN J 5015 PRINT 23 45 5016 PRINT 2. 1 5017 PRINT 5.6E 9 5018 PRINT 1.2E- 9 31000 STOP 31001 PRINT "ERROR IN STOP" 31999 END . . 1 REM TEST PROGRAM 2 REMARK OTHER FORM OF REM ***NO SPACES FOLLOW KEYWORD 4 PRINT "TEST GOS" 5 LET A=0 0006GO TO0008 ***NO SPACE FOLLOWING STATEMENT NUMBER ***NO SPACE FOLLOWS KEYWORD 7 PRINT "GO ERROR" 8 DEF FNV=3 9 GOTO 14 12 GO TO17 ***NO SPACE FOLLOWS KEYWORD 14 DIM V(3) 15 GOTO 12 17 LET A=A+1 18 IF A<4 THEN 6 20 GO SUB 24 21 GOTO 30 24 REM SUBROUTINE 25 RETURN 30 PRINT "TEST CONSTANTS" 32 PRINT 0.0; 1; 2.0; 03.0; 4E0; " SB 0 THRU 4" 00033 PRINT .5E+1;600E-2;0.07E2;-(-8),.0000000009E10; " SB 5 THRU 9" 34 PRINT 25.678900000000000000000000000000000234; " SB 25.6789" 35 PRINT-1.1*(-1.2);" SB 1.32" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 36 PRINT 26070000000000000000123E-21;" SB 26.07" 37 PRINT - 36 ^ .5; -7; - ( + 8 ); " IS -6 THRU -8" 38 PRINT 1E-38;1E+38; " ARE 1E-38 AND 1E+38" 39 PRINT 100E322,.001E-322; " ARE TOO LARGE AND TOO SMALL" ***WARNING EXPONENT VALUE EXCEEDS MINIMAL REQUIREMENT ***WARNING EXPONENT VALUE EXCEEDS MINIMAL REQUIREMENT ***BLANK LINE ENCOUNTERED IN INPUT-IGNORED 40 REM TEST PRINT FORMATS 41 PRINT"A "; "B"; "C"; "D "; "E SB A BCD E" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 42 PRINT "1 TAB";TAB(.6);"3 TABS";TAB(3);"ENDTABS" 43 PRINT "1 TAB","3 TABS",;,,;;; 44 PRINT "ENDTABS" 45 PRINT "A"; 46 PRINT;;; ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 47 PRINT;;"B SB AB" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 48 PRINT;;, ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 49 PRINT"SB IDENTED ONE TAB" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 50PRINT"LONGESTPOSSIBLE................................................ ***NO SPACE FOLLOWING STATEMENT NUMBER ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 51 PRINT "20 TABS";TAB(4*5) 52 LET X=1/3 53 PRINT "TOOLONG",X,X,X,X,X,X,X,X,X,X,X,X,X,X,X,X 54 PRINT "Y" ; "" ; "E" ; 55PRINT"";"S"; " SB YES (WITH NO SPACES IN IT)" ***NO SPACE FOLLOWING STATEMENT NUMBER ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 60 PRINT "TEST DEF" 61 GOTO 63 62 DEF FNA=1 63DEFFNB ( X ) = X + 1 ***NO SPACE FOLLOWS KEYWORD 64 DEF FNZ(Z9) =Z9*2+FNA+FNB(1+1) 65 DEF FNK(X)=X+FNB(X)+X 68 LET X=3 70PRINTFNA,FNB (1),FNB(-(-1-1)), FNB(FNB(2)), ***NO SPACE FOLLOWING STATEMENT NUMBER ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 71 PRINT FNZ(1/2),X+FNB(1)*FNB(1)-1,X+4 72IFFNA<>FNATHEN 78 ***NO SPACE FOLLOWING STATEMENT NUMBER ***NO SPACE FOLLOWS KEYWORD ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 73 PRINT 8;" SB 1 THRU 8" 74 IF FNK(FNK (10) + FNK(20) -1) =274 THEN 78 75 PRINT "FUNCTION ERROR 1 WITH:",FNK(FNK(10)+FNK(20)-1) 78 PRINT "TEST ON" 81 LET X3=3 82 ON 1 GOTO 85 ***WARNING - NO VARIABLE CONTROLLING ON STATEMENT 83 PRINT "ON ERROR 1" 85 ON X3+6-6 GOTO 86,86,87,86 86 PRINT "ON ERROR 2" 87ON(SGN(RND))GOTO 88,89 ***NO SPACE FOLLOWS KEYWORD ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 88 ON 2*X3/X3+X3 GOTO 89,89,89,89,90 89 PRINT "ON ERROR 3" 90 PRINT "END ON TESTS" 100 REM IF TESTS (FIRST NON-JUMPS) 101 IF 1<>1 THEN 103 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 102 PRINT 1 103 IF 1=1+1 THEN 105 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 104 PRINT 2 105 IF1>1 THEN 107 ***NO SPACE FOLLOWS KEYWORD ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 106 PRINT 3 107 IF 1<=6*0 THEN 109 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 108 PRINT 4 109 IF 6<6 THEN 111 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 110 PRINT 5 111 IF 1>2 THEN 113 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 112 PRINT 6 113 IF 1<0 THEN 115 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 114 PRINT 7 115 IF 1 + 1 >= 1 + 2 THEN 117 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 116 PRINT 8 117 REM END NON-JUMPS NOW TRY JUMPS 120 PRINT " SB 1 THRU 8" 121 IF 1+1=2 THEN 123 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 122 PRINT -1 123 IF1<>2 THEN 125 ***NO SPACE FOLLOWS KEYWORD ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 124 PRINT-2 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 125 IF1>0THEN127 ***NO SPACE FOLLOWS KEYWORD ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 126 PRINT-3 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 127IF1>=1E0THEN129 ***NO SPACE FOLLOWS KEYWORD ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 128 PRINT-4 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 129 IF-1*1 >=-1-1 THEN 131 ***NO SPACE FOLLOWS KEYWORD ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 130 PRINT-5 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 131 IF -2<-1 THEN 133 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 132 PRINT-6 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 133 IF 0<=0 THEN 135 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 134 PRINT-7 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 135 IF 1<3/1 THEN 139 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 136 PRINT-8 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 139 GOTO 200 150 REM USE ALL VARIABLE NAMES 151 PRINT A,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9 152 PRINT B,B1,B2,B3,B4,B5,B6,B7,B8,B9 153 PRINT C,C1,C2,C3,C4,C5,C6,C7,C8,C9 154 PRINT D,D0,D1,D2,D3,D4,D5,D6,D7,D8,D9 155 PRINT E9,E8,E7,E6,E5,E4,E3,E2,E1,E 156 PRINT F,F1,F2,F3,F4,F5,F6,F7,F8,F9 157 PRINT G,G1,G2,G3,G4,G5,G6,G7,G8,G9 158 PRINT H,H1,H2,H3,H4,H5,H6,H7,H8,H9 159 PRINT I,I1,I2,I3,I4,I5,I6,I7,I8,I9 160 PRINT J,J1,J2,J3,J4,J5,J6,J7,J8,J9 161 PRINT K1,K2,K3,K4,K5,K6,K7,K8,K9 162 PRINT L,L1,L2,L3,L4,L5,L6,L7,L8,L9 163 PRINT N,N1,N2,N3,N4,N5,N6,N7,N8,N9 164 PRINT M,M1,M2,M3,M4,M5,M6,M7,M8,M9 165 PRINT O,O1,O2,O3,O4,O5,O6,O7,O8,O9 166 PRINT P,P1,P2,P3,P4,P5,P6,P7,P8,P9 167 PRINT Q,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9 168 PRINT S,S1,S2,S3,S4,S5,S6,S7,S8,S9 169 PRINT T,T0,T1,T2,T3,T4,T5,T6,T7,T8,T9 170 PRINT U,U1,U2,U3,U4,U5,U6,U7,U8,U9,U0 171 PRINT V,V0,V1,V2,V3,V4,V5,V6,V7,V8,V9 172 PRINT W1,W,W0,W2,W3,W4,W5,W6,W7,W8,W9 174 PRINT X,X0,X1,X2,X3,X4,X5,X6,X7,X8,X9 175 PRINT Y,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9 176 PRINT Z,Z1,Z0,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9 180 PRINT A$,B$,C$,D$,E$,F$,G$ 181 PRINT H$,I$,J$,K$,L$,M$,N$ 182 PRINT O$,P$,Q$,R$,S$,T$ 184 PRINT V$,W$,X$,Y$,Z$ 185 PRINT R,R0,R1,R2,R3,R4,R5,R6,R7,R8,R9 186 PRINT B0,C0,E0,F0,G0,H0,I0,J0,K0,K,L0 187 PRINT M0,N0,O0,P0,U$,Q0,S0,Y0 200 PRINT "GOSUB TESTS" 202 GOSUB 500 204 GOSUB 210 206 REM THIS SUBROUTINE NEVER RETURNS 210 GOSUB 500 212 PRINT" SB XX" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 214 LET X1=9 216 LET X2=5*2 218 GOSUB 600 220 PRINT " SB 987654321" 222 PRINT F;" SB 90" 240 PRINT "TEST FORS" 242 FOR I=1 TO 3 244 PRINT I, 246 NEXT I 248 PRINT " SB 1 THRU 3" 252 LET E=2 254 FOR A=0 TO E 255 DEF FNY=-1 256 FOR Z9=-FNY-2 TO 3*(-1) STEP -(-FNY) 258 PRINT 3*A-Z9 260 NEXT Z9 261 LET E=0 262 NEXT A 264 PRINT " SB 123456789" 266 PRINT A," SB 3",Z9;" SB -4" 268 LET P=0 270 FORA=1TO3-PSTEPP ***NO SPACE FOLLOWS KEYWORD ***SPACES MUST PRECEDE AND FOLLOW KEYWORD ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 272 LET P=P+1 274 PRINT A+P; 276 IF P>4 THEN 280 278 NEXT A 280 PRINT " SB 23456" 286 FOR V=20 TO 16 STEP -1 288 IF V=18 THEN 300 290 REM RETURN HERE ON GOSUB MUCH LATER 291 IF V>18 THEN 294 292 PRINT V; 294 NEXT V 296 PRINT V;" SB 18 THRU 15" 298 RETURN 300 FOR I=1 TO 7 STEP 3 302 GO SUB 330 304 GOTO 320 306 PRINT I,X1,FNY*FNY*X2; 308 FOR J=4 TO 2 STEP-9 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 310 GOTO 314 312 NEXT J 314 NEXT I 316 PRINT " SB 123456789" 318 GO TO 350 320 LET X1=I+1 322 GOTO 306 ***ILLEGAL TRANSFER INTO FOR BLOCK 330 LET X2=I+2 332 RETURN 350 FOR I=1 TO 0 352 PRINT "FOR ERROR 1" 354 NEXT I 356 FOR I=1 TO 2 STEP-1 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 358 PRINT "FOR ERROR 2" 360 NEXT I 362 FOR K=0 TO 0 364 PRINT K; 366 NEXT K 368 FOR I=0 TO 0 STEP -(-FNY) 370 PRINT I+1; 372 NEXT I 374 PRINT" SB 01" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 376 LET P=0 378 FOR I=1 TO 2 380 LET P=P+1 382 IF P<5000 THEN 378 384 NEXT I 386 PRINT I,P," SB 3,5001" 388 LET P=10 389 LET Q=1 390 FOR I=1 TO P STEP Q 392 PRINT I; 394 LET P=3 396 LET I=I+P 398 LET Q=0 399 NEXT I 400 PRINT I; "SB 1,5,9,13" 410 FOR I=1 TO 3 412 FOR I=6 TO 9 ***NESTED FOR-LOOP CONTROL VARIABLES THE SAME 414 PRINT I; 416 NEXT I 418 GOTO 422 420 NEXT I ***NEXT FOUND BUT NO FOR OPEN 422 PRINT I;" SB 6 THRU 10" 430 PRINT "10 NESTED FORS -- NB V IS STILL ACTIVE AT 286" 432 FOR A=1 TO 1 434 FOR B=2 TO 2 436 FOR C=-3 TO -3 438 FOR D=4 TO 4 STEP -1 440 FOR E=5 TO 5 STEP-1 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 444 PRINT A;B; -C;D;E; 446 FOR F=-6 TO -6 STEP -1 448 FOR G=7 TO 7 450 FOR H=8 TO 8 452 FOR I=9 TO 9 454 PRINT -F; G; H; I; " SB 1 THRU 9" 456 NEXT I 458 NEXT H 460 NEXT G 462 NEXT F 464 NEXT E 466 NEXT D 468 NEXT C 470 NEXT B 472 NEXT A 480 GOSUB 290 498 PRINT "END FOR TESTS" 499 GOTO 640 500 REM SUBROUTINE 1 502 PRINT "X" ; 504 RETURN 600 REM RECURSIVE MULTIPLY SUBROUTINE : X1*X2 605 DEF FNO=1 610 PRINT X1; 615 IF X1=FNO THEN 630 618 LET X1=X1-FNO 620 GOSUB 605 622 LET F=F+X2 624 RETURN 630 LET F=X2 632 RETURN 640 PRINT "TEST RANDOM NUMBERS" 641 PRINT RND,RND," SHOULD BE THE SAME 2 VALUES EVERY RUN" 642 RANDOMIZE 643 PRINT RND,RND," SHOULD BOTH CHANGE (ALMOST) EVERY RUN" 644 RANDOMIZE 645 PRINT RND,RND," SHOULD BOTH CHANGE (ALMOST) EVERY RUN" 646 LET E=9 647 LET A=9 650 LET E$="EIGHTEEN CHAR STRI" 652 LET N$="" 654 LET F$=E$ 655 IF A<>E THEN 658 656 LET G$="NG" 658 PRINT F$;""; N$; G$; " SB EIGHTEEN CHAR STRING" 670 PRINT "COMPARISON OF STRINGS" 672 IF E$<>E$ THEN 674 673 PRINT "A"; 674 IF N$<>"" THEN 676 675 PRINT "B"; 676 IF "PIG"<>"PIG" THEN 678 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 677 PRINT "C"; 678 IF"" = " " THEN 680 ***NO SPACE FOLLOWS KEYWORD ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 679 PRINT "D"; 680 IF "PIG"="PIT" THEN 682 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 681 PRINT "E"; 682 IF G$="EIGHTEEN CHAR PTRI" THEN 684 683 PRINT "F"; 684 IF E$ > E$ THEN 686 ***ILLEGAL STRING EXPRESSION 685 PRINT "G"; 686 IF E$"B" THEN 690 ***NO SPACE FOLLOWS KEYWORD ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 689 PRINT "I"; 690 PRINT " SB ABCDEFGHI" 691 PRINT "J"; 692 IF"A">="A:" THEN 694 ***NO SPACE FOLLOWS KEYWORD ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 693 PRINT "K"; 694 IF "A:"<="A" THEN 696 ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 695 PRINT "L"; 696 IF E$<="EIGHTEEN CHAR STRG" THEN 698 ***ILLEGAL STRING EXPRESSION 697 PRINT "M"; 698 IF":"<""THEN 700 ***NO SPACE FOLLOWS KEYWORD ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 699 PRINT "N"; 700 IF "2"<"1" THEN 710 ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 701 PRINT "O"; 710IFE$=F$THEN712 ***NO SPACE FOLLOWS KEYWORD ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 711 PRINT " STRING ERROR 1" 712 IF "" ="" THEN 714 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 713 PRINT " STRING ERROR 2" 714 IF E$<>"EIGHTEEN CHAR STRG" THEN 716 715 PRINT " STRING ERROR 3" 716 IF E$ >"EIGHTEEN CHAR STRG" THEN 718 ***ILLEGAL STRING EXPRESSION 717 PRINT " STRING ERROR 4" 718 IF":"> "" THEN 720 ***NO SPACE FOLLOWS KEYWORD ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 719 PRINT " STRING ERROR 5" 720 IF "EIGHTEEN CHAR STRG" =E$ THEN 726 ***ILLEGAL STRING EXPRESSION 725 PRINT " STRING ERROR 8" 726 IF E$<=E$ THEN 728 ***ILLEGAL STRING EXPRESSION 727 PRINT " STRING ERROR 9" 728 IF "012345678901"<="012345678911" THEN 730 ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 729 PRINT " STRING ERROR 10" 730 IF ":">="" THEN 732 ***ILLEGAL STRING EXPRESSION ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 731 PRINT " STRING ERROR 11" 732 PRINT "P SB JKLMNOP" 750 PRINT "EXPRESSION EVALUATION TESTS" 752 PRINT 3-1-1; 1+2*.5; 15-4*3; 56/7/2; " SB 1 THRU 4" 754 DEF FNU(X)=X+1*1 756 LET U(3,4)=2 758 PRINT (2+8)/2; (((4))+(-(-(2))));FNU(4+6/3); U(6/3+1,3*2-2)^4-8; 760 PRINT " SB 5 THRU 8" 762 PRINT3-(2+U(-5+4*2,6 + FNU(3^2+6)-18) ) +6; " SB 5", 2^3^4; " SB ***NON-BLANK CHARACTERS OCCUR AFTER POSITION 72 ***SPACES MUST PRECEDE AND FOLLOW KEYWORD ***NO MATCHING CLOSING QUOTE IN STRING 764 PRINT-2^2,-(+1+2^2);-2*9^.5;-56/2^3; " SB -4 THRU -7" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 766 PRINT(1E38+1E-38)-(1E38-1E-38)+5.7; " SB 5.7" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 768 IF 1+2*3^4=168-125/5^2 THEN 770 ***WARNING - NO VARIABLES IN RELATIONAL EXPRESSIONS 769 PRINT "EXPRESSION EVALUATION ERROR" 770 PRINT 6*10/4; 2^2*4; 3/3*17; 1*3*1*3*2*1/1; " SB 15 THRU 18" 772 PRINT-3^2; -4*2,-8+1; -(+(-(+(-5))))-1; " SB -9 THRU -6" ***SPACES MUST PRECEDE AND FOLLOW KEYWORD 800 PRINT "ARRAY TESTS" 802 DIM A(1),B(1,2),C(3,4), D(5,11) 804 LET A(0)=1 806 LET A(1)=2 808 LET B(0,0)=3 810 LET B(A(0),2)=4 812 LET X(0)=5 814 LET X(10)=6 816 LET Y(0,0)=7 818 LET Y(10,10)=Y(0,0)+A(0) 820 PRINT A(0);A(A(A(0))-1);B(0,0);B(1,3-1); " SB 1 THRU 4" 822 PRINT X(0); X(10); Y(2*0,0);Y(10,10); " SB 5 THRU 8" 824 DEF FNC=M(N+M+N(0,A(0)-1)-2) 826 LET N(0,0)=10 828 LET M(10)=9 829 LET M=5 830 LET N=-M+2 832 LET M(0)=N(0,0)-2 834 PRINT FNC;M(.49); M(10.49)-2; 836 LET X(9)=10.4 838 PRINT M(X(M(X( FNC+1-1)-.3))+1-SGN(N(0,0)))^.5*2; " SB 9 THRU 6" 850 FOR I=1 TO 3 852 FOR J=0 TO 4 854 GOTO 856 856 DIM Q(3,4) 858 DEF FNF=2 859 LET Q(I,J)=FNF^(I-1) 860 IF I=1 THEN 862 861 LET Q(I,J)=Q(I,J)+Q(I-1,J) 862 FOR K=1 TO J 864 LET Q(I,K)=Q(I,K)+Q(I,K-1) 866 NEXT K 868 NEXT J 870 NEXT I 872 PRINT 2^Q(1,2); Q(1,4); Q(2,4); Q(3,4); " SB 8192,23,156,642 " 874 LET X(FNC+X(3*3)-INT(11.9)-RND*.4)= 11 876 PRINT X(N(0,0)^A(0)-2)^A(1); " SB 121" 900 PRINT "TEST DATA AND INPUT" 902 GOTO 904 904 DATA 3 , "EIGHTEEN CHAR STRI", EIGHTEEN CHAR STRI 906 LET E$="EIGHTEEN CHAR STRI" 908 READ X 910 GO SUB 1050 918DATA"" ***NO SPACE FOLLOWING STATEMENT NUMBER ***NO SPACE FOLLOWS KEYWORD 926 DATA 3.0,4.0 , .05E2 ,600E-02,.007E+3,8.00000001 928 FOR I=1 TO 6 930 READ J 932 PRINT J; 934 NEXT I 936 PRINT " SB 3 THRU 8" 938DATA -4,+5,-60E-1,2,10,4 ***NO SPACE FOLLOWING STATEMENT NUMBER 940 READ A,B,C 942 PRINT A,-B,C," SB -4 THRU -6" 944 LET I=3 946 READ I,X(I),X ( X ( I ) ) 948 PRINT I,X(2),X(10)," SB 2,10,4" 950 READ I,J,I,J,X(2),X(J) 952 DATA 20,200,1,2 953 DATA 2000,.30 954 PRINT I,J,X(2)*10, " IS 1 THRU 3" 956 DEF FNH(I)=X(I+1)-14 958 LET X(6)=20 960 READ J,X(FNH(J)) 962 DATA 5,10 964 PRINT J,X(6)," SB 5,10" 966 DATA" ", . ,",..." ***NO SPACE FOLLOWS KEYWORD 968 READ A$,B$,C$ 970 PRINT "+.+" ; A$ ; "+";B$;"+";C$; " SB +.+ +.+,..." 972 DATA AZ09* ):$ , =<>-å(..+E;/. ***STATEMENT CONTAINS NON-STANDARD CHARACTER ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING ***NON-STANDARD CHARACTER IN UNQUOTED STRING 974 DATA"AZ09* ):$" , "=<>-å(..+E;/." ***STATEMENT CONTAINS NON-STANDARD CHARACTER ***NO SPACE FOLLOWS KEYWORD 976 READ A$,B$,Y$,Z$ 978 PRINT A$;B$;Y$;Z$ 979 PRINT " SB AZ09* ):$=<>-å(..+E;/. (REPEATED TWICE)" ***STATEMENT CONTAINS NON-STANDARD CHARACTER 980 RESTORE 982 READ Y 984 PRINT X,Y," SB 3,3" 985 GOSUB 1050 986 FOR I=1 TO 20 988 RESTORE 990 NEXT I 992 FOR J=1 TO 9 994 READ C$ 996 NEXT J 998 PRINT C$," SB .007E+3" 1000 GO TO 1100 1050 REM SUBROUTINE TO CHECK STRING INPUT 1052 READ F$,G$ 1053 READ N$ 1054 GO TO 1058 1056 INPUT F$,G$ 1057 INPUT N$ 1058 IF F$<>G$ THEN 1066 1060 IF F$=E$ THEN 1068 1066 PRINT " DATA ERROR 1 WITH:";F$,G$ 1068 IF N$="" THEN 1072 1070 PRINT " DATA ERROR 2 WITH:";N$ 1072 LET F$="RUBBISH1" 1074 LET G$="RUBBISH2" 1076 LET N$="RUBBISH3" 1078 RETURN 1100 PRINT "NOW REPEAT USING INPUT FOR READ" 1108 INPUT X0 1110 GOSUB 1056 1128 INPUT J1,J2,J3,J4,J5,J6 1130 PRINT J1,J2,J3 1134 PRINT J4,J5,J6 1136 PRINT " IS 3 THRU 8" 1140 INPUT A,B,C 1142 PRINT A,-B,C," IS -4 THRU -6" 1146 INPUT I,X(I),X(X(I)) 1148 PRINT I,X(2),X(10)," IS 2,10,4" 1150 INPUT I,J0,I,J0,R(2),R(J0) 1154 PRINT I,J0,R(2)*10, " IS 1 THRU 3" 1158 LET X(6)=20 1160 INPUT J0,X(FNH(J0)) 1164 PRINT J0,X(6)," IS 5,10" 1166 LET C$="1234567890123456" 1168 INPUT A$,B$,C$ 1170PRINT "+.+" ; A$ ; "+";B$;"+";C$; " SB +.+ +.+,..." ***NO SPACE FOLLOWING STATEMENT NUMBER 1176 INPUT A$,B$ 1177 INPUT P$,Q$ 1178 PRINT A$ ; B$;P$;Q$ 1179PRINT " SB AZ09* ):$=<>-å(..+E;/. (REPEATED TWICE)" ***STATEMENT CONTAINS NON-STANDARD CHARACTER ***NO SPACE FOLLOWING STATEMENT NUMBER 1184 PRINT X0,X,Y," IS 3,3,3" 1190 REM NOW INTERMIX READ WITH INPUT 1192 RESTORE 1194 READ X 1196 INPUT X0 1198 READ F$ 1200 INPUT S$,T$ 1201 INPUT G$ 1202 READ G$,N$ 1204 GOSUB 1058 1206 PRINT X,X0,S$,T$," IS 3 THRU 6" 5000 REM TEST SPACING ERRORS ***ONE OR MORE SPACES PRECEEDING STATEMENT NUMBER 5001 DEF FN L=1 ***SPACES NOT PERMITTED IN VARIABLE NAME 5002 DEF F ND=1 ***SPACES NOT PERMITTED IN VARIABLE NAME 5003 RANDOMIZ E ***SPACES IN KEYWORD 5004 PRINT A $ ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5005 LET A 1=3 5006 PRINT SI N(X) ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5007 DEF FNJ=RN D ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5008 G O TO 5009 ***SPACES IN KEYWORD 5009 IF A> =3 THEN 5010 ***SPACES NOT ALLOWED WITHIN MULTICHARACTER RELATIONAL SYMBOL 5010 IF S< > S THEN 5011 ***SPACES NOT ALLOWED WITHIN MULTICHARACTER RELATIONAL SYMBOL 5011 FOR A1=1 TO 3 STE P 6 ***SPACES NOT ALLOWED WITHIN KEYWORD 5013 NEXT A 1 ***SPACES NOT PERMITTED IN VARIABLE NAME 5014 PRINT FN J ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5015 PRINT 23 45 ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5016 PRINT 2. 1 ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5017 PRINT 5.6E 9 ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 5018 PRINT 1.2E- 9 ***SPACES NOT PERMITTED IN NUMBER/VARIABLE/FUNCTION NAME 31000 STOP ***STATEMENT NUMBER EXCEEDS MAXIMUM ALLOWED 31001 PRINT "ERROR IN STOP" ***STATEMENT NUMBER EXCEEDS MAXIMUM ALLOWED 31999 END ***STATEMENT NUMBER EXCEEDS MAXIMUM ALLOWED ***ARRAY AND SIMPLE NUMERIC NAME CLASHES A B C D M N Q R U V X Y *** ILLEGAL JUMPS INTO FOR BLOCKS-CHECKS ABANDONED 498 STATEMENTS PROCESSED 152 ERROR MESSAGES OUTPUT LINE NUMBER CROSS REFERENCE TABLE --------------------------------- 6 - 18 8 - 6 12 - 15 14 - 9 17 - 12 24 * - 20 30 - 21 63 - 61 78 - 72 74 85 - 82 86 - 85 87 - 85 88 - 87 89 - 87 88 90 - 88 103 - 101 105 - 103 107 - 105 109 - 107 111 - 109 113 - 111 115 - 113 117 * - 115 123 - 121 125 - 123 127 - 125 129 - 127 131 - 129 133 - 131 135 - 133 139 - 135 200 - 139 210 - 204 280 - 276 290 * - 480 294 - 291 300 - 288 306 - 322 314 - 310 320 - 304 330 - 302 350 - 318 378 - 382 422 - 418 500 * - 202 210 600 * - 218 605 - 620 630 - 615 640 - 499 658 - 655 674 - 672 676 - 674 678 - 676 680 - 678 682 - 680 684 - 682 686 - 684 688 - 686 690 - 688 694 - 692 696 - 694 698 - 696 700 - 698 710 - 700 712 - 710 714 - 712 716 - 714 718 - 716 720 - 718 722 - 720 724 - 722 726 - 724 728 - 726 730 - 728 732 - 730 770 - 768 856 - 854 862 - 860 904 - 902 1050 * - 910 985 1056 - 1110 1058 - 1054 1204 1066 - 1058 1068 - 1060 1072 - 1068 1100 - 1000 5009 - 5008 5010 - 5009 5011 - 5010 VARIABLES AND FUNCTION CROSS REFERENCE TABLE -------------------------------------------- SIMPLE VARIABLES A - 5 17 18 151 254 258 262 266 270 274 278 432 444 472 647 655 940 942 1140 1142 5009 A0 - 151 A1 - 151 5005 5011 5013 A2 - 151 A3 - 151 A4 - 151 A5 - 151 A6 - 151 A7 - 151 A8 - 151 A9 - 151 B - 152 434 444 470 940 942 1140 1142 B0 - 186 B1 - 152 B2 - 152 B3 - 152 B4 - 152 B5 - 152 B6 - 152 B7 - 152 B8 - 152 B9 - 152 C - 153 436 444 468 940 942 1140 1142 C0 - 186 C1 - 153 C2 - 153 C3 - 153 C4 - 153 C5 - 153 C6 - 153 C7 - 153 C8 - 153 C9 - 153 D - 154 438 444 466 D0 - 154 D1 - 154 D2 - 154 D3 - 154 D4 - 154 D5 - 154 D6 - 154 D7 - 154 D8 - 154 D9 - 154 E - 155 252 254 261 440 444 464 646 655 E0 - 186 E1 - 155 E2 - 155 E3 - 155 E4 - 155 E5 - 155 E6 - 155 E7 - 155 E8 - 155 E9 - 155 F - 156 222 446 454 462 622 630 F0 - 186 F1 - 156 F2 - 156 F3 - 156 F4 - 156 F5 - 156 F6 - 156 F7 - 156 F8 - 156 F9 - 156 G - 157 448 454 460 G0 - 186 G1 - 157 G2 - 157 G3 - 157 G4 - 157 G5 - 157 G6 - 157 G7 - 157 G8 - 157 G9 - 157 H - 158 450 454 458 H0 - 186 H1 - 158 H2 - 158 H3 - 158 H4 - 158 H5 - 158 H6 - 158 H7 - 158 H8 - 158 H9 - 158 I - 159 242 244 246 300 306 314 320 330 350 354 356 360 368 370 372 378 384 386 390 392 396 399 400 410 412 414 416 422 452 454 456 850 859 860 861 864 870 928 934 944 946 948 950 954 956 986 990 1146 1148 1150 1154 I0 - 186 I1 - 159 I2 - 159 I3 - 159 I4 - 159 I5 - 159 I6 - 159 I7 - 159 I8 - 159 I9 - 159 J - 160 308 312 852 859 861 862 868 930 932 950 954 960 964 992 996 J0 - 186 1150 1154 1160 1164 J1 - 160 1128 1130 J2 - 160 1128 1130 J3 - 160 1128 1130 J4 - 160 1128 1134 J5 - 160 1128 1134 J6 - 160 1128 1134 J7 - 160 J8 - 160 J9 - 160 K - 186 362 364 366 862 864 866 K0 - 186 K1 - 161 K2 - 161 K3 - 161 K4 - 161 K5 - 161 K6 - 161 K7 - 161 K8 - 161 K9 - 161 L - 162 L0 - 186 L1 - 162 L2 - 162 L3 - 162 L4 - 162 L5 - 162 L6 - 162 L7 - 162 L8 - 162 L9 - 162 M - 164 824 829 830 M0 - 187 M1 - 164 M2 - 164 M3 - 164 M4 - 164 M5 - 164 M6 - 164 M7 - 164 M8 - 164 M9 - 164 N - 163 824 830 N0 - 187 N1 - 163 N2 - 163 N3 - 163 N4 - 163 N5 - 163 N6 - 163 N7 - 163 N8 - 163 N9 - 163 O - 165 O0 - 187 O1 - 165 O2 - 165 O3 - 165 O4 - 165 O5 - 165 O6 - 165 O7 - 165 O8 - 165 O9 - 165 P - 166 268 270 272 274 276 376 380 382 386 388 390 394 396 P0 - 187 P1 - 166 P2 - 166 P3 - 166 P4 - 166 P5 - 166 P6 - 166 P7 - 166 P8 - 166 P9 - 166 Q - 167 389 390 398 Q0 - 187 Q1 - 167 Q2 - 167 Q3 - 167 Q4 - 167 Q5 - 167 Q6 - 167 Q7 - 167 Q8 - 167 Q9 - 167 R - 185 R0 - 185 R1 - 185 R2 - 185 R3 - 185 R4 - 185 R5 - 185 R6 - 185 R7 - 185 R8 - 185 R9 - 185 S - 168 5010 S0 - 187 S1 - 168 S2 - 168 S3 - 168 S4 - 168 S5 - 168 S6 - 168 S7 - 168 S8 - 168 S9 - 168 T - 169 T0 - 169 T1 - 169 T2 - 169 T3 - 169 T4 - 169 T5 - 169 T6 - 169 T7 - 169 T8 - 169 T9 - 169 U - 170 U0 - 170 U1 - 170 U2 - 170 U3 - 170 U4 - 170 U5 - 170 U6 - 170 U7 - 170 U8 - 170 U9 - 170 V - 171 286 288 291 292 294 296 V0 - 171 V1 - 171 V2 - 171 V3 - 171 V4 - 171 V5 - 171 V6 - 171 V7 - 171 V8 - 171 V9 - 171 W - 172 W0 - 172 W1 - 172 W2 - 172 W3 - 172 W4 - 172 W5 - 172 W6 - 172 W7 - 172 W8 - 172 W9 - 172 X - 52 53 63 65 68 71 174 754 908 984 1184 1194 1206 5006 X0 - 174 1108 1184 1196 1206 X1 - 174 214 306 320 610 615 618 X2 - 174 216 306 330 622 630 X3 - 81 85 88 174 X4 - 174 X5 - 174 X6 - 174 X7 - 174 X8 - 174 X9 - 174 Y - 175 982 984 1184 Y0 - 187 Y1 - 175 Y2 - 175 Y3 - 175 Y4 - 175 Y5 - 175 Y6 - 175 Y7 - 175 Y8 - 175 Y9 - 175 Z - 176 Z0 - 176 Z1 - 176 Z2 - 176 Z3 - 176 Z4 - 176 Z5 - 176 Z6 - 176 Z7 - 176 Z8 - 176 Z9 - 64 176 256 258 260 266 STRING VARIABLES A$ - 180 968 970 976 978 1168 1170 1176 1178 5004 B$ - 180 968 970 976 978 1168 1170 1176 1178 C$ - 180 968 970 994 998 1166 1168 1170 D$ - 180 E$ - 180 650 654 672 684 686 696 710 714 716 720 724 726 906 1060 F$ - 180 654 658 710 1052 1056 1058 1060 1066 1072 1198 G$ - 180 656 658 682 1052 1056 1058 1066 1074 1201 1202 H$ - 181 I$ - 181 J$ - 181 K$ - 181 L$ - 181 M$ - 181 N$ - 181 652 658 674 722 1053 1057 1068 1070 1076 1202 O$ - 182 P$ - 182 1177 1178 Q$ - 182 1177 1178 R$ - 182 S$ - 182 1200 1206 T$ - 182 1200 1206 U$ - 187 V$ - 184 W$ - 184 X$ - 184 Y$ - 184 976 978 Z$ - 184 976 978 NUMERIC ARRAYS A - 802 804 806 810 818 820 824 876 B - 802 808 810 820 C - 802 D - 802 M - 824 828 832 834 838 N - 824 826 832 838 876 Q - 856 859 861 864 872 R - 1150 1154 U - 756 758 762 V - 14 X - 812 814 822 836 838 874 876 946 948 950 954 956 958 960 964 1146 1148 1158 1160 1164 Y - 816 818 822 USER DEFINED FUNCTIONS FNA - 62 64 70 72 FNB - 63 64 65 70 71 FNC - 824 834 838 874 FND - 5002 FNF - 858 859 FNH - 956 960 1160 FNJ - 5007 5014 FNK - 65 74 75 FNL - 5001 FNO - 605 615 618 FNU - 754 758 762 FNV - 8 FNY - 255 256 306 368 FNZ - 64 71 STANDARD FUNCTIONS INT - 874 RND - 87 641 643 645 874 5007 SGN - 87 838 SIN - 5006 TAB FUNCTION TAB - 42 51 STATEMENT TYPE CROSS REFERENCE TABLE ------------------------------------ DATA - 904 918 926 938 952 953 962 966 972 974 DEF - 8 62 63 64 65 255 605 754 824 858 956 5001 5002 5007 DIM - 14 802 856 END - 31999 FOR - 242 254 256 270 286 300 308 350 356 362 368 378 390 410 412 432 434 436 438 440 446 448 450 452 850 852 862 928 986 992 5011 GOSUB - 20 202 204 210 218 302 480 620 910 985 1110 1204 GOTO - 6 9 12 15 21 61 139 304 310 318 322 418 499 854 902 1000 1054 5008 IF - 18 72 74 101 103 105 107 109 111 113 115 121 123 125 127 129 131 133 135 276 288 291 382 615 655 672 674 676 678 680 682 684 686 688 692 694 696 698 700 710 712 714 716 718 720 722 724 726 728 730 768 860 1058 1060 1068 5009 5010 INPUT - 1056 1057 1108 1128 1140 1146 1150 1160 1168 1176 1177 1196 1200 1201 LET - 5 17 52 68 81 214 216 252 261 268 272 320 330 376 380 388 389 394 396 398 618 622 630 646 647 650 652 654 656 756 804 806 808 810 812 814 816 818 826 828 829 830 832 836 859 861 864 874 906 944 958 1072 1074 1076 1158 1166 5005 NEXT - 246 260 262 278 294 312 314 354 360 366 372 384 399 416 420 456 458 460 462 464 466 468 470 472 866 868 870 934 990 996 5013 ON - 82 85 87 88 PRINT - 4 7 30 32 33 34 35 36 37 38 39 41 42 43 44 45 46 47 48 49 50 51 53 54 55 60 70 71 73 75 78 83 86 89 90 102 104 106 108 110 112 114 116 120 122 124 126 128 130 132 134 136 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 174 175 176 180 181 182 184 185 186 187 200 212 220 222 240 244 248 258 264 266 274 280 292 296 306 316 352 358 364 370 374 386 392 400 414 422 430 444 454 498 502 610 640 641 643 645 658 670 673 675 677 679 681 683 685 687 689 690 691 693 695 697 699 701 711 713 715 717 719 721 723 725 727 729 731 732 750 752 758 760 762 764 766 769 770 772 800 820 822 834 838 872 876 900 932 936 942 948 954 964 970 978 979 984 998 1066 1070 1100 1130 1134 1136 1142 1148 1154 1164 1170 1178 1179 1184 1206 5004 5006 5014 5015 5016 5017 5018 31001 RANDOMIZE - 642 644 5003 READ - 908 930 940 946 950 960 968 976 982 994 1052 1053 1194 1198 1202 REM - 1 2 24 40 100 117 150 206 290 500 600 1050 1190 5000 RESTORE - 980 988 1192 RETURN - 25 298 332 504 624 632 1078 STOP - 31000 FILE CONTAINING ALL THE CHARACTERS USED IN PBASIC THE UPPER CASE ALPHABET "ABCDEFGHIJKLMNOPQRSTUVWXYZ" THE NUMERALS ZERO TO NINE "0123456789" PLUS ASCII 2/11 "+" MINUS ASCII 2/13 "-" CLOSE ASCII 2/9 ")" EQUALS ASCII 3/13 "=" PERIOD ASCII 2/14 "." OPEN ASCII 2/8 "(" ASTERISK ASCII 2/10 "*" SLANT ASCII 2/15 "/" SPACE ASCII 2/0 " " LESS THAN ASCII 3/12 "<" GREATER THAN ASCII 3/14 ">" CIRCUMFLEX ASCII 5/14 "^" QUOTE ASCII 2/2 """ EXCLAMATION POINT ASCII 2/1 "]" NUMBER SIGN ASCII 2/3 "#" DOLLAR ASCII 2/4 "$" PERCENT ASCII 2/5 "%" AMPERSAND ASCII 2/6 "&" APOSTROPHE ASCII 2/7 "'" COLON ASCII 3/10 ":" SEMI COLON ASCII 3/11 ";" QUESTION MARK ASCII 3/15 "?" UNDERLINE ASCII 5/15 "_" COMMA ASCII 2/12 ","