C.......... THE MINICOMPILER C ************************* C * * C * OVERVIEW * C * * C ************************* C C C THIS PROGRAM IS A COMPILER WHICH TAKES AS DATA A PROGRAM WRITTEN C IN A SIMPLE PROGRAMMING LANGUAGE ( A DESCRIPTION OF WHICH FOLLOWS) C AND PRODUCES AS OUTPUT A TRANSLATION OF THAT PROGRAM INTO A SERIES C OF ASSIGNMENT STATEMENTS. THE STRAIGHT LINE CODE TRANSLATION IS C PRINTED IN A READABLE FORM FOR THE COMPILER USER AND ALSO PUNCHED C IN A CODED FORM FOR USE AS INPUT TO ANY OF SEVERAL ROUNDOFF ERROR C ANALYSIS PROGRAMS OF WEBB MILLER. C THE MAIN ROUTINE OF THE COMPILER IS AN LL-1 PARSING ROUTINE. IT C CALLS THE LEXICAL ANALYZER TO PRODUCE INTERNAL TOKENS BY SCANNING C THE SOURCE CODE. THE PARSER ALSO CALLS THE ROUTINE CODGEN WHICH C PRODUCES INTERMEDIATE CODE FOR THE INTERPRETER AND WHICH PERFORMS C SOME SYNTAX CHECKING AND OTHER PERIPHERAL FUNCTIONS NECESSARY C FOR PARSING. C WHEN THE ENTIRE INPUT HAS BEEN SCANNED AND PARSED, THE INTERPRETING C ROUTINES ARE ACTIVATED. THESE INTERPRET THE INTERMEDIATE CODE AND C GENERATE THE FINAL STRAIGHT LINE PRINTED AND PUNCHED OUTPUT. DURING C INTERPRETATION, ALL INTEGER EXPRESSIONS ARE ACTUALLY EVALUATED IN C ORDER TO PERFORM THE CORRECT NUMBER OF ITERATIONS OF EXPLICIT FOR- C LOOPS AND OF FOR-LOOPS IMPLICIT IN SUMMATION EXPRESSIONS, AND TO C INTERPRETIVELY PERFORM IF-THEN TESTS. IN CONTRAST, NO ACTUAL C REAL ARITHMETIC COMPUTATION IS DONE. THROUGHOUT, ALL REAL C VARIABLES ARE TREATED SYMBOLICALLY AS BEING THE N-TH INPUT VALUE, C INTERMEDIATE VALUE, OR REAL CONSTANT. C BOTH THE LEXICAL ANALYZER AND THE INTERPRETER COMPRISE SEVERAL SUB- C ROUTINES.IN ADDITION THERE ARE COLLECTIONS OF SYMBOL TABLE ROUTINES, C ERROR ROUTINES AND ROUTINES TO PRINT AND PUNCH THE COMPILER'S C OUTPUT. C IF ANY ERRORS ARE ENCOUNTERED DURING PARSING, THE PARSER CONTINUES C TO CHECK FOR SYNTAX ERRORS, BUT NO FURTHER INTERMEDIATE CODE WILL BE C GENERATED, AND NO INTERPRETATION WILL TAKE PLACE. SIMILARLY, IF C EXECUTION ERRORS ARE IDENTIFIED DURING INTERPRETATION, NO STRAIGHT C LINE CODE WILL BE EITHER PRINTED OR PUNCHED. C C C ************************************** C * * C * THE SOURCE LANGUAGE * C * * C ************************************** C C C THE LANGUAGE TO BE COMPILED IS A SIMPLE LANGUAGE DESIGNED FOR C CODING NUMERICAL ALGORITHMS. IT BASICALLY INCLUDES REAL ASSIGN- C MENT STATEMENTS, DIMENSION STATEMENTS AND SOME BLOCK STRUCTURE C IMPOSED BY FOR-LOOPS, AND IF-THEN TESTS. THERE ARE NO MIXED-MODE C ARITHMETIC EXPRESSIONS, AND NO STATEMENT LABELS. INTEGER EXPRESSIONS C AND VARIABLES ARE USED ONLY FOR DIMENSIONING REAL ARRAYS, FOR C DEFINING BOUNDS IN FOR-LOOPS AND SUMMATION EXPRESSION LOOPS, AND FOR C VARIABLES TO BE TESTED IN IF-THEN STATEMENTS. C THE CARD FORMAT IS SIMILAR TO FORTRAN. STATEMENTS APPEAR C IN COLUMNS 7-72, AND A 1 IN COLUMN 6 INDICATES CONTINUATION. A C C IN COLUMN 1 INDICATES A COMMENT. C THERE ARE NINE STATEMENT TYPES, BRIEFLY DESCRIBED BELOW: C C 1. THE TEST STATEMENT C C USE: TO ASSIGN VALUES TO INTEGER VARIABLES WHICH WILL THEMSELVES C BE USED TO DIMENSION REAL ARRAYS. C C FORM: TEST(I1,I2,I3,...) C C WHERE EACH I IS AN ASSIGNMENT STATEMENT OF THE FORM C INTEGER VARIABLE = INTEGER CONSTANT. C C 2. THE DIMENSION STATEMENT C C USE: TO ASSIGN DIMENSIONS TO ARRAYS. THE ARRAY NAME MAY BE C EITHER A DEFAULT REAL OR INTEGER IDENTIFIER. ITS USE IN C THE DIMENSION STATEMENT CONSTITUTES AN IMPLICIT REAL C DECLARATION. C C FORM: DIMENSION(D1,D2,D3 ..) C C WHERE EACH D IS OF ONE OF THE FOLLOWING FORMS: C IDENTIFIER(I) C IDENTIFIER(I1,I2) C AND EACH I IS AN INTEGER VARIABLE OR INTEGER CONSTANT. C C NOTE: DIMENSION AND TEST STATEMENTS ARE NON-EXECUTABLE AND MUST C PRECEED ALL EXECUTABLE STATEMENTS. IN ADDITION, AN INTEGER C VARIABLE APPEARING IN A DIMENSION STATEMENT MUST BE ASSIGNED A C VALUE IN A PRECEEDING TEST STATEMENT. C C 3. THE INPUT/OUTPUT STATEMENTS C C USE: TO NOTIFY THE COMPILER THAT CERTAIN VALUES WILL BE SUPPLIED C BY THE PROGRAMMER AS INITIAL VALUES FOR REAL VARIABLES WHEN C THE STRAIGHT LINE CODE IS USED AS INPUT FOR A ROUNDOFF ERROR C ANALYSIS; OR THAT CERTAIN REAL VARIABLES ARE EXPECTED TO C RECEIVE VALUES AS A RESULT OF RUNNING THE PROGRAM BEING C COMPILED. C C FORM: INPUT(D1,D2,D3,...) C OUTPUT(D1,D2,D3,..) C C EACH D IS EITHER THE NAME OF A REAL SCALAR, A SINGLE ARRAY C ELEMENT, OR AN ENTIRE ARRAY. IN THE LATTER CASE THE ARRAY C WILL BE INPUT(OUTPUT) IN COLUMN MAJOR ORDER. C NOTE THAT ONLY VALUES WHICH ARE THE RESULT OF A C COMPUTATION MAY BE OUTPUT. CONSTANTS OR DATA VALUES C MAY NOT BE OUTPUT. C C 4. THE REAL ASSIGNMENT STATEMENT C C USE: TO ASSIGN A VALUE TO A REAL VARIABLE C C FORM: REAL VARIABLE = REAL EXPRESSION C C WHERE THE REAL VARIABLE IS EITHER A REAL SCALAR OR SINGLE C ARRAY ELEMENT. REAL EXPRESSIONS ARE MADE UP OF REAL C VARIABLES AND CONSTANTS COMBINED WITH THE BINARY OPERATORS C +, -, * AND / AND THE UNARY OPERATORS UNARY - AND SQRT. C (THE OPERAND OF THE SQRT MUST APPEAR IN PARENTHESES.) C (NOTE THAT THERE IS NO REAL EXPONENTIATION ALLOWED.) C OPERATOR PRECEDENCE IS AS IN STANDARD FORTRAN. IN ADDITION C THERE IS A SUMMATION OPERATION ON ARRAY VECTORS, IN EFFECT, C A BUILT-IN INNER PRODUCT. A SUMMATION EXPRESSION CAN APPEAR C IN A REAL EXPRESSION AND IS OF THE FORM: C C SUMMATION(D1 * D2, SUMMATION-VARIABLE = INTEXP1 TO INTEXP2) C C WHERE INTEXP IS AN INTEGER EXPRESSION, THE SUMMATION C VARIABLE IS ANY INTEGER IDENTIFIER NAME, AND WHERE D1 AND D2 C ARE EACH OF ONE OF THE FORMS: C ARRAY NAME(SUMMATION-VARIABLE) C ARRAY NAME(SUMMATION-VARIABLE,SUMMATION-VARIABLE) C ARRAY NAME(SUMMATION-VARIABLE,INTEXP) C ARRAY NAME(INTEXP,SUMMATION-VARIABLE) C C A SUMMATION EXPRESSION WILL BE INTERPRETED AS AN IMPLICIT C FOR-LOOP. ANY USE OF THE SUMMATION VARIABLE IN THE INTEGER C EXPRESSIONS BOUNDING THE SUMMATION LOOP WILL BE FLAGGED AS C AN ERROR. C C 5. THE FOR STATEMENT C C USE: AS A MEANS OF INDICATING THAT A BLOCK OF STATEMENTS IS TO BE C ITERATIVELY EXECUTED A SPECIFIED NUMBER OF TIMES. C C FORM: FOR INTEGER-VARIABLE = INTEXP1 TO INTEXP2 BY INCREMENT C C WHERE INTEXP STANDS FOR INTEGER EXPRESSION, AND INCREMENT IS C WRITTEN AS EITHER +1, -1 OR 1. C C INTERPRETATION: ALL STATEMENTS UP TO THE END STATEMENT MATCHING C THIS FOR STATEMENT (SEE BELOW FOR DISCUSSION OF END C STATEMENTS) WILL BE ITERATIVELY INTERPRETED AS IN A FORTRAN C DO LOOP, EXCEPT THAT NEGATIVE INCREMENTS ARE ALLOWED AND IN C THIS CASE, THE LOOP VARIABLE TEST IS DONE AT THE TOP OF THE C LOOP. THUS, EMPTY LOOPS ARE POSSIBLE, THAT IS THOSE WHICH C WILL NOT BE EXECUTED AT ALL. (NOTE THE SAME IS TRUE OF THE C IMPLICIT FOR-LOOP IN A SUMMATION EXPRESSION.) C C 6. THE IF-THEN STATEMENT C C USE: TO ALLOW SELECTIVE EXECUTION OF A BLOCK OF STATEMENTS C DEPENDING ON THE OUTCOME OF A COMPARISON OF THE VALUES OF C TWO INTEGER EXPRESSIONS. C C FORM: IF INTEXP1 .R. INTEXP2 THEN C C WHERE INTEXP STANDS FOR INTEGER EXPRESSION AND R IS ONE OF C THE RELATIONS WRITTEN EQ,NE,GT,LT,LE OR GE WITH THE C STANDARD FORTRAN DENOTATION. NOTE THAT THERE ARE NO C PARENTHESES AROUND THE RELATIONAL EXPRESSION. C C INTERPRETATION: IF THE TEST SUCCEEDS, THAT IS IF THE TWO INTEGER C EXPRESSIONS ARE RELATED IN THE INDICATED WAY AT THE TIME OF C INTERPRETATION, THEN ALL THE STATEMENTS UP TO THE NEXT END C STATEMENT WILL BE INTERPRETED. OTHERWISE, THE FIRST C EXECUTABLE STATEMENT FOLLOWING THE NEXT END STATEMENT WILL C BE THE NEXT STATEMENT INTERPRETED. C C 7. THE END STATEMENT C C USE: TO DEFINE THE ENDS OF BLOCKS OF STATEMENTS BEGINNING WITH C FOR STATEMENTS OR IF-THEN STATEMENTS. C C FORM1: END C FORM2 : END(INTEGER-VARIABLE) C C MEANING: WHEN FORM 1 IS USED THE EFFECT IS TO CLOSE THE BLOCK OF C STATEMENTS BEGINNING AT THE NEAREST PRECEEDING FOR OR C IF-THEN STATEMENT. C WHEN FORM2 IS USED THE EFFECT IS TO CLOSE THE FOR BLOCK C WHOSE LOOP VARIABLE MATCHES THE END STATEMENT VARIABLE. IN C ADDITION, ANY FOR OR IF-THEN BLOCKS WHICH BEGIN BETWEEN THIS C END STATEMENT AND ITS MATCHING FOR STATEMENT ARE CLOSED. C THIS INTERPRETATION IMPOSES STANDARD FORTRAN LIKE NESTING C CONVENTIONS ON FOR AND IF-THEN BLOCKS. THAT IS, A SEQUENCE C OF STATEMENTS C FOR K = IE1 TO IE2 BY 1 C . C . C FOR I = IE3 TO IE4 BY 1 C . C . C END(K) C . C END(I) C WILL RESULT IN AN ERROR MESSAGE WHEN THE END(I) STATEMENT C IS ENCOUNTERED, BECAUSE BOTH FOR STATEMENTS WILL HAVE BEEN C CLOSED BY THE PARSER WHEN THE END(K) STATEMENT WAS PARSED. C C NOTE: ADDITIONAL RESTRICTIONS ON BLOCK STRUCTURES: C 1) AT MOST EIGHT FOR AND/OR IF-THEN BLOCKS CAN BE BEGUN C BEFORE AN END STATEMENT OCCURS. C 2) A FOR LOOP VARIABLE CANNOT BE USED AGAIN AS AN EXPLICIT C FOR LOOP VARIABLE WITHIN ITS ORIGINAL LOOP. IT CAN BE C REUSED AS A SUMMATION VARIABLE, HOWEVER. C C C 8. THE COMPOSITION STATEMENT C C USE: TO REPRESENT THE TEST PROGRAM AS THE COMPOSITION OF TWO C COMPUTATIONS SO THAT THE ERROR-ANALYSIS SOFTWARE CAN C TEST FOR INHERENT INSTABILITY, I.E., INSTABILITY THAT C PERSISTS REGARDLESS OF HOW THE TWO COMPUTATIONS ARE C PERFORMED. C C FORM: COMPOSITION C C 9. THE STOP STATEMENT C C USE: TO DENOTE THE END OF THE PROGRAM C C FORM: *STOP C C ************************************************************** C * * C * NAMING INPUT/OUTPUT DEVICES IN FORMAT STATEMENTS * C * * C ************************************************************** C C THE CURRENT VALUES ARE 5,6 AND 7 FOR (RESP.) CARD READER, LINE C PRINTER AND THE DEVICE FOR THE OUTPUT PREPARED FOR THE ROUNDOFF C ANALYSIS SOFTWARE. TO CHANGE THESE VALUES MERELY ALTER THE BLOCK C DATA INITIALIZATION OF COMMON AREA /IO/ JUST BELOW. C C C **************************** C * * C * THE PARSE TABLE * C * * C **************************** C C IN THE DOCUMENTATION OF THE PARSER WHICH FOLLOWS, THE SYMBOLS C OF THE GRAMMAR AND THE RULES OF THE GRAMMAR ARE DESCRIBED. THE PARSE C TABLE ITSELF IS NOT EXPLICITLY DESCRIBED BECAUSE IT IS TOO BIG TO C PRINT OUT IN COMMENTS. THE FOLLOWING CODE, FOLLOWED BY THE BLOCK C DATA SUBROUTINE IN THIS PROGRAM WILL CAUSE THE PARSE TABLE TO C BE PRINTED OUT. IN THE PRINT OUT, THE COLUMNS REPRESENT THE TOKENS C COMING TO THE PARSER FROM THE LEXICAL ANALYZER, AND THE ROWS C REPRESENT THE NONTERMINALS ON THE PARSE STACK. AN ENTRY OF -1 IN THE C TABLE INDICATES AN ERROR. ANY OTHER ENTRY IS THE INDEX OF THE RULE C BY WHICH THE TOP ENTRY OF THE PARSESTACK SHOULD BE EXPANDED. C CODE: C C COMMON /PARSER/P,R C INTEGER P(26,31),R(58,14) C 10 FORMAT('0',5X,5HI 0,30I4) C 20 FORMAT(' ',6H-----I,124(1HI)) C 30 FORMAT(' ',I2,3X,1HI,31I4) C 40 FORMAT(' ',5X,1HI) C WRITE(6,10) (I,I=1,30) C WRITE(6,20) C DO 100 I=1,26 C WRITE(6,40) C 100 WRITE(6,30) I,(P(I,J),J=1,31) C STOP C END C C BLOCK DATA C C IO INPUT/OUTPUT DEVICE NUMBERS: C NREAD CARD READER C NPRINT LINE PRINTER C NPUNCH DEVICE FOR PUNCHED OUTPUT (PREPARED FOR THE C ROUNDOFF ANALYSIS SOFTWARE.) C C SYMTAB THE COLLECTION OF ARRAYS WHICH MAKE UP THE SYMBOL TABLE, C INCLUDING: C NAME IDENTIFIER, UP TO 10 CHARACTERS, FILLED OUT C WITH BLANKS C TYPE SIGNIFIES WHETHER REAL OR INTEGER CONSTANT, C REAL OR INTEGER VARIABLE, OR ONE OR TWO C DIMENSIONAL ARRAY C VALUE FOR REAL AND INTEGER CONSTANTS AND VARIABLES C THIS CONTAINS THEIR VALUE; FOR ARRAYS C THIS IS A POINTER TO THE AUXILIARY STORAGE C SET ASIDE FOR THE ELEMENTS OF THE ARRAY C ROWS THE NUMBER OF ROWS IN AN ARRAY; FOR REAL AND C INTEGER CONSTANTS AND VARIABLES THIS IS C ALWAYS ZERO C COLS THE NUMBER OF COLUMNS IN AN ARRAY; FOR REAL C AND INTEGER CONSTANTS AND VARIABLES AND C ONE DIMENSIONAL ARRAYS THIS IS ALWAYS ZERO C DEFIND INDICATES WHETHER OR NOT A VALUE HAS BEEN C ASSIGNED C NPRINT LINE PRINTER C AUXVAL AUXILIARY STORAGE FOR ARRAY ELEMENTS; IF THE C AUXVAL CORRESPONDING TO A PARTICULAR C ELEMENT OF A PARTICULAR ARRAY IS ZERO C THIS MEANS THE ELEMENT IS UNDEFINED C C MISC MISCELLANEOUS COLLECTION OF CODES, COUNTERS, AND POINTERS C INCLUDING: C INTVAR CODE FOR INTEGER VARIABLE -- SET TO 0 C INTCON CODE FOR INTEGER CONSTANT -- SET TO 1 C REAVAR CODE FOR REAL VARIABLE -- SET TO 2 C ONEDIM CODE FOR ONE DIMENSIONAL ARRAY -- SET TO 3 C TWODIM CODE FOR TWO DIMENSIONAL ARRAY -- SET TO 4 C REACON CODE FOR REAL CONSTANT -- SET TO 5 C VAR CODE FOR VARIABLE, INTEGER OR REAL -- C SET TO -1 C AUXPTR POINTER TO LAST USED WORD OF AUXILIARY STORAGE C AUXLIM LIMIT ON TOTAL NUMBER OF WORDS OF AUXILIARY C STORAGE SET ASIDE FOR ARRAY ELEMENTS -- C SET TO 300 C SYMPTR POINTER TO LAST USED ENTRY IN SYMBOL TABLE C SYMLIM LIMIT ON TOTAL NUMBER OF ENTRIES IN SYMBOL C TABLE -- SET TO 50 C I SET TO THE INTERNAL CODE FOR THE LETTER I; C USED IN DETERMINING WHETHER A VARIABLE IS C INTEGER OR REAL ACCORDING TO THE FORTRAN C CONVENTION FOR THE FIRST LETTER OF THE NAME C N SET TO THE INTERNAL CODE FOR THE LETTER N; C USED ALONG WITH I AS DESCRIBED ABOVE C C ERRCT GLOBAL ERROR COUNT C C REACNT COUNTER WHICH IS INCREMENTED EACH TIME A REAL CONSTANT C IS ADDED TO THE SYMBOL TABLE; THE CONSTANT IS THEN C ASSIGNED THE NEGATIVE OF THE CURRENT VALUE OF REACNT C C SUPP ARRAY CONTAINING THE NAMES OF ALL REAL CONSTANTS IN C THE SYMBOL TABLE C COMMON /IO/ NREAD,NPRINT,NPUNCH C /SYMTAB/ NAME,TYPE,VALUE,ROWS,COLS,DEFIND, C AUXVAL C /MISC/ INTVAR,INTCON,REAVAR,ONEDIM,TWODIM, C REACON,VAR,AUXPTR,AUXLIM,SYMPTR, C SYMLIM,I,N C /TEMP/ SUPP,REACNT C /ERRNUM/ ERRCT C /FIN/ FDAT,FINT,FOUT,KDAT,KINT,KOUT C /SUM/ DUM,NULTAB,NULVAL,NULSTM C /INTCOD/ ICODE,LINE C /ITEMPS/ ITEM,TOP C /ATTSTK/ ASTACK,ATOP C /PARSER/ P,R C /OPTS/ F0,F1,OPT C /COMPOZ/ NCUT LOGICAL NULSTM,DEFIND(50) LOGICAL DUM INTEGER NAME (50,10), TYPE (50), VALUE (50), ROWS (50), C COLS (50), AUXVAL (300), INTVAR, INTCON, REAVAR, C ONEDIM, TWODIM, REACON, VAR, AUXPTR, AUXLIM, C ATOP, SYMPTR, SYMLIM, I, N, REACNT, SUPP (20,10), C R(58,14),P(26,31),FDAT(50,2),FINT(500,5),FOUT(20,3), C ASTACK(30),ICODE(500,11),ITEM(30),ERRCT,RD5,LP6,BT7 C ,F0,F1,OPT C C ********************************************* C * DECLARE I/O DEVICE NUMBERS * C ********************************************* DATA NREAD,NPRINT,NPUNCH /5,6,7/ C DATA NAME(1,1), NAME(1,2), NAME(1,3), NAME(1,4), NAME(1,5), C NAME(1,6), NAME(1,7), NAME(1,8), NAME(1,9), NAME(1,10) C / 1H*, 1HI, 1HN, 1HT, 1HR, 1H , 1H , 1H , 1H , 1H /, C TYPE(1) , VALUE(1) /3,1/, C INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, C AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N, REACNT, C ERRCT,ATOP,KDAT,KINT,KOUT,NULTAB,NULVAL,NULSTM, C DUM C / 0, 1, 2, 3, 4, 5, -1, 200, 300, 1, 50, C 1HI, 1HN, 7*0 , 50 , .TRUE. , .FALSE./ C DATA F0,F1,OPT/0,0,1/ DATA NCUT/0/ C C ************************************** C * INITIALIZATION OF THE PARSE TABLE * C ************************************** DATA P(1,1),P(1,2),P(1,3),P(1,4),P(1,5),P(1,6),P(1,7),P(1,8), * P(1,9),P(1,10),P(1,11),P(1,12),P(1,13),P(1,14),P(1,15),P(1,16) * /-1,-1,4,4,4,-1,7,-1,1,-1,-1,2,-1,3,-1,5/,P(1,17),P(1,18), * P(1,19),P(1,20),P(1,21),P(1,22),P(1,23),P(1,24),P(1,25),P(1,26), * P(1,27),P(1,28),P(1,29),P(1,30),P(1,31)/6,11*-1,58,2*-1/, * P(2,1),P(2,2),P(2,3),P(2,4),P(2,5),P(2,6),P(2,7),P(2,8),P(2,9), * P(2,10),P(2,11),P(2,12),P(2,13),P(2,14),P(2,15),P(2,16),P(2,17), * P(2,18),P(2,19),P(2,20),P(2,21),P(2,22),P(2,23),P(2,24),P(2,25), * P(2,26),P(2,27),P(2,28),P(2,29),P(2,30),P(2,31) * /-1,10,17*-1,8,9,10*-1/,P(3,1),P(3,2),P(3,3),P(3,4),P(3,5),P(3,6) * ,P(3,7),P(3,8),P(3,9),P(3,10),P(3,11),P(3,12),P(3,13),P(3,14), * P(3,15),P(3,16),P(3,17),P(3,18),P(3,19),P(3,20),P(3,21),P(3,22), * P(3,23),P(3,24),P(3,25),P(3,26),P(3,27),P(3,28),P(3,29),P(3,30), * P(3,31)/23*-1,11,3*-1,0,3*-1/,P(4,1),P(4,2),P(4,3),P(4,4),P(4,5), * P(4,6),P(4,7),P(4,8),P(4,9),P(4,10),P(4,11),P(4,12),P(4,13), * P(4,14),P(4,15),P(4,16),P(4,17),P(4,18),P(4,19),P(4,20),P(4,21), * P(4,22),P(4,23),P(4,24),P(4,25),P(4,26),P(4,27),P(4,28),P(4,29), * P(4,30),P(4,31)/-1,-1,12,13,14,26*-1/ DATA P(5,1),P(5,2),P(5,3),P(5,4),P(5,5),P(5,6),P(5,7),P(5,8), * P(5,9),P(5,10),P(5,11),P(5,12),P(5,13),P(5,14),P(5,15),P(5,16), * P(5,17),P(5,18),P(5,19),P(5,20),P(5,21),P(5,22),P(5,23),P(5,24), * P(5,25),P(5,26),P(5,27),P(5,28),P(5,29),P(5,30),P(5,31) * /23*-1,15,16,16,5*-1/,P(6,1),P(6,2),P(6,3),P(6,4),P(6,5),P(6,6), * P(6,7),P(6,8),P(6,9),P(6,10),P(6,11),P(6,12),P(6,13),P(6,14), * P(6,15),P(6,16),P(6,17),P(6,18),P(6,19),P(6,20),P(6,21),P(6,22), * P(6,23),P(6,24),P(6,25),P(6,26),P(6,27),P(6,28),P(6,29),P(6,30), * P(6,31)/23*-1,17,16,16,5*-1/,P(7,1),P(7,2),P(7,3),P(7,4),P(7,5), * P(7,6),P(7,7),P(7,8),P(7,9),P(7,10),P(7,11),P(7,12),P(7,13), * P(7,14),P(7,15),P(7,16),P(7,17),P(7,18),P(7,19),P(7,20),P(7,21), * P(7,22),P(7,23),P(7,24),P(7,25),P(7,26),P(7,27),P(7,28),P(7,29), * P(7,30),P(7,31)/24*-1,0,18,5*-1/ ,P(8,1),P(8,2),P(8,3),P(8,4), *P(8,5),P(8,6),P(8,7),P(8,8),P(8,9),P(8,10),P(8,11),P(8,12),P(8,13) * ,P(8,14),P(8,15),P(8,16),P(8,17),P(8,18),P(8,19),P(8,20),P(8,21), * P(8,22),P(8,23),P(8,24),P(8,25),P(8,26),P(8,27),P(8,28),P(8,29), * P(8,30),P(8,31)/24*-1,0,19,5*-1/ DATA P(9,1),P(9,2),P(9,3),P(9,4),P(9,5),P(9,6),P(9,7),P(9,8), * P(9,9),P(9,10),P(9,11),P(9,12),P(9,13),P(9,14),P(9,15),P(9,16), * P(9,17),P(9,18),P(9,19),P(9,20),P(9,21),P(9,22),P(9,23),P(9,24), * P(9,25),P(9,26),P(9,27),P(9,28),P(9,29),P(9,30),P(9,31) * /21,-1,20,23,22,26*-1/,P(10,1),P(10,2),P(10,3),P(10,4),P(10,5), * P(10,6),P(10,7),P(10,8),P(10,9),P(10,10),P(10,11),P(10,12), * P(10,13),P(10,14),P(10,15), P(10,16),P(10,17),P(10,18),P(10,19), * P(10,20),P(10,21),P(10,22),P(10,23),P(10,24),P(10,25),P(10,26), * P(10,27),P(10,28),P(10,29),P(10,30),P(10,31)/24*-1,24,25,5*-1/, * P(11,1),P(11,2),P(11,3),P(11,4),P(11,5),P(11,6),P(11,7), * P(11,8),P(11,9),P(11,10),P(11,11),P(11,12),P(11,13),P(11,14), * P(11,15),P(11,16),P(11,17),P(11,18),P(11,19),P(11,20),P(11,21), * P(11,22),P(11,23),P(11,24),P(11,25),P(11,26),P(11,27),P(11,28), * P(11,29),P(11,30),P(11,31)/24*-1,0,26,5*-1/,P(12,1),P(12,2), * P(12,3),P(12,4),P(12,5),P(12,6),P(12,7),P(12,8),P(12,9), * P(12,10),P(12,11),P(12,12),P(12,13),P(12,14),P(12,15), * P(12,16),P(12,17),P(12,18),P(12,19),P(12,20),P(12,21),P(12,22), * P(12,23),P(12,24),P(12,25),P(12,26),P(12,27),P(12,28),P(12,29), * P(12,30),P(12,31)/27,27,18*-1,28,-1,-1,27,7*-1/ DATA P(13,1),P(13,2),P(13,3),P(13,4),P(13,5),P(13,6),P(13,7), * P(13,8),P(13,9),P(13,10),P(13,11),P(13,12),P(13,13),P(13,14), * P(13,15),P(13,16),P(13,17),P(13,18),P(13,19),P(13,20),P(13,21), * P(13,22),P(13,23),P(13,24),P(13,25),P(13,26),P(13,27),P(13,28), * P(13,29),P(13,30),P(13,31) */9*-1,0,0,-1,0,6*-1,29,30,3*-1,0,0,4*-1,0/,P(14,1),P(14,2),P(14,3) *,P(14,4),P(14,5),P(14,6),P(14,7),P(14,8),P(14,9),P(14,10),P(14,11) * ,P(14,12),P(14,13),P(14,14),P(14,15),P(14,16),P(14,17),P(14,18), * P(14,19),P(14,20),P(14,21),P(14,22),P(14,23),P(14,24),P(14,25), * P(14,26),P(14,27),P(14,28),P(14,29),P(14,30),P(14,31) * /2*31,21*-1,31,7*-1/,P(15,1),P(15,2),P(15,3),P(15,4),P(15,5), * P(15,6),P(15,7),P(15,8),P(15,9),P(15,10),P(15,11),P(15,12), * P(15,13),P(15,14),P(15,15),P(15,16),P(15,17),P(15,18),P(15,19), * P(15,20),P(15,21),P(15,22),P(15,23),P(15,24),P(15,25),P(15,26), * P(15,27),P(15,28),P(15,29),P(15,30),P(15,31) */9*-1,0,0,-1,0,6*-1,0,0,32,33,-1,0,0,-1,0,-1,-1,0/,P(16,1),P(16,2) * ,P(16,3),P(16,4),P(16,5),P(16,6),P(16,7),P(16,8),P(16,9),P(16,10) * ,P(16,11),P(16,12),P(16,13),P(16,14),P(16,15),P(16,16),P(16,17), * P(16,18),P(16,19),P(16,20),P(16,21),P(16,22)/35,36,20*-1/ DATA P(16,23),P(16,24),P(16,25),P(16,26),P(16,27),P(16,28), * P(16,29),P(16,30),P(16,31)/-1,34,7*-1/,P(17,1),P(17,2),P(17,3), * P(17,4),P(17,5),P(17,6),P(17,7),P(17,8),P(17,9),P(17,10),P(17,11) * ,P(17,12),P(17,13),P(17,14),P(17,15),P(17,16),P(17,17),P(17,18), * P(17,19),P(17,20),P(17,21),P(17,22),P(17,23),P(17,24),P(17,25), * P(17,26),P(17,27),P(17,28),P(17,29),P(17,30),P(17,31) * /2*-1,37,38,39,26*-1/,P(18,1),P(18,2),P(18,3),P(18,4),P(18,5), * P(18,6),P(18,7),P(18,8),P(18,9),P(18,10),P(18,11),P(18,12), * P(18,13),P(18,14),P(18,15),P(18,16),P(18,17),P(18,18),P(18,19), * P(18,20),P(18,21),P(18,22),P(18,23),P(18,24),P(18,25),P(18,26), * P(18,27),P(18,28),P(18,29),P(18,30),P(18,31) * /2*-1,4*40,-1,40,9*-1,40,2*-1,41,-1,-1,40,7*-1/,P(19,1),P(19,2), *P(19,3),P(19,4),P(19,5),P(19,6),P(19,7),P(19,8),P(19,9),P(19,10), * P(19,11),P(19,12),P(19,13),P(19,14),P(19,15),P(19,16),P(19,17), * P(19,18),P(19,19),P(19,20),P(19,21),P(19,22),P(19,23),P(19,24), * P(19,25),P(19,26),P(19,27),P(19,28),P(19,29),P(19,30),P(19,31) * /19*-1,42,43,3*-1,0,2*-1,0,3*-1/ DATA P(20,1),P(20, 2),P(20,3),P(20,4),P(20,5),P(20,6),P(20,7), * P(20,8),P(20,9),P(20,10),P(20,11),P(20,12),P(20,13),P(20,14), * P(20,15),P(20,16),P(20,17),P(20,18),P(20,19),P(20,20),P(20,21), * P(20,22),P(20,23),P(20,24),P(20,25),P(20,26),P(20,27),P(20,28), * P(20,29),P(20,30),P(20,31)/2*-1,4*44,-1,44,9*-1,44,5*-1,44,7*-1/ DATA P(21,1),P(21,2),P(21,3),P(21,4),P(21,5),P(21,6),P(21,7), * P(21,8),P(21,9),P(21,10),P(21,11),P(21,12),P(21,13),P(21,14), * P(21,15),P(21,16),P(21,17),P(21,18),P(21,19),P(21,20), * P(21,21),P(21,22),P(21,23),P(21,24),P(21,25),P(21,26),P(21,27), * P(21,28),P(21,29),P(21,30),P(21,31) * /19*-1,0,0,45,46,-1,0,2*-1,0,3*-1/,P(22,1),P(22,2),P(22,3), *P(22,4),P(22,5),P(22,6),P(22,7),P(22,8),P(22,9),P(22,10),P(22,11), * P(22,12),P(22,13),P(22,14),P(22,15),P(22,16),P(22,17),P(22,18), * P(22,19),P(22,20),P(22,21),P(22,22),P(22,23),P(22,24),P(22,25), * P(22,26),P(22,27),P(22,28),P(22,29),P(22,30),P(22,31) */-1,-1,3*56,57,-1,49,9*-1,47,5*-1,48,7*-1/,P(23,1),P(23,2),P(23,3) *,P(23,4),P(23,5),P(23,6),P(23,7),P(23,8),P(23,9),P(23,10),P(23,11) * ,P(23,12),P(23,13),P(23,14),P(23,15),P(23,16),P(23,17),P(23,18), * P(23,19),P(23,20),P(23,21),P(23,22),P(23,23),P(23,24),P(23,25), * P(23,26),P(23,27),P(23,28),P(23,29),P(23,30),P(23,31) * /3*-1,50,51,26*-1/ DATA P(24,1),P(24,2),P(24,3),P(24,4),P(24,5),P(24,6),P(24,7), * P(24,8),P(24,9),P(24,10),P(24,11),P(24,12),P(24,13),P(24,14), * P(24,15),P(24,16),P(24,17),P(24,18),P(24,19),P(24,20),P(24,21), * P(24,22),P(24,23),P(24,24),P(24,25),P(24,26),P(24,27),P(24,28), * P(24,29),P(24,30),P(24,31)/2*52,18*-1,52,2*-1,52,5*-1,53,-1/, * P(25,1),P(25,2),P(25,3),P(25,4),P(25,5),P(25,6),P(25,7), * P(25,8),P(25,9),P(25,10),P(25,11),P(25,12),P(25,13),P(25,14), * P(25,15),P(25,16),P(25,17),P(25,18),P(25,19),P(25,20),P(25,21), * P(25,22),P(25,23),P(25,24),P(25,25),P(25,26),P(25,27),P(25,28), * P(25,29),P(25,30),P(25,31)/2*55,18*-1,55,2*-1,55,5*-1,54,-1/, * P(26,1),P(26,2),P(26,3),P(26,4),P(26,5),P(26,6),P(26,7),P(26,8), * P(26,9),P(26,10),P(26,11),P(26,12),P(26,13),P(26,14),P(26,15), * P(26,16),P(26,17),P(26,18),P(26,19),P(26,20),P(26,21),P(26,22), * P(26,23),P(26,24),P(26,25),P(26,26),P(26,27),P(26,28),P(26,29), * P(26,30),P(26,31)/21,10,29*-1/ C C ****************************************** C * INITIALIZATION OF RULES OF THE GRAMMAR * C ****************************************** DATA R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8), * R(1,9),R(1,10),R(1,11)/10,8,0,18,112,9,112,10,102,220,27/, * R(2,1),R(2,2),R(2,3),R(2,4),R(2,5),R(2,6),R(2,7),R(2,8), * R(2,9),R(2,10)/9,11,112,30,26,30,112,12,216,27/,R(3,1),R(3,2), * R(3,3),R(3,4),R(3,5)/4,13,103,221,27/,R(4,1),R(4,2),R(4,3), * R(4,4),R(4,5),R(4,6)/5,117,18,118,214,27/,R(5,1),R(5,2),R(5,3), * R(5,4),R(5,5),R(5,6),R(5,7),R(5,8)/7,15,23,104,217,107,24,27/, * R(6,1),R(6,2),R(6,3),R(6,4),R(6,5),R(6,6),R(6,7),R(6,8), * R(6,9),R(6,10)/9,16,23,0,18,1,218,108,24,27/,R(7,1),R(7,2),R(7,3) * ,R(7,4),R(7,5),R(7,6),R(7,7),R(7,8),R(7,9),R(7,10),R(7,11), * R(7,12)/11,6,23,109,23,126,110,24,219,111,24,27/,R(8,1),R(8,2), * R(8,3)/2,19,1/,R(9,1),R(9,2),R(9,3),R(9,4)/3,20,1,222/, * R(10,1),R(10,2)/1,1/,R(11,1),R(11,2),R(11,3),R(11,4)/3,23,0,24/, * R(12,1),R(12,2),R(12,3),R(12,4)/3,2,212,212/,R(13,1),R(13,2), *R(13,3)/2,3,105/,R(14,1),R(14,2),R(14,3)/2,4,106/,R(15,1),R(15,2), * R(15,3),R(15,4),R(15,5)/4,23,112,24,212/ DATA R(16,1),R(16,2),R(16,3)/2,212,212/,R(17,1),R(17,2), * R(17,3),R(17,4),R(17,5),R(17,6)/5,23,112,25,112,24/,R(18,1), * R(18,2),R(18,3),R(18,4),R(18,5)/4,25,104,217,107/,R(19,1), * R(19,2),R(19,3),R(19,4),R(19,5),R(19,6),R(19,7)/ * 6,25,0,18,1,218,108/,R(20,1),R(20,2)/1,2/,R(21,1),R(21,2)/ * 1,0/,R(22,1),R(22,2)/1,4/,R(23,1),R(23,2)/1,3/,R(24,1),R(24,2)/ * 1,212/,R(25,1),R(25,2),R(25,3)/2,25,126/,R(26,1),R(26,2),R(26,3), * R(26,4),R(26,5),R(26,6),R(26,7),R(26,8),R(26,9)/ * 8,25,109,23,126,110,24,219,111/,R(27,1),R(27,2),R(27,3)/ * 2,114,113/,R(28,1),R(28,2),R(28,3),R(28,4),R(28,5)/ * 4,20,114,211,113/,R(29,1),R(29,2),R(29,3),R(29,4),R(29,5)/ * 4,19,114,207,113/,R(30,1),R(30,2),R(30,3),R(30,4),R(30,5)/ * 4,20,114,208,113/,R(31,1),R(31,2),R(31,3)/2,116,115/,R(32,1), * R(32,2),R(32,3),R(32,4),R(32,5)/4,21,116,209,115/,R(33,1),R(33,2) * ,R(33,3),R(33,4),R(33,5)/4,22,116,210,115/ DATA R(34,1),R(34,2),R(34,3),R(34,4)/3,23,112,24/,R(35,1), * R(35,2),R(35,3)/2,0,215/,R(36,1),R(36,2),R(36,3)/2,1,215/, * R(37,1),R(37,2),R(37,3),R(37,4)/3,2,212,212/,R(38,1),R(38,2), * R(38,3),R(38,4),R(38,5),R(38,6)/5,3,23,112,24,212/,R(39,1), * R(39,2),R(39,3),R(39,4),R(39,5),R(39,6),R(39,7)/ * 6,4,23,112,25,112,24/,R(40,1),R(40,2),R(40,3)/2,120,119/, * R(41,1),R(41,2),R(41,3),R(41,4),R(41,5),R(41,6),R(41,7),R(41,8)/ * 7,20,120,3*212,206,119/,R(42,1),R(42,2),R(42,3),R(42,4),R(42,5)/ * 4,19,120,201,119/,R(43,1),R(43,2),R(43,3),R(43,4),R(43,5)/ * 4,20,120,202,119/,R(44,1),R(44,2),R(44,3)/2,122,121/,R(45,1), *R(45,2),R(45,3),R(45,4),R(45,5)/4,21,122,203,121/,R(46,1),R(46,2), *R(46,3),R(46,4),R(46,5)/4,22,122,204,121/,R(47,1),R(47,2),R(47,3), * R(47,4),R(47,5),R(47,6),R(47,7)/8,17,23,118,24,2*212 /,R(47,8), * R(47,9)/212,205/,R(48,1),R(48,2),R(48,3),R(48,4)/3,23,118,24/, * R(49,1),R(49,2),R(49,3),R(49,4),R(49,5),R(49,6),R(49,7),R(49,8), *R(49,9),R(49,10),R(49,11)/13,7,23,123,21,123,25,29,18,112,9/, *R(49,12),R(49,13),R(49,14)/112,24,224/,R(50,1),R(50,2),R(50,3), * R(50,4),R(50,5),R(50,6),R(50,7)/6,3,23,29,213,24,212/,R(51,1), * R(51,2),R(51,3),R(51,4),R(51,5)/4,4,23,124,24/ DATA R(52,1),R(52,2),R(52,3),R(52,4),R(52,5)/4,112,25,29,213/, * R(53,1),R(53,2),R(53,3),R(53,4),R(53,5)/4,29,213,25,125/, * R(54,1),R(54,2),R(54,3)/2,29,213/,R(55,1),R(55,2)/1,112/,R(56,1), * R(56,2)/1,117/,R(57,1),R(57,2),R(57,3),R(57,4)/3,5,212,212/, * R(58,1),R(58,2),R(58,3)/2,28,223/ C C END C C ******************************************* C * * C * MAIN PROGRAM (THE PARSER) * C * * C ******************************************* C * * C * GENERAL DESCRIPTION * C * * C ******************************************* C C THE PARSER PERFORMS AN LL-1 PARSE AND TRANSLATION BASED ON C INPUT TOKENS FROM THE LEXICAL ANALYZER. INITIALLY (AT THE C BEGINNING OF THE PARSING OF EACH STATEMENT) THE PARSE STACK C CONTAINS ONLY THE GRAMMATICAL SYMBOL WHICH IS THE SENTENTIAL C NONTERMINAL. WHENEVER A NONTERMINAL IS ON TOP OF THE PARSE STACK C THE PARSER REFERS TO THE PARSETABLE TO SEE IF THE CURRENT INPUT C TOKEN IS AN INSTANCE OF THE FIRST SYMBOL OF A POSSIBLE EXPANSION C OF THAT NONTERMINAL BY A RULE OF THE GRAMMAR. IF SO, THE C PARSETABLE ENTRY CORRESPONDING TO THE NONTERMINAL AND INPUT WILL C BE THE INDEX OF THE ENTRY OF THE RULES ARRAY IN WHICH THE RIGHT C HAND SIDE OF THE APPROPRIATE RULE IS STORED. THE NONTERMINAL ON C THE PARSESTACK WILL BE REPLACED BY THE INDICATED EXPANSION. IF C THE PARSE TABLE ENTRY HAD BEEN NEGATIVE, THEN AN SYNTAX ERROR HAS C BEEN ENCOUNTERED AND THE PARSERS ERROR ROUTINE WILL COMMENCE. C WHENEVER A TERMINAL IS ON TOP OF THE PARSE STACK AND IT MATCHES C THE CURRENT INPUT TOKEN, IT IS POPPED OFF THE STACK, AND THE INPUT C IS ADVANCED (THAT IS, THE LEXICAL ANALYZER IS CALLED TO PRODUCE THE C NEXT TOKEN.) IF A TERMINAL ON TOP OF THE PARSESTACK DOES NOT MATCH C THE INPUT, THIS INDICATES A SYNTAX ERROR, AND THE ERROR ROUTINE C BEGINS. C WHEN AN ACTION SYMBOL IS ON TOP OF THE PARSE STACK, THE CODE C GENERATOR IS CALLED TO PERFORM SOME ROUTINE DEPENDENT ON THE VALUE C OF THAT SYMBOL. C IN ADDITION TO SYNTACTIC ANALYSIS, THE PARSER ALSO PUSHES ANY C SEMANTIC INFORMATION ASSOCIATED WITH TOKENS ONTO A SUPPLEMENTARY C ATTRIBUTE STACK. THIS INFORMATION IS EITHER A SYMBOL TABLE INDEX C ASSOCIATED WITH A CONSTANT OR VARIABLE, AND INDICATOR OF WHETHER C AN I-O TOKEN REPRESENTS INPUT OR OUTPUT, OR AN INTEGER CODE C IDENTIFYING A PARTICULAR RELATION (GREATER THAN, EQUAL, LESSTHAN, C ETC.) ATTACHED TO A RELATION TOKEN. THE PARSER DOES NOT FURTHER C MANIPULATE THE ATTRIBUTE STACK. THE STACK ITSELF IS EMPTIED AT C THE COMPLETION OF PARSING EACH STATEMENT BY THE CODE GENERATOR. C C ******************************************************* C * * C * VARIABLES AND DATA STRUCTURES USED BY THE PARSER * C * * C ******************************************************* C C PSTACK(50) : THE PARSE STACK C PTOP : POINTER TO THE TOP OF PSTACK C ASTACK(30) : THE ATTRIBUTE STACK C ATOP : POINTER TO THE TOP OF ASTACK C (ASTACK AND ATOP ARE IN COMMON WITH CODGEN) C TYPE : THE INTERNAL NAME OF A TERMINAL (TOKEN) PASSED C TO THE PARSER BY A SUBROUITNE CALL TO LEXAN C ATTR : IF NOT EQUAL TO -1 THIS IS AN ATTRIBUTE C ASSOCIATED WITH A TOKEN AS DESCRIBED ABOVE C (PASSED TO THE PARSER BY A CALL TO LEXAN.) C P(26,31) : THE PARSE TABLE. THE ROWS CORRESPOND TO C NONTERMINALS, AND THE COLUMNS TO TERMINALS. C R(58,14) : THE RULES ARRAY. EACH ROW CONSISTS OF A FIRST C ENTRY WHICH TELLS HOW MANY SYMBOLS FOLLOW AND C THAT MANY ENTRIES WHICH CODE THE RIGHT HAND SIDE C A RULE. NOTE THAT SEVERAL RULES OF THE GRAMMAR C MAY HAVE THE SAME RIGHT HAND SIDES,WITH DIFFERENT C LEFT HAND SIDES. (SEE RULES BELOW) C ERR : THE COUNT OF ERRORS ENCOUNTERED SO FAR IN PARSING C (IN COMMON WITH ALL ERROR ROUTINES ) C ERRBIT : A LOGICAL VARIABLE WHICH IS FALSE AT THE START C OF PARSING EACH STATEMENT. IF AN ERROR IS C IDENTIFIED BY THE PARSER DURING THE ANALYSIS OF C THAT STATEMENT, ERRBIT IS SET TO TRUE, AND THE C PARSERS ERROR ROUTINE IS ACTIVATED. THIS CONSISTS C OF POPPING ALL ELEMENTS OFF THE PARSE STACK C EXCEPT FOR THE SYMBOL FOR END OF STATEMENT, AND C REPEATEDLY CALLING THE LEXICAL ANALYZER UNTIL C THE END OF STATEMENT TOKEN IS RETURNED. AT THAT C POINT, THE ERRBIT IS SET TO FALSE AGAIN, AND C PARSING CONTINUES. C C ********************************************************** C * * C * GRAMMATICAL SYMBOLS AND RULES OF THE GRAMMAR * C * * C ********************************************************** C C THE GRAMMATICAL SYMBOLS ARE LISTED BELOW. THE COMPILER USES ONLY C INTERNAL INTEGER CODES, BUT EACH SYMBOL HAS ALSO BEEN GIVEN A NAME C FOR CLARITY IN DOCUMENTATION. THE NAMES OF TERMINALS (TOKENS FROM C THE LEXICAL ANALYZER) ARE PREFACED BY A T, THE NAMES OF NONTERMINALS C ARE PREFACED BY AN N AND ACTION SYMBOLS (WHICH FUNCTIONS AS SIGNALS C TO THE PARSER TO CALL CODE GENERATION SUBROUTINES) ARE PREFACED BY AN C A. C C CODE NAME DESCRIPTION C C 0 T0 INTEGER VARIABLE C 1 T1 INTEGER CONSTANT C 2 T2 REAL SCALAR VARIABLE C 3 T3 ONE DIMENSIONAL ARRAY C 4 T4 TWO DIMENSIONAL ARRAY C 5 T5 REAL CONSTANT C 6 TDIM DIMENSION C 7 TSUM SUMMATION C 8 TFOR FOR C 9 TTO TO C 10 TBY BY C 11 TIF IF C 12 TTHEN THEN C 13 TEND END C 15 TI-O INPUT OR OUTPUT C 16 TTEST TEST C 17 TSQRT SQRT C 18 T= EQUAL SIGN C 19 T+ PLUS SIGN C 20 T- MINUS SIGN C 21 T* MULTIPLICATION SIGN C 22 T/ DIVISION SIGN C 23 T( LEFT PARENTHESIS C 24 T) RIGHT PARENTHESIS C 25 T, COMMA C 26 TREL RELATION NAME C 27 TEOS END OF STATEMENT C 28 TEOF END OF FILE C 29 TDUM SUMMATION VARIABLE C 30 TDOT PERIOD BEFORE OR AFTER RELATION NAME C C 101 NSENT STATEMENT C 102 NINC FOR STATEMENT INCREMENT C 103 NEND OPTIONAL INTEGER VARIABLE NAME IN END STATEMENT C 104 NIOVAR INPUT-OUTPUT VARIABLE C 105 NSUB2 OPTIONAL SINGLE SUBSCRIPT ON IO VARIABLE C 106 NSUB3 OPTIONAL DOUBLE SUBSCRIPT ON IO VARIABLE C 107 NIOLIST OPTIONAL ADDITIONAL INPUT-OUTPUT VARIABLES C 108 NTLIST OPTIONAL ADDITIONAL LIST OF INTEGER ASSIGNMENT C STATEMENTS C 109 NVAR ANY VARIABLE NAME C 110 NSUB1 OPTIONAL SECOND SUBSCRIPT IN ARRAY BEING C DIMENSIONED C 111 NDIMLIST OPTIONAL ADDITIONAL LIST OF ARRAY NAMES TO BE C DIMENSIONED C 112 NIE INTEGER EXPRESSION C 113 NIEX INTEGER EXPRESSION MINUS ITS FIRST TERM C 114 NIT INTEGER TERM C 115 NITX INTEGER TERM MINUS ITS FIRST FACTOR C 116 NIF INTEGER FACTOR C 117 NRV REAL VARIABLE NAME C 118 NRE REAL EXPRESSION C 119 NREX REAL EXPRESSION MINUS ITS FIRST TERM C 120 NRT REAL TERM C 121 NRTX REAL TERM MINUS ITS FIRST FACTOR C 122 NRF REAL FACTOR C 123 NMUL MULTIPLICAND IN SUMMATION EXPRESSION C 124 ND1 SUBSCRIPT LIST OF DOUBLY SUBSCRIPTED NMUL C 125 ND2 SECOND SUBSCRIPT OF ND1 C 126 NINT INTEGER VARIABLE OR CONSTANT C C 201 ARADD GENERATE INTERMEDIATE REAL ADDTION INSTRUCTION C 202 ARSUB GENERATE INTERMEDIATE REAL SUBTRACTION INSTRUCTION C 203 ARMUL GENERATE INTERMEDIATE REAL MULTIPLICATION C INSTRUCTION C 204 ARDIV GENERATE INTERMEDIATE REAL DIVISION INSTRUCTION C 205 ASQRT GENERATE INTERMEDIATE SQUARE ROOT INSTRUCTION C 206 AUMINUS GENERATE UNARY REAL MINUS INSTRUCTION C 207 AIMINUS DO INTEGER UNARY MINUS ROUTINE C 208 AIADD GENERATE INTERMEDIATE INTEGER ADD INSTRUCTION C 209 AISUB GENERATE INTERMEDIATE INTEGER SUBTRACTION C INSTRUCTION C 210 AIMUL GENERATE INTERMEDIATE INTEGER MULTIPLY INSTRUCTION C 211 AIDIV GENERATE INTERMEDIATE INTEGER DIVIDE INSTRUCTION C 212 A0PUSH PUSH A 0 ONTO THE ATTRIBUTE STACK C 213 A*PUSH PUSH A -1 ONTO THE ATTRIBUTE STACK C 214 ASTORE GENERATE INTERMEDIATE STORE INSTRUCTION C 215 ALOAD GENERATE INTERMEDIATE LOAD INSTRUCTION C 216 AIF MANIPULATE FOR STACK AND GENERATE INTERMEDIATE C TEST INSTRUCTION C 217 AI-O GENERATE INTERMEDIATE INPUT-OUTPUT INSTRUCTION C 218 ASSIGN STORE INTEGER VALUE IN SYMBOL TABLE ENTRY OF C INTEGER VARIABLE C 219 ADIM ASSIGN DIMENSIONS TO REAL VARIABLE C 220 AFOR MANIPULATE FOR-STACK AND DO FOR LOOP INTERMEDIATE C ROUTINE C 221 AEND MANIPULATE FOR STACK AND PREVIOUS INTERMEDIATE CODE C AND GENERATE INTERMEDIATE BRANCH INSTRUCTION C 222 ADEC INDICATE NEGATIVE FOR LOOP INCREMENT C 223 AEOF END OF FILE ROUTINE C 224 ASUM SUMMATION ACTIONS C 225 AEOS END OF STATEMENT ACTIONS C C C THE RULES OF THE GRAMMAR CONSIST OF A LEFT HAND SIDE WHICH IS A C SINGLE NONTERMINAL, AND A RIGHT HAND SIDE WHICH IS A STRING OF C TERMINALS, NONTERMINALS, AND ACTION SYMBOLS. THE LEFT HAND C SIDES ARE NOT STORED EXPLICITLY IN THE COMPILER BUT ARE GIVEN C BELOW FOR COMPLETENESS. PRECEEDING EACH RULE IS AN INTEGER C WHICH IS THE INDEX OF THE RULES ARRAY IN WHICH THE RIGHT HAND C SIDE IS STORED. IF THIS INTEGER IS ZERO, IT INDICATES THAT THE C RULE IS A NULL PRODUCTION. C C INDEX L.H.S. EXPANSION C C 1 NSENT : TFOR T0 T= NIE TTO NIE TBY NINC AFOR TEOS C 2 NSENT : TIF NIE TDOT TREL TDOT NIE TTHEN AIF TEOS C 3 NSENT : TEND NEND AEND TEOS C 4 NSENT : NRV T= NRE ASTORE TEOS C 5 NSENT : TI-O T( NIOVAR AI-O NIOLIST T) TEOS C 6 NSENT : TTEST T( T0 T= T1 ASSIGN NTLIST T) TEOS C 7 NSENT : TDIM T( NVAR T( NINT NSUB1 T) ADIM NDIMLIST T) TEOS C 58 NSENT : TEOF AEOF C C 8 NINC : T+ T1 C 9 NINC : T- T1 ADEC C 10 NINC : T1 C C 11 NEND : T( T0 T) C 0 NEND : C C 12 NIOVAR : T2 A0PUSH A0PUSH C 13 NIOVAR : T3 NSUB2 C 14 NIOVAR : T4 NSUB3 C C 15 NSUB2 : T( NIE T) A0PUSH C 16 NSUB2 : A0PUSH A0PUSH C C 16 NSUB3 : A0PUSH A0PUSH C 17 NSUB3 : T( NIE T, NIE T) C C 18 NIOLIST : T, NIOVAR AI-O NIOLIST C 0 NIOLIST : C C 19 NTLIST : T, T0 T= T1 ASSIGN NTLIST C 0 NTLIST : C C 20 NVAR : T2 C 21 NVAR : T0 C 22 NVAR : T4 C 23 NVAR : T3 C C 24 NSUB1 : A0PUSH C 25 NSUB1 : T, NINT C 0 NSUB1 : C C 26 NDIMLIST: T, NVAR T( NINT NSUB1 T) ADIM NDIMLIST C 0 NDIMLIST: C C 27 NIE : NIT NIEX C 28 NIE : T= NIT AIMINUS NIEX C C 29 NIEX : T+ NIT AIADD NIEX C 30 NIEX : T- NIT AISUB NIEX C 0 NIEX : C C 31 NIT : NIF NITX C C 32 NITX : T* NIF AIMUL NITX C 33 NITX : T/ NIF AIDIV NITX C 0 NITX : C C 34 NIF : T( NIE T) C 35 NIF : T0 ALOAD C 36 NIF : T1 ALOAD C C 37 NRV : T2 A0PUSH A0PUSH C 38 NRV : T3 T( NIE T) A0PUSH C 39 NRV : T4 T( NIE T, NIE T) C C 40 NRE : NRT NREX C 41 NRE : T- NRT A0PUSH A0PUSH A0PUSH AUMINUS NREX C C 42 NREX : T+ NRT ARADD NREX C 43 NREX : T- NRT ARSUB NREX C 0 NREX : C C 44 NRT : NRF NRTX C C 45 NRTX : T* NRF ARMUL NRTX C 46 NRTX : T/ NRF ARDIV NRTX C 0 NRTX : C C 47 NRF : TSQRT T( NRE T) A0PUSH A0PUSH A0PUSH ASQRT C 48 NRF : T( NRE T) C 49 NRF : TSUM T( NMUL T* NMUL T, TDUM T= NIE TTO NIE T) ASUM C 56 NRF : NRV C 57 NRF : T5 A0PUSH A0PUSH C C 50 NMUL : T3 T( TDUM A*PUSH T) A0PUSH C 51 NMUL : T4 T( ND1 T) C C 52 ND1 : NIE T, TDUM A*PUSH C 53 ND1 : TDUM A*PUSH T, ND2 C C 54 ND2 : TDUM A*PUSH C 55 ND2 : NIE C C 21 NINT : T0 C 10 NINT : T1 C INTEGER PSTACK(50), PTOP, ASTACK, ATOP, TYPE, ATTR, RULE, ERR COMMON /ATTSTK/ ASTACK(30), ATOP /PARSER/ P, R /ERRNUM/ ERR COMMON /IO/ NREAD, NPRINT, NPUNCH COMMON /STATE/ NBRSTM COMMON /INTCOD/ IC, T INTEGER IC(500,11), T LOGICAL ERRBIT INTEGER P(26,31), R(58,14) C C C CALL INITIALIZATION ROUTINES AND INITIALIZE THE PARSE STACK C AND INTERMEDIATE CODE ARRAY C T = 0 DO 20 I=1,500 DO 10 J=1,11 IC(I,J) = 0 10 CONTINUE 20 CONTINUE PTOP = 1 PSTACK(1) = 101 ERRBIT = .FALSE. CALL SYMINT CALL CODGEN(25) C C GET NEXT TOKEN FROM LEXICAL ANALYZER. ASSUMING NO ERROR C CONDITION, BRANCH ACCORDING TO TYPE OF STACK SYMBOL ON C TOP OF PARSE STACK. C 30 CALL LEXAN(TYPE, ATTR) IF (ERRBIT) GO TO 110 40 IF (PSTACK(PTOP).LT.100) GO TO 70 IF (PSTACK(PTOP).LT.200) GO TO 50 C C ACTION SYMBOL ON TOP OF PARSE STACK. CALL CODE GENERATOR AND POP C NSYM = PSTACK(PTOP) - 200 CALL CODGEN(NSYM) IF (NSYM.EQ.23) GO TO 120 PTOP = PTOP - 1 GO TO 40 C C NONTERMINAL ON TOP OF PARSE STACK. REPLACE IT BY ITS EXPANSION C ACCORDING TO 'TYPE' AS INDICATED BY THE PARSETABLE. IF THERE IS C NO LEGAL EXPANSION, SET ERROR CONDITION C 50 K = PSTACK(PTOP) - 100 RULE = P(K,TYPE+1) IF (RULE.LT.0) GO TO 100 PTOP = PTOP - 1 IF (RULE.EQ.0) GO TO 40 PTOP = PTOP + R(RULE,1) IF (PTOP.GT.50) CALL TERROR(4) K = R(RULE,1) DO 60 I=1,K J = PTOP + 1 - I PSTACK(J) = R(RULE,I+1) 60 CONTINUE GO TO 40 C C TERMINAL ON TOP OF PARSESTACK. SET ERROR CONDITION OF IT DOES C NOT MATCH 'TYPE'. ELSE, POP IT AND ADVANCE INPUT. IN ADDITION C IF CURRENT INPUT REPRESENTS A VARIABLE,CONSTANT, RELATION OR C I/O COMMAND, ITS ATTRIBUTE IS PUSHED ONTO ASTACK C 70 IF (PSTACK(PTOP).NE.TYPE) GO TO 100 IF (ATTR.LT.0) GO TO 80 ATOP = ATOP + 1 IF (ATOP.GT.30) CALL TERROR(4) ASTACK(ATOP) = ATTR 80 IF (TYPE.EQ.27) GO TO 90 PTOP = PTOP - 1 IF (TYPE.EQ.28) GO TO 40 GO TO 30 90 PSTACK(PTOP) = 101 CALL CODGEN(25) GO TO 30 C C AN ERROR HAS BEEN ENCOUNTERED. THE PARSE STACK IS POPPED TO C END OF STATEMENT MARKER AND ERROR CONDITION IS SET. NEW TOKENS ARE C GOTTEN UNTIL END OF STATEMENT AND PARSING OF NEXT STATEMENT CAN BEGIN C 100 CALL IERROR(21) ERRBIT = .TRUE. PSTACK(1) = 27 PTOP = 1 110 IF (TYPE.NE.27) GO TO 30 ERRBIT = .FALSE. GO TO 40 C C THIS STOP STATEMENT CAN'T BE REACHED. I AM TRICKING THE COMPILER. 120 STOP END SUBROUTINE ADDNAM(ARRAY, ASIZ, P, IS1, IS2) C ======================================= C C ADD A VARIABLE NAME TO AN ARRAY C - INCLUDE SUBSCRIPTS IF REQUESTED C C ======================================= INTEGER ASIZ, ARRAY(ASIZ), NAM(10), CONB, CON0, P DATA CONB /1H /, CON0 /1H0/ C === C FIRST INITIALIZE ARRAY TO BLANKS C DO 10 I=1,ASIZ ARRAY(I) = CONB 10 CONTINUE IF (P.NE.0) GO TO 20 C === C HERE IF THE CONSTANT ZERO IS DESIRED (FOR INTEGER STORE) C - PUT A HOLLERITH ZERO IN FIRST POSITION, RETURN C ARRAY(1) = CON0 GO TO 60 C === C GET NAME OF THE VARIABLE C 20 CALL GETNAM(P, NAM) C === C FIND LENGTH OF THE NAME (NEEDED BY ADDSUB) C KTR = 10 DO 30 I=1,10 ARRAY(I) = NAM(I) IF (NAM(I).NE.CONB) GO TO 30 KTR = I - 1 GO TO 40 30 CONTINUE C === C CALL ADDSUB TO GET THE SUBSCRIPTS (IF PRESENT) C 40 CONTINUE IF (P.NE.1) GO TO 50 CALL GETVAL(1, IS1, 0, IVAL) CALL ADDTMP(ARRAY, ASIZ, IVAL) GO TO 60 50 IF (IS1.NE.0) CALL ADDSUB(ARRAY, ASIZ, KTR, IS1, IS2) 60 RETURN END SUBROUTINE ADDSUB(ARRAY, ASIZ, KTR, IS1, IS2) C ======================================= C C ADD SUBSCIPTS TO AN ARRAY CONTAINING C ADD CHARACTER REPRESENTATION OF SUBSCRIPTS C C ======================================= INTEGER ASIZ, ARRAY(ASIZ), D(10) INTEGER OPNPAR, CLSPAR, COMMA, FAC LOGICAL SIG DATA OPNPAR, CLSPAR, COMMA /1H(,1H),1H,/ DATA D(1), D(2), D(3), D(4), D(5), D(6), D(7), D(8), D(9), D(10) * /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ C === C ADD OPEN PARENTHESIS, GET FIRST SUBSCRIPT C KTR = KTR + 1 ARRAY(KTR) = OPNPAR IRET = 1 NUM = IS1 GO TO 30 10 IF (IS2.EQ.0) GO TO 20 C === C HERE IF SECOND SUBSCRIPT IS NEEDED C - ADD A COMMA C - ADD THE SECOND SUBSCRIPT C KTR = KTR + 1 ARRAY(KTR) = COMMA IRET = 2 NUM = IS2 GO TO 30 20 KTR = KTR + 1 ARRAY(KTR) = CLSPAR GO TO 50 C === C INSERT THE CHARACTER REPRESENTATION OF THE SUBSCRIPT C 30 FAC = 100 SIG = .FALSE. DO 40 I=1,3 IDIG = NUM/FAC NUM = NUM - IDIG*FAC FAC = FAC/10 KTR = KTR + 1 IF (IDIG.NE.0 .OR. SIG .OR. I.EQ.3) ARRAY(KTR) = D(IDIG+1) IF (IDIG.NE.0) SIG = .TRUE. 40 CONTINUE GO TO (10, 20), IRET 50 RETURN END SUBROUTINE ADDTMP(ARRAY, ASIZ, ITMPVL) C ************************** C ************************** FINISHING ROUTINES C ************************** SUBROUTINES ADDNAM, ADDTMP, ADDSUB C ************************** C C >>===> ONLY THE PURPOSE OF THESE SUBROUTINES ARE DESCRIBED HERE, AS C THEIR IMPLEMENTATIONS ARE TRIVIAL. C C SUBROUTINE ADDNAM: C C - ADDNAM WILL ADD THE CHARACTER REPRESENTATION OF A VARIABLE (PLUS C ANY SUBSCRIPTS) TO AN INTEGER ARRAY (ITS FIRST ARGUMENT). C - ADDNAM CALLS ADDSUB TO ADD SUBSCRIPTS IF THEY ARE NEEDED. C - ADDNAM CALLS ADDTMP IF THE VARIABLE IS A REAL TEMPORARY. C C SUBROUTINE ADDTMP: C C - ADDTMP WILL ADD THE CHARACTER REPRESENTATION OF ANY REAL TEMP C VALUE POSSIBLE. POSSIBILITIES INCLUDE: C *DATA(I), *INTR(I), *CONS(I), *NULL C C SUBROUTINE ADDSUB: C C - ADDSUB WILL ADD THE CHARACTER EQUIVALENT OF SUBSCRIPTS TO C AN INTEGER ARRAY (ITS FIRST ARGUMENT). C POSSIBILITIES INCLUDE: "(I)", AND "(I,I)". C C ======================================= C C SET A PASSED ARRAY TO EITHER C *DATA(I), *CONS(I), OR *INTR(I) C C ======================================= COMMON /SUM/ DUM, NULTAB, NULVAL, NULSTM INTEGER ASIZ, ARRAY(ASIZ) INTEGER NCAR(5,4), Z(20), CONB LOGICAL DUM, NULSTM EQUIVALENCE (NCAR(1,1),Z(1)) DATA Z(1), Z(2), Z(3), Z(4), Z(5) /1H*,1HD,1HA,1HT,1HA/ DATA Z(6), Z(7), Z(8), Z(9), Z(10) /1H*,1HC,1HO,1HN,1HS/ DATA Z(11), Z(12), Z(13), Z(14), Z(15) /1H*,1HI,1HN,1HT,1HR/ DATA Z(16), Z(17), Z(18), Z(19), Z(20) /1H*,1HN,1HU,1HL,1HL/ DATA CONB /1H / C === C INITIALIZE ARRAY TO BLANKS C DO 10 I=1,ASIZ ARRAY(I) = CONB 10 CONTINUE C === C DETERMINE LABEL TO BE ADDED, THEN ADD IT C ITYPE = 4 IF (ITMPVL.EQ.50 .OR. ITMPVL.EQ.NULVAL) GO TO 20 IF (ITMPVL.GT.0) ITYPE = 1 IF (ITMPVL.LT.0) ITYPE = 2 IF (ITMPVL.GT.100) ITYPE = 3 20 DO 30 I=1,5 ARRAY(I) = NCAR(I,ITYPE) 30 CONTINUE C === C DETERMINE VALUE OF SUBSCRIPT, THEN CALL ADDSUB TO ADD SUBSCRIPTS C IF (ITYPE.EQ.4) GO TO 40 IS1 = IABS(ITMPVL) IF (IS1.GT.100) IS1 = IS1 - 100 IS2 = 0 KFILL = 5 CALL ADDSUB(ARRAY, ASIZ, KFILL, IS1, IS2) 40 RETURN END SUBROUTINE ADD(NAM, TYP, INDEX) C C ****************************************************************** C * * C * ADD * C * * C * GIVEN THE NAME OF A CONSTANT, VARIABLE, OR ARRAY, ADD * C * CHECKS WHETHER IT'S IN THE SYMBOL TABLE (IF IT'S AN ARRAY, * C * IT MUST BE) OR NOT. IF SO, ADD RETURNS THE TYPE AS RETRIEVED * C * FROM THE TABLE AND A POINTER TO THE LOCATION OF THE ITEM IN * C * THE TABLE. IF NOT, ADD PUTS THE ITEM IN THE TABLE AND RETURNS* C * A POINTER TO ITS LOCATION. IN THIS CASE, ADD MUST BE GIVEN * C * THE TYPE OF A CONSTANT. IF GIVEN A TYPE OF VARIABLE, ADD * C * WILL DECIDE WHETHER THE ITEM IS INTEGER OR REAL BASED ON * C * FORTRAN CONVENTIONS FOR THE FIRST LETTER OF THE NAME. * C * REAL CONSTANTS ARE ASSIGNED A VALUE WHEN PLACED IN THE TABLE. * C * NOTE THAT THE REAL CONSTANTS ZERO AND ONE ARE ENTERED AT MOST * C * ONCE IN THE SYMBOL TABLE, REGARDLESS OF REPRESENTATION IN THE * C * INPUT PROGRAM. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL * /MISC/ INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, * AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N /TEMP/ SUPP, REACNT COMMON /OPTS/ CON0, CON1, OPT LOGICAL DEFIND(50) INTEGER SUPP(20,10) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300), INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, * VAR, AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N, REACNT C C INDEX POINTER INTO THE SYMBOL TABLE C NAM NAME (10 CHARACTERS -- SOME MAY BE TRAILING BLANKS) C OF ITEM WHICH IS TO BE ADDED TO SYMBOL TABLE IF C IT'S NOT ALREADY THERE C TYP TYPE OF ITEM WITH NAME NAM; IF ITEM IS ADDED, TYP MUST C BE INTEGER CONSTANT, REAL CONSTANT, OR SIMPLY VARIABLE C INTEGER NAM(10), TYP, INDEX INTEGER FLAG0, FLAG1, OPT, CON0, CON1 INTEGER ZERO, ONE, BLANK, DOT DATA ZERO /1H0/, BLANK /1H /, DOT /1H./, ONE /1H1/ C SEE IF IN SYMTAB DO 20 J=1,SYMPTR DO 10 K=1,10 IF (NAME(J,K).NE.NAM(K)) GO TO 20 10 CONTINUE INDEX = J TYP = TYPE(INDEX) GO TO 130 20 CONTINUE C CHECK FOR REAL CONSTANT ZERO OR ONE IF (TYP.NE.5) GO TO 80 C TEST FOR REAL ZERO DO 30 III=1,10 IF (NAM(III).NE.ZERO .AND. NAM(III).NE.BLANK .AND. * NAM(III).NE.DOT) GO TO 50 30 CONTINUE C NAME IS THAT OF ZERO IF (CON0.NE.0) GO TO 40 FLAG0 = SYMPTR + 1 CON0 = -(REACNT+1) GO TO 80 40 INDEX = FLAG0 GO TO 130 C TEST FOR REAL CONSTANT ONE 50 IF (NAM(1).NE.ONE) GO TO 80 IF (NAM(2).NE.DOT) GO TO 80 DO 60 III=3,10 IF (NAM(III).NE.ZERO .AND. NAM(III).NE.BLANK) GO TO 80 60 CONTINUE C NAME IS THAT OF ONE IF (CON1.NE.0) GO TO 70 FLAG1 = SYMPTR + 1 CON1 = -(REACNT+1) GO TO 80 70 INDEX = FLAG1 GO TO 130 C NOT IN SYMTAB SO PUT IT IN 80 SYMPTR = SYMPTR + 1 IF (SYMPTR.GT.SYMLIM) CALL TERROR(1) INDEX = SYMPTR DO 90 L=1,10 NAME(INDEX,L) = NAM(L) 90 CONTINUE IF (TYP.NE.VAR) GO TO 110 C ELSE THIS IS VAR--REAL OR INT? IF (NAM(1).LT.I .OR. NAM(1).GT.N) GO TO 100 C ELSE THIS IS INT TYP = INTVAR TYPE(INDEX) = INTVAR GO TO 130 C THEN THIS IS REAL 100 TYP = REAVAR TYPE(INDEX) = REAVAR GO TO 130 C THEN THIS IS CONSTANT 110 TYPE(INDEX) = TYP IF (TYP.EQ.INTCON) GO TO 130 C ELSE THIS IS REACON REACNT = REACNT + 1 IF (REACNT.GT.20) CALL TERROR(1) VALUE(INDEX) = -REACNT DEFIND(INDEX) = .TRUE. DO 120 M=1,10 SUPP(REACNT,M) = NAM(M) 120 CONTINUE 130 RETURN END C SUBROUTINE CODGEN(ACTION) C C ************************************************ C * * C * SUBROUTINE CODGEN * C * * C ************************************************ C C THE SUBROUTINE CODGEN IS CALLED BY THE MAIN PARSING ROUTINE C WHENEVER AN ACTION SYMBOL IS ON TOP OF THE PARSE STACK. CODGEN IS C ACTUALLY A COLLECTION OF INDEPENDENT BLOCKS OF CODE, ONLY ONE OF WHICH C IS EXECUTED ON EACH CALL TO CODGEN. THE PARAMETER ACTION USED TO C CALL CODGEN IS USED AS THE BASIS OF A COMPUTED GOTO TO INITIALLY C LOCATE THE APPROPRIATE CODE. CODGEN PERFORMS FOUR TYPES OF FUNCTIONS C LISTED HERE AND DESCRIBED IN DETAIL BELOW: C 1: ATTRIBUTE AND FOR-STACK MANIPULATION C 2: GLOBAL SYNTAX CHECKING C 3: INTERMEDIATE CODE GENERATION C 4: INTERACTION WITH THE SYMBOL TABLE TO ESTABLISH VALUES OF C INTEGER VARIABLES, AND DIMENSIONS OF REAL ARRAYS C C ************************************************************** C * * C * VARIABLES AND DATA STRUCTURES USED BY CODGEN * C * * C ************************************************************** C C ACTION : THE PARAMETER USED BY THE PARSER TO CALL CODGEN C ICODE(500,11): THE ARRAY OF INTERMEDIATE INSTRUCTIONS BUILT BY C CODGEN AND REPRESENTING A PROGRAM TO BE C INTERPRETED. EACH LINE BEGINS WITH AN OPCODE AND C ENDS WITH AN ENTRY TELLING WHICH LINE OF SOURCE CODE C PRODUCED THIS INSTRUCTION. THE INTERVENING FIELDS C CAN REPRESENT SYMBOL TABLE INDICES OR INDICES IN THE C ARRAY OF INTEGER TEMPORARIES, BRANCH LABELS, OR C CODES OF VARIOUS KINDS. THE MEANINGS OF OPERANDS C DEPEND ON THE OPCODE AND ARE FULLY DESCRIBED IN THE C DOCUMENTATION OF INTERPRETATION ROUTINES. (THIS C ARRAY IS IN COMMON WITH THE INTERPRETER.) C LINE : THE INDEX OF THE LAST LINE OF ICODE WHICH WAS FILLED C ASTACK(30) : THE ATTRIBUTE STACK. THIS IS IN COMMON WITH THE C PARSER AND IS DISCUSSED FURTHER BELOW. C ATOP : POINTER TO THE TOP OF ASTACK C ITOP : A POINTER TO THE NEXT AVAILABLE INTEGER TEMPORARY. C (NOTE THAT ITOP IS SET TO 0 AFTER EACH STATEMENT IS C PARSED.) C RTEMP : A POINTER TO THE NEXT AVAILABLE REAL TEMPORARY IN C THE SYMBOL TABLE. (ALL REAL TEMPORARIES ARE STORED C IN AN ARRAY WHOSE SYMBOL TABLE INDEX IS 1.) NOTE C THE CODE GENERATOR USES A DIFFERENT REAL TEMPORARY C AS THE INTENDED LOCATION OF THE RESULT OF EACH C INTERMEDIATE REAL OPERATION INSTRUCTION. THUS C THE ONLY WAY REAL TEMPORARIES CAN BE REUSED IS IF C THEY ARE ASSIGNED IN INSTRUCTIONS WHICH APPEAR IN AN C ITERATIVE FOR-LOOP. C L : THE INDEX OF THE LINE OF INTERMEDIATE CODE CURRENTLY C BEING BUILT. C VAL,VAL1 ; PARAMETERS FOR SUBROUTINES CALL TO THE SYMBOL TABLE C ERR : THE GLOBAL ERROR COUNT. IN COMMON WITH MOST ROUTINES C NOTE THAT WHENEVER ERR BECOMES NON-ZERO, NO FURTHER C INTERMEDIATE CODE WILL BE GENERATED. C FSTACK(8,4) : THE FOR-STACK. EACH LINE OF THIS ARRAY IS USED TO C RECORD INFORMATION ABOUT A FOR-LOOP OR IF-THEN BLOCK C WHICH IS CURRENTLY BEING PARSED. C C *************************************** C * * C * CODGEN FUNCTIONS * C * * C *************************************** C C 1: ATTRIBUTE AND FOR STACK MANIPTULATION C C ALL ATTRIBUTES OF TOKENS FROM THE LEXICAL ANALYZER ARE PUSHED C ONTO THE ATTRIBUTE STACK BY THE PARSER. SOME OF THESE ARE C SIMPLY NOTED BY CODGEN IN MAKING UP INTERMEDIATE INSTRUCTIONS, C BUT ATTRIBUTES RELEVANT TO INTEGER AND REAL EXPRESSIONS ARE USED C AND REPLACED AS FOLLOWS: C EVERY TIME AN INTEGER VARIABLE OR CONSTANT IS RECOGNIZED C CODGEN GENERATES AN INSTRUCTION TO THE INTERPRETER TO LOAD ITS C VALUE INTO AN INTEGER TEMPORARY, AND REPLACES ITS SYMBOL TABLE C INDEX ON ASTACK BY THE INDEX OF THIS TEMPORARY. WHEN INTEGER C OPERATORS ARE PARSED, CODGEN USES THE TOP TWO INTEGER TEMPORARY C INDICES ON ASTACK TO BUILD THE INTERMEDIATE INSTRUCTION AND THEN C REPLACES THEM BY THE INDEX OF THE RESULT. THUS, WHENEVER A SERIES C OF INTEGER OPERATIONS FORM AN INTEGER EXPRESSION, AT THE END OF C PARSING THE EXPRESSION THE TOP ELEMENT OF ASTACK WILL BE A POINTER C TO THE INTEGER TEMPORARY ARRAY ELEMENT WHICH WILL CONTAIN THE C ACTUAL VALUE OF THAT EXPRESSION AFTER INTERPRETATION. C IN REAL ARITHMETIC EXPRESSIONS, EVERY OPERAND WILL BE C REPRESENTED ON THE ASTACK BY THREE ELEMENTS, THESE BEING THE C SYMBOL TABLE INDEX OF THE REAL VARIABLE AND THE INTEGER C TEMPORARY INDICES OF THE VALUES OF ITS SUBSCRIPTS, IF ANY. C THE A0PUSH AND A*PUSH ACTIONS GUARANTEE THAT THESE INDICES WILL BE C 0 IF THERE IS NO SUBSCRIPT, OR -1 IF THE SUBSCRIPT IS A SUMMATION C VARIABLE. IN ADDITION, FOR UNIFORMITY, THE NULL OPERAND IN C UNARY REAL OPERATIONS WILL APPEAR ON ASTACK AS THREE ZEROES. AS C WITH INTEGERS, WHENEVER AN INTERMEDIATE REAL INSTRUCTION IS C GENERATED, THE ATTRIBUTES OF ITS OPERANDS ARE REPLACED ON THE C ATTRIBUTE STACK BY THE ATTRIBUTES OF THE REAL TEMPORARY C IN WHICH THE INTERMEDIATE RESULT WILL BE STORED BY THE C INTERPRETER. C THE ONLY OTHER TIMES THAT CODGEN CHANGES ASTACK IS TO PUT C ON A DUMMY INDICATOR OF A NEGATIVE FOR LOOP INCREMENT AND TO C EMPTY ASTACK AFTER A STATEMENT IS COMPLETELY PARSED. C C WHEN A FOR STATEMENT IS ENCOUNTERED, AN ENTRY IS PLACED ON C FSTACK WHICH INDICATES THAT A FOR STATEMENT HAS BEEN SEEN, ITS C LOOP-VARIABLE, WHETHER THE VARIABLE IS TO BE INCREMENTED OR C DECREMENTED, AND THE LINE OF INTERMEDIATE CODE GENERATED BY THE C FOR STATEMENT. WHEN THE MATCHING END IS LATER ENCOUNTERED, THE C LAST INFORMATION WILL BE NECESSARY FOR CODGEN TO FILL IN A C BRANCH LABEL IN THAT LINE OF CODE, AND TO GENERATE ANOTHER C INTERMEDIATE INSTRUCTION TO BRANCH FROM THE BOTTOM OF THE LOOP C BACK TO ITS TOP. C WHEN AN IF-THEN STATEMENT IS PARSED, AN ENTRY IS PLACED ON C FSTACK INDICATING THAT THIS IS AN IF STATEMENT, AND THE LINE OF C INTERMEDIATE CODE GENERATED FROM IT. THE LATTER INFORMATION C WILL BE USED WHEN THE MATCHING END IS FOUND, TO PLACE A PROPER C BRANCH LABEL IN THAT SAME LINE OF CODE. C C 2: INTERMEDIATE CODE GENERATION C C CODGEN BUILDS INSTRUCTIONS BASED ON THE ACTION SYMBOL USED C AS ITS PARAMETER (WHICH OFTEN BECOMES THE OPCODE OF THE C INTERMEDIATE INSTRUCTION) AND ON THE CURRENT ATTRIBUTE STACK. IN C THE CASES OF FOR OR IF-THEN BLOCKS OF INSTRUCTIONS, THE FIFTH C FIELD OF THE INSTRUCTION AT THE TOP OF THE BLOCK IS FILLED IN WHEN C WHEN THE END OF THE BLOCK IS IDENTIFIED. C C 3: INTERACTION WITH THE SYMBOL TABLE C C WHEN SOURCE STATEMENTS BEGINNING WITH THE KEY WORD TEST ARE C PARSED CODGEN CALLS THE SYMBOL TABLE TO STORE THE ASSIGNED C INTEGER VALUES. SIMILARLY, WHEN DIMENSION STATEMENTS ARE PARSED, C CODGEN RETRIEVES THE VALUES OF THE SUBSCRIPTS AND CALLS THE SYMBOL C TABLE TO ASSIGN DIMENSIONS TO REAL ARRAYS. C C 4: GLOBAL SYNTAX CHECKING. ERRORS AND WARNINGS IDENTIFIED BY CODGEN. C C TERROR 4 : ATTRIBUTE STACK OVERFLOW C TERROR 5 : INTEGER TEMPORARY OVERFLOW C TERR0R 6 : REAL TEMPORARY OVERFLOW C TERROR 7 : TOO MANY NESTED FOR AND/OR IF-THEN BLOCKS C ERROR 20 : DIMENSION STATEMENT FOLLOWS EXECUTABLE CODE C ERROR 22 : FOR LOOP INCREMENT NOT EQUAL TO PLUS OR MINUS 1 C ERROR 23 : EXTRANEIOUS END OR IMPROPER FOR LOOP NESTING C ERROR 24 : ATTEMPT TO ILLEGALLY REDEFINE FOR LOOP VARIABLE C ERROR 25 : WARNING - MISSING END C INTEGER ACTION, ICODE, ITOP, RTEMP, LINE, ASTACK, ATOP, L, VAL, * VAL1 INTEGER ERR, FSTACK(8,4), FTOP, FS COMMON /INTCOD/ ICODE(500,11), LINE COMMON /ATTSTK/ ASTACK(30), ATOP /ERRNUM/ ERR COMMON /OPTS/ F0, F1, OPT INTEGER F0, F1, OPT DATA RTEMP /2/, FTOP /0/ C C GO TO (40, 40, 40, 40, 40, 40, 10, 10, 10, 10, 10, 60, 60, 70, * 10, 90, 100, 120, 130, 140, 170, 240, 250, 260, 280), ACTION C C INTERMEDIATE CODE FOR INTEGER EXPRESSIONS C 10 IF (ERR.GT.0) RETURN CALL NEXT L = LINE ITOP = ITOP + 1 IF (ITOP.GT.30) CALL TERROR(5) IF (ACTION.EQ.15) GO TO 20 IF (ACTION.LT.11) GO TO 30 C C GENERATE AN INSTRUCTION TO LOAD ZERO INTO AN INTEGER TEMPORARY C FOLLOWED BY A SUBTRACT IN ORDER TO EFFECT A UNARY MINUS. C ICODE(L,1) = 19 ICODE(L,2) = 0 ICODE(L,3) = ITOP CALL NEXT L = LINE ICODE(L,1) = 8 ICODE(L,2) = ASTACK(ATOP) ICODE(L,3) = ITOP ICODE(L,4) = ASTACK(ATOP) RETURN C C GENERATE LOAD INSTRUCTION C 20 ICODE(L,1) = 19 ICODE(L,2) = ASTACK(ATOP) ICODE(L,3) = ITOP ASTACK(ATOP) = ITOP RETURN C C GENERATE INTERMEDIATE INTEGER BINARY OPERATIONS C 30 ICODE(L,1) = ACTION ICODE(L,2) = ITOP ICODE(L,3) = ASTACK(ATOP-1) ICODE(L,4) = ASTACK(ATOP) ATOP = ATOP - 1 ASTACK(ATOP) = ITOP RETURN C C CODE GENERATION FOR REAL ARITHMETIC OPERATORS C 40 IF (ERR.NE.0) RETURN CALL NEXT L = LINE RTEMP = RTEMP + 1 IF (RTEMP.GT.200) CALL TERROR(6) ICODE(L,1) = ACTION ICODE(L,2) = 1 ICODE(L,3) = RTEMP ICODE(L,4) = 0 DO 50 I=1,6 J = 10 - I + 1 K = ATOP - I + 1 ICODE(L,J) = ASTACK(K) 50 CONTINUE ATOP = ATOP - 3 K = ATOP - 2 ASTACK(K) = 1 K = ATOP - 1 ASTACK(K) = RTEMP ASTACK(ATOP) = 0 RETURN C C ATTRIBUTE STACK MANIPULATION NECESSARY FOR UNIFORMITY IN PROCESSING C REAL VARIABLES C 60 ATOP = ATOP + 1 IF (ATOP.GT.30) CALL TERROR(4) IF (ACTION.EQ.12) ASTACK(ATOP) = 0 IF (ACTION.EQ.13) ASTACK(ATOP) = -1 RETURN C C INTERMEDIATE STORE INSTRUCTION. GENERATED AT END OF REAL C ASSIGNMENT STATEMENT C 70 IF (ERR.NE.0) RETURN CALL NEXT L = LINE ICODE(L,1) = 15 DO 80 I=1,6 J = 7 - I + 1 K = ATOP - I + 1 ICODE(L,J) = ASTACK(K) 80 CONTINUE RETURN C C IF STATEMENT ACTIONS C C PUT IF-STATEMENT INCICATOR ON FOR STACK C 90 FTOP = FTOP + 1 IF (FTOP.GT.8) CALL TERROR(7) FSTACK(FTOP,1) = 1 FSTACK(FTOP,2) = 0 C C GENERATE INTERMEDIATE TEST INSTRUCTION C IF (ERR.NE.0) RETURN CALL NEXT L = LINE ICODE(L,1) = 13 K = ATOP - 2 ICODE(L,2) = ASTACK(K) ICODE(L,3) = ASTACK(ATOP) K = ATOP - 1 ICODE(L,4) = ASTACK(K) FSTACK(FTOP,4) = L RETURN C C INPUT/OUTPUT ACTIONS C 100 CALL NEXT L = LINE DO 110 I=1,4 ICODE(L,I) = ASTACK(I) 110 CONTINUE CALL GETDIM(ASTACK(2), I, J) K = 2 IF (I.NE.0) K = 3 IF (J.NE.0) K = 4 ICODE(L,5) = K ATOP = 1 RETURN C C TEST ACTIONS: STORE INTEGER VALUE IN SYMBOL TABLE ENTRY OF C INTEGER VARIABLE C C 120 CALL GETVAL(ASTACK(ATOP), 0, 0, VAL) CALL STORE(ASTACK(ATOP-1), 0, 0, VAL) ATOP = 0 RETURN C C DIMENSION ACTIONS: ASSIGN DIMENSIONS TO REAL VARIABLES C C 130 IF (LINE.GT.0) CALL IERROR(20) CALL GETVAL(ASTACK(ATOP-1), 0, 0, VAL) VAL1 = 0 IF (ASTACK(ATOP).NE.0) CALL GETVAL(ASTACK(ATOP), 0, 0, VAL1) CALL RDIM(ASTACK(ATOP-2), VAL, VAL1) ATOP = 0 RETURN C C FOR STATEMENT ACTIONS C 140 IF (FTOP.EQ.0) GO TO 160 C C CHECK FOR ATTEMPT TO REDEFINE FOR LOOP VARIABLE C DO 150 I=1,FTOP IF (FSTACK(I,2).NE.ASTACK(1)) GO TO 150 CALL IERROR(24) RETURN 150 CONTINUE C C PUT FOR-STATEMENT INDICATOR ON FOR STACK C 160 K = ATOP IF (ASTACK(K).EQ.(-1)) K = K - 1 CALL GETVAL(ASTACK(K), 0, 0, VAL) IF (VAL.NE.1) CALL IERROR(22) FTOP = FTOP + 1 IF (FTOP.GT.8) CALL TERROR(7) FSTACK(FTOP,1) = 0 FSTACK(FTOP,2) = ASTACK(1) FSTACK(FTOP,3) = 0 IF (ASTACK(ATOP).EQ.(-1)) FSTACK(FTOP,3) = 1 IF (ERR.NE.0) RETURN C C GENERATE ISTORE INSTRUCTION C IF (ATOP.EQ.5) FSTACK(FTOP,3) = 1 CALL NEXT L = LINE ICODE(L,1) = 20 ICODE(L,2) = ASTACK(1) ICODE(L,3) = ASTACK(2) C C GENERATE FOR INSTRUCTION C CALL NEXT L = LINE ICODE(L,1) = 12 ICODE(L,2) = ASTACK(1) ICODE(L,3) = ASTACK(3) ICODE(L,4) = FSTACK(FTOP,3) FSTACK(FTOP,4) = L RETURN C C C END ACTIONS: CHECK FOR PROPER NESTING OF LOOPS. FILL IN BRANCH C LABEL IN INTERMEDIATE CODE FOR IF AND FOR STATEMENTS. FOR FOR LOOPS C GENERATE INCREMENT/DECREMENT INTERMEDIATE CODE AND BRANCH C INSTRUCTION FOR BOTTOM OF THE LOOP. C 170 IF (FTOP.NE.0) GO TO 180 CALL IERROR(23) RETURN 180 J = FTOP IF (ATOP.EQ.0) GO TO 200 C C END STATEMENT HAS A LABEL. CHECK NESTING C J = 0 DO 190 I=1,FTOP IF (FSTACK(I,2).NE.ASTACK(1)) GO TO 190 J = I 190 CONTINUE IF (J.NE.0) GO TO 200 CALL IERROR(23) RETURN 200 IF (J.NE.FTOP) CALL IERROR(25) IF (ERR.NE.0) GO TO 230 DO 220 I=1,10 IF (FSTACK(FTOP,1).EQ.1) GO TO 210 C C GENERATE INTERMEDIATE INC/DEC AND BRANCH AT BOTTOM OF FOR LOOP C CALL NEXT L = LINE ICODE(L,1) = 11 ICODE(L,2) = FSTACK(FTOP,2) ICODE(L,5) = FSTACK(FTOP,3) CALL NEXT L = LINE ICODE(L,1) = 14 ICODE(L,2) = FSTACK(FTOP,4) C C FILL IN BRANCH LABEL IN FOR/IF INSTRUCTIONS C 210 FS = FSTACK(FTOP,4) ICODE(FS,5) = LINE + 1 IF (FTOP.EQ.J) GO TO 230 FTOP = FTOP - 1 220 CONTINUE 230 FTOP = J - 1 RETURN C C INDICATE NEGATIVE FOR LOOP INCREMENT C 240 ATOP = ATOP + 1 IF (ATOP.GT.30) CALL TERROR(4) ASTACK(ATOP) = -1 RETURN C C END OF PROGRAM ACTIONS C 250 IF (FTOP.NE.0) CALL IERROR(23) CALL IERROR(0) IF (ERR.NE.0) STOP CALL NEXT L = LINE ICODE(L,1) = 16 CALL INTERP RETURN C C SUMMATION ACTIONS C 260 IF (ERR.NE.0) RETURN RTEMP = RTEMP + 1 IF (RTEMP.GT.200) CALL TERROR(6) CALL NEXT L = LINE ICODE(L,1) = 21 K = ATOP - 7 DO 270 I=2,9 ICODE(L,I) = ASTACK(K) K = K + 1 270 CONTINUE ICODE(L,10) = RTEMP ATOP = ATOP - 5 ASTACK(ATOP-2) = 1 ASTACK(ATOP-1) = RTEMP ASTACK(ATOP) = 0 RETURN C C 280 ATOP = 0 ITOP = 0 RETURN C END SUBROUTINE CODOPT C ---------------------------------------------------------------------- C THIS PROGRAM PERFORMS 'CODE OPTIMIZATION' ON THE STRAIGHT-LINE PROGRAM C PRODUCED BY THE MINICOMPILER. THE FOLLOWING TRANSFORMATIONS ARE C APPLIED. C 1. AN OPERATION IS REMOVED IF EVERY OUTPUT VALUE IS INDEPENDENT C OF IT, I.E., USELESS OPERATIONS ARE STRIPPED AWAY. C 2. REDUNDANT OPERATIONS ARE REMOVED USING A 'VALUE NUMBER' C METHOD LIKE THAT IN COCKE AND SCHWARTZ, 'PROGRAMMING C LANGUAGES AND THEIR COMPILERS (2ND ED.), COURANT INST. (1970), C PP. 320-334. C 3. OPERATIONS OF THE FORMS 0.0 + X, X + 0.0, X - 0.0, 0.0*X, 0.0/X, C SQRT(0.0), -0.0, 1.0*X, X*1.0, X/1.0 AND SQRT(1.0) ARE REMOVED, C WHILE 0.0 - X IS CONVERTED TO A UNARY MINUS. C ---------------------------------------------------------------------- C ARRAY 'NUMBER' IS FIRST USED TO MARK (WITH 1) INTERMEDIATE VALUES C WHICH ARE NOT USELESS. LATER IT POINTS TO AN INTERMEDIATE C COMPUTED VALUE'S CORRESPONDING VALUE IN THE REDUCED PROGRAM. C COMMON /OPTS/ CON0, CON1, OPT COMMON /TEMP/ SUPP, REACNT COMMON /FIN/ FDAT, FINT, FOUT, KDAT, KINT, KOUT COMMON /IO/ NREAD, NPRINT, NPUNCH INTEGER NLOP(500), NOPER(500), NROP(500), NUMBER(500), NDXOUT(20) INTEGER FDAT(50,2), FINT(500,5), FOUT(20,3) INTEGER CON0, CON1, OPT, SUPP(20,10), REACNT EQUIVALENCE (FINT(1,1),NLOP(1)), (FINT(1,2),NROP(1)), (NOP,KINT), * (NFIND,KOUT), (NGIVEN,KDAT), (NCONST,REACNT) C C INITIALIZE THE HASH TABLE FOR THE 'OPTIMIZED' CODE. M0 = 0 N0 = 0 CALL INSERT(0, 0, 0, M0, N0, -1, IER) C C INITIALIZE OPERATION CODES DO 10 I=1,NOP J = FINT(I,3) K = J/10 NOPER(I) = J - K*10 10 CONTINUE C INITIALIZE OUTPUT VALUES DO 20 I=1,NFIND NDXOUT(I) = FOUT(I,3) - 100 20 CONTINUE C C C FIRST LOCATE THE 'LIVE' OPERATIONS, I.E., THOSE OPERATIONS USED IN THE C EVALUATION OF SOME OUTPUT. DO 30 I=1,NOP NUMBER(I) = 0 30 CONTINUE DO 40 I=1,NFIND NDXI = NDXOUT(I) NUMBER(NDXI) = 1 40 CONTINUE DO 50 IBACK=2,NOP I = NOP + 2 - IBACK NUMBI = NUMBER(I) IF (NUMBI.EQ.0) GO TO 50 NLOPM = NLOP(I) - 100 IF (NLOPM.GT.0) NUMBER(NLOPM) = 1 IF (NOPER(I).GT.4) GO TO 50 NROPM = NROP(I) - 100 IF (NROPM.GT.0) NUMBER(NROPM) = 1 50 CONTINUE C C C PROCESS THE I-TH OPERATION. DO 180 I=1,NOP NUMBI = NUMBER(I) C IGNORE USELESS OPERATIONS. IF (NUMBI.EQ.0) GO TO 180 ILOP = NLOP(I) C IF OPERAND IS A COMPUTED VALUE, LOCATE THE C CORRESPONDING VALUE IN THE REDUCED PROGRAM. C CONSTANT AND INPUT VALUES HAVE IDENTICAL C REPRESENTATIONS IN THE ORIGINAL AND THE C REDUCED PROGRAMS. IF (ILOP.GT.100) ILOP = NUMBER(ILOP-100) IOPER = NOPER(I) IROP = NROP(I) IF (IROP.GT.100) IROP = NUMBER(IROP-100) C NOW ILOP, IOPER AND IROP GIVE THE ORIGINAL C I-TH OPERATION IN TERMS OF THE REDUCED PROGRAM. C C HERE IF THE LEFT OPERAND IS 0.0. IF (ILOP.NE.CON0) GO TO 90 GO TO (60, 70, 80, 80, 80, 80), IOPER 60 NUMBER(I) = IROP GO TO 180 70 ILOP = IROP IOPER = 6 IROP = 0 GO TO 170 80 NUMBER(I) = CON0 GO TO 180 C C HERE IF THE LEFT OPERAND IS 1.0 90 IF (ILOP.NE.CON1) GO TO 120 GO TO (120, 120, 100, 120, 110, 120), IOPER 100 NUMBER(I) = IROP GO TO 180 110 NUMBER(I) = CON1 GO TO 180 120 IF (IOPER.GT.4) GO TO 170 C C HERE IF THE RIGHT OPERAND IS 0.0 IF (IROP.NE.CON0) GO TO 150 GO TO (130, 130, 140, 200), IOPER 130 NUMBER(I) = ILOP GO TO 180 140 NUMBER(I) = CON0 GO TO 180 C C HERE IF THE RIGHT OPERAND IS 1.0 150 IF (IROP.NE.CON1) GO TO 170 GO TO (170, 170, 160, 160), IOPER 160 NUMBER(I) = ILOP GO TO 180 C C INSERT THE OPERATION IF IT IS NOT REDUNDANT. 170 CALL INSERT(ILOP, IOPER, IROP, NBR, ISOLD, 0, IER) IF (IER.NE.0) GO TO 210 NUMBER(I) = NBR IF (ISOLD.EQ.1) GO TO 180 NBR = NBR - 100 NLOP(NBR) = ILOP NOPER(NBR) = IOPER NROP(NBR) = IROP IF (FINT(I,3).GT.10) FINT(NBR,4) = FINT(I,4) J = FINT(I,3)/10 FINT(NBR,3) = J*10 + IOPER FINT(NBR,5) = FINT(I,5) 180 CONTINUE N0 = 0 CALL INSERT(0, 0, 0, NOP, N0, 1, IER) C DO 190 I=1,NFIND NDXI = NDXOUT(I) FOUT(I,3) = NUMBER(NDXI) 190 CONTINUE RETURN C 200 WRITE (NPRINT,99999) GO TO 220 210 WRITE (NPRINT,99998) 220 STOP 99999 FORMAT (16H DIVISION BY 0.0) 99998 FORMAT (17H PROGRAM TOO LONG) END LOGICAL FUNCTION COMPO1(CARD) C THIS ADD HOC ROUTINE (AND COMPO2,COMPO3) WERE ADDED WHEN THE C 'COMPOSITION' INSTRUCTION WAS INCLUDED IN THE SOURCE LANGUAGE. C THIS ROUTINE CHECKS FOR COMPOSITION INSTRUCTIONS. INTEGER CARD(80), C(11), BLANK DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), * C(11) /1HC,1HO,1HM,1HP,1HO,1HS,1HI,1HT,1HI,1HO,1HN/ DATA BLANK /1H / COMPO1 = .FALSE. IF (CARD(1).EQ.C(1)) GO TO 30 K = 0 10 K = K + 1 IF (K.EQ.62) GO TO 30 IF (CARD(K).EQ.BLANK) GO TO 10 J = 1 20 IF (CARD(K).NE.C(J)) GO TO 30 K = K + 1 J = J + 1 IF (J.LE.11) GO TO 20 COMPO1 = .TRUE. 30 RETURN END SUBROUTINE COMPO2(LOCNTR) C A 'COMPOSITION' INSTRUCTION IS BEING EXECUTED BY THE INTERPRETER. C POINT NCUT TO THE LAST LINE OF THE STRAIGHT-LINE PROGRAM GENERATED C SO FAR. INCREMENT LOCNTR TO MOVE INTERPRETER TO ITS NEXT INSTRUCTION. COMMON /COMPOZ/ NCUT COMMON /FIN/ FDAT, INT, FOUT, KDAT, KINT, KOUT INTEGER FDAT(50,2), INT(500,5), FOUT(20,3) C AT MOST ON 'COMPOSITION' CAN BE EXECUTED. IF (NCUT.NE.0) CALL IERROR(26) NCUT = KINT LOCNTR = LOCNTR + 1 RETURN END SUBROUTINE COMPO3(OPSIGN) C IF A 'COMPOSITION' INSTRUCTION WAS EXECUTED, THEN MARK ALL C OPERATIONS 'PLUS'. OTHERWISE, MARK ALL 'BOUNDARY' NODES 'PLUS' C AND THE OTHER (I.E., ERROR-FREE) NODES 'MINUS'. COMMON /FIN/ FDAT, FINT, FOUT, KDAT, KINT, KOUT COMMON /COMPOZ/ NCUT INTEGER OPSIGN(500), FDAT(50,2), FINT(500,5), FOUT(20,3), PLUS DATA PLUS, MINUS /1,-1/ IF (NCUT.LE.0) GO TO 60 DO 10 I=1,KINT OPSIGN(I) = MINUS 10 CONTINUE IF (NCUT.EQ.KINT) GO TO 40 LIM = NCUT + 1 DO 20 I=LIM,KINT ILOP = FINT(I,1) - 100 IF (0.LT.ILOP .AND. ILOP.LE.NCUT) OPSIGN(ILOP) = PLUS ITMP = FINT(I,3) IPTR = ITMP/10 IOP = ITMP - IPTR*10 IF (IOP.GE.4) GO TO 20 IROP = FINT(I,2) - 100 IF (0.LT.IROP .AND. IROP.LE.NCUT) OPSIGN(IROP) = PLUS 20 CONTINUE 30 RETURN 40 IF (KOUT.EQ.0) GO TO 30 DO 50 I=1,KOUT ITMP = FOUT(I,3) - 100 OPSIGN(ITMP) = PLUS 50 CONTINUE GO TO 30 60 DO 70 I=1,KINT OPSIGN(I) = PLUS 70 CONTINUE GO TO 30 END SUBROUTINE ERROR(ERR, NAM, C1, C2) C C ****************************************************************** C * * C * ERROR * C * * C * GIVEN AN ERROR NUMBER AND THE NAME OF AN ITEM (AND POSSIBLY* C * SUBSCRIPTS), ERROR PRINTS THE APPROPRIATE ERROR MESSAGE AND * C * INCREMENTS THE GLOBAL ERROR COUNT. * C * NOTE THE ERRORS ARE DISTRIBUTED AS FOLLOWS: * C * 1-5,30 SYMBOL TABLE * C * 15,16 LEXICAL ANALYZER * C * * C ****************************************************************** C COMMON /ERRNUM/ ERRCT /STATE/ ST /IO/ NREAD, NPRINT, NPUNCH C C ERR NUMBER OF ERROR TO BE PRINTED C NAM NAME OF ITEM TO WHICH ERROR REFERS C C1 FIRST SUBSCRIPT OF ITEM -- MAY BE ZERO C C2 SECOND SUBSCRIPT OF ITEM -- MAY BE ZERO C INTEGER CONB, ERR, ERRCT, C1, C2, ST, NAM(10), NAM2(17) DATA CONB /1H / C INCREMENT GLOBAL ERROR COUNT ERRCT = ERRCT + 1 IF (ERR.GT.5) GO TO 50 GO TO (10, 10, 20, 30, 40), ERR C ERROR #1 AND #2 10 ISUB = C1 IF (ERR.EQ.2) ISUB = C2 WRITE (NPRINT,99999) ERR, (NAM(I),I=1,10), ISUB GO TO 100 C ERROR #3 20 WRITE (NPRINT,99998) (NAM(I),I=1,10) GO TO 110 C ERROR #4 30 WRITE (NPRINT,99997) (NAM(I),I=1,10) GO TO 100 C ERROR #5 40 WRITE (NPRINT,99996) GO TO 110 50 IF (ERR.GT.16) GO TO 60 C ERROR #15 AND #16 WRITE (NPRINT,99995) (NAM(I),I=1,10) GO TO 110 60 IF (ERR.GT.27) GO TO 70 WRITE (NPRINT,99993) C1 GO TO 100 C ERROR #30 70 DO 80 I=1,17 NAM2(I) = CONB 80 CONTINUE DO 90 I=1,10 IF (NAM(I).EQ.CONB) GO TO 90 K = I NAM2(I) = NAM(I) 90 CONTINUE IF (C1.NE.0) CALL ADDSUB(NAM2, 17, K, C1, C2) IF (ERR.EQ.30) WRITE (NPRINT,99994) (NAM2(I),I=1,17) IF (ERR.EQ.31) WRITE (NPRINT,99992) (NAM2(I),I=1,17) 100 WRITE (NPRINT,99991) ST 110 RETURN 99999 FORMAT (21H *** SUBSCRIPT NUMBER, I2, 10H OF ARRAY , 10A1, * 19H IS OUT OF BOUNDS (, I5, 17H), 1 IS USED. ***) 99998 FORMAT (11H *** ARRAY , 10A1, 27H IS ALREADY DIMENSIONED ***) 99997 FORMAT (5H *** , 10A1, 30H IS UNDEFINED (1 IS USED). ***) 99996 FORMAT (38H *** ATTEMPT TO REDEFINE REAL CONSTANT, 11H (COMPILER , * 11HERROR). ***) 99995 FORMAT (45H *** NAME OR CONSTANT TOO LONG (TRUNCATED TO , 10A1, * 6H). ***) 99994 FORMAT (5H *** , 17A1, 37H IS UNDEFINED (IT IS SET TO 0.0). ***) 99993 FORMAT (42H *** ATTEMPTED INTEGER DIVISION BY ZERO. , 8HRESULT I, * 19HS SET TO DIVIDEND (, I10, 1H)) 99992 FORMAT (5H *** , 29HTHE VALUE OF OUTPUT VARIABLE , 17A1, 6H DOES , * 30HNOT RESULT FROM A COMPUTATION.) 99991 FORMAT (28H *** ERROR OCCURRED IN LINE , I3, 5H. ***) END SUBROUTINE FINISH C ************************** C ************************** FINISHING ROUTINES C ************************** SUBROUTINE FINISH C ************************** C C CALLING SEQUENCE: C C CALL FINISH C C ARGUMENTS: NONE C C THE DATA FOR SUBROUTINE FINISH IS IN COMMON BLOCK FIN. C THESE INCLUDE THE ARRAYS CONTAINING REAL ARITHMETIC, INPUT, AND C OUTPUT INSTRUCTIONS, AND POINTERS INDICATING THE LAST FILLED C POSITION OF EACH ARRAY. C C PURPOSE: C C TO PRODUCE THE FINAL OUTPUT OF THE INTERPRETER. C THERE ARE TWO TYPES OF OUTPUT PRODUCED: C C - PUNCHED CARDS; C THESE CARDS CONTAIN THE CODES WHICH ARE USED AS INPUT TO THE C ERROR ANALYSIS SOFTWARE. C C - PRINTED LINES; C THERE ARE FOUR SECTIONS TO THE PRINTED OUTPUT. C - THE VARIABLES INTO WHICH INPUT VALUES GO ARE LISTED C (IN CHRONOLOGICAL ORDER OF INPUT). C - THE REAL CONSTANTS ARE LISTED C - THE INTERMEDIATE CODE INSTRUCTONS ARE LISTED. THESE C INCLUDE ALL REAL ARITHMETIC INSTRUCTIONS WHICH WERE C NOT DELETED BY THE CODE OPTIMIZER. IF AN INSTRUCTION C CHANGED THE VALUE OF SOME REAL VARIABLE IN THE PROGRAM, C THE NAME OF THAT VARIABLE (PLUS SUBSCRIPTS) IS OUTPUT. C - THE VARIABLES WHICH WERE OUTPUT BY THE PROGRAM (AND THEIR C VALUES AT THE TIME OF OUTPUT) ARE LISTED (IN CHRONOLO- C GICAL ORDER OF OUTPUT). C C SUBROUTINES CALLED: C C ADDNAM: ADD THE NAME OF A VARIABLE TO AN INTEGER ARRAY C (INCLUDING SUBSCRIPTS IF DESIRED). C ADDTMP: ADD THE CHARACTER REPRESENTATION OF THE VALUE OF A VARIABLE C INTO AN INTEGER ARRAY (I.E., "*INT(I)", "*DAT(I)", ETC.). C C PROCEDURE: C C (1) OUTPUT DATA VALUES. C C - IF NONE, PRINT MESSAGE, GO TO (2). C - FOR EACH ENTRY IN ARRAY FDAT, C C - GET SYMBOL TABLE POINTER, SUBSCRIPTS FROM FDAT. C - CALL ADDNAM FOR CHARACTER REPRESENTATION OF NAME, C PRINT IT OUT. C C (2) OUTPUT STRAIGHT LINE CODE. C C - OUTPUT NUMBER OF LINES BY FORMAT *** FORMAT(I3) ***. C - IF NONE, PRINT MESSAGE, GO TO (3). C - FOR EACH ENTRY IN ARRAY FINT, C C - GET VALUES FOR LEFT AND RIGHT ARGUMENTS, GET OPERATION C CODE FROM FINT. C - OUTPUT LEFT-VALUE, OP CODE, RIGHT-VALUE TO PUNCHED CARDS C BY FORMAT *** FORMAT(I3,I2,I4) ***. C - GET SYMBOL TABLE POINTER, SUBSCRIPTS OF TARGET. C IF POINTER IS NOT ZERO, ADD NAME OF TARGET TO PRINTER C OUTPUT. C C (3) OUTPUT OUTPUT VALUES (NAMES). C C - OUTPUT NUMBER OF OUTPUT VALUES BY FORMAT *** FORMAT(I2) ***. C - IF NONE, PRINT MESSAGE, GO TO (4) C - FOR EACH OF THE OUTPUT VALUES, C C - GET SYMBOL TABLE POINTER, SUBSCRIPTS OF VARIABLE. C - OUTPUT NAME, VALUE OF VARIABLE TO PRINTER. C - OUTPUT VALUE ONLY TO PUNCHED CARDS BY FORMAT C *** FORMAT(I3) ***. C C (4) OUTPUT REAL CONSTANTS. C C - OUTPUT NUMBER OF CONSTANTS BY FORMAT *** FORMAT(I2) ***. C - OUTPUT EACH OF THE CONSTANTS BY FORMAT *** FORMAT(10A1) ***. C C (5) OUTPUT NUMBER OF DATA VALUES C C - OUTPUT TO PUNCHED CARDS ONLY BY FORMAT *** FORMAT(I2) ***. C C COMMON /FIN/ FDAT, FINT, FOUT, KDAT, KINT, KOUT COMMON /TEMP/ SUPP, REACNT COMMON /OPTS/ N0, N1, NOPT COMMON /IO/ NREAD, NPRINT, NPUNCH COMMON /COMPOZ/ NCUT INTEGER FDAT(50,2), FINT(500,5), FOUT(20,3), SUPP(20,10), OP(4) INTEGER OPSIGN(500) INTEGER HOLD(17), HOLDL(10), HOLDR(10), CONB, VAL1, VAL2, REACNT DATA OP(1), OP(2), OP(3), OP(4), CONB /1H+,1H-,1H*,1H/,1H / C === C PROCESS DATA LINES C === CALL COMPO3(OPSIGN) WRITE (NPRINT,99995) IF (KDAT.EQ.0) GO TO 20 DO 10 I=1,KDAT IPTR = FDAT(I,1) ITMP = FDAT(I,2) IS1 = ITMP/101 IS2 = ITMP - IS1*101 CALL ADDNAM(HOLD, 17, IPTR, IS1, IS2) WRITE (NPRINT,99999) I, HOLD 10 CONTINUE GO TO 30 20 WRITE (NPRINT,99994) C === C PRINT THE REAL CONSTANTS C === 30 IF (REACNT.EQ.0) GO TO 50 WRITE (NPRINT,99988) DO 40 I=1,REACNT WRITE (NPRINT,99985) I, (SUPP(I,J),J=1,10) 40 CONTINUE C === C PROCESS INTERMEDIATE VALUE LINES C === 50 WRITE (NPRINT,99993) IF (NCUT.NE.0) WRITE (NPRINT,99992) WRITE (NPUNCH,99982) KINT IF (KINT.EQ.0) GO TO 110 DO 100 I=1,KINT I2 = FINT(I,5) VAL1 = FINT(I,1) CALL ADDTMP(HOLDL, 10, VAL1) VAL2 = FINT(I,2) IF (VAL2.NE.0) CALL ADDTMP(HOLDR, 10, VAL2) ITMP = FINT(I,3) IPTR = ITMP/10 IOP = ITMP - IPTR*10 IOPX = IOP*OPSIGN(I) WRITE (NPUNCH,99981) VAL1, IOPX, VAL2 IF (IPTR.EQ.0) GO TO 60 ITMP = FINT(I,4) IS1 = ITMP/101 IS2 = ITMP - IS1*101 CALL ADDNAM(HOLD, 17, IPTR, IS1, IS2) GO TO 80 60 DO 70 J=1,17 HOLD(J) = CONB 70 CONTINUE 80 IF (NCUT.GT.0 .AND. IOPX.LT.0) GO TO 90 IF (IOP.LE.4) IOPOP = OP(IOP) IF (IOP.LE.4) WRITE (NPRINT,99998) I2, I, HOLDL, IOPOP, HOLDR, * HOLD IF (IOP.EQ.5) WRITE (NPRINT,99987) I2, I, HOLDL, HOLD IF (IOP.EQ.6) WRITE (NPRINT,99984) I2, I, HOLDL, HOLD GO TO 100 90 IF (IOP.LE.4) IOPOP = OP(IOP) IF (IOP.LE.4) WRITE (NPRINT,99997) I2, I, HOLDL, IOPOP, HOLDR, * HOLD IF (IOP.EQ.5) WRITE (NPRINT,99986) I2, I, HOLDL, HOLD IF (IOP.EQ.6) WRITE (NPRINT,99983) I2, I, HOLDL, HOLD 100 CONTINUE GO TO 120 110 WRITE (NPRINT,99991) C === C PROCESS OUTPUT LINES C === 120 WRITE (NPRINT,99990) WRITE (NPUNCH,99980) KOUT IF (KOUT.EQ.0) GO TO 140 DO 130 I=1,KOUT IPTR = FOUT(I,1) ITMP = FOUT(I,2) IS1 = ITMP/101 IS2 = ITMP - IS1*101 ITMP = FOUT(I,3) CALL ADDTMP(HOLDL, 10, ITMP) CALL ADDNAM(HOLD, 17, IPTR, IS1, IS2) WRITE (NPRINT,99996) I, HOLDL, HOLD ITMP = ITMP - 100 WRITE (NPUNCH,99982) ITMP 130 CONTINUE GO TO 150 140 WRITE (NPRINT,99989) 150 WRITE (NPUNCH,99980) REACNT IF (REACNT.EQ.0) GO TO 170 DO 160 I=1,REACNT WRITE (NPUNCH,99979) (SUPP(I,J),J=1,10) 160 CONTINUE 170 WRITE (NPUNCH,99980) KDAT WRITE (NPRINT,99978) RETURN 99999 FORMAT (9H *DATA(, I2, 5H) IS , 17A1) 99998 FORMAT (I5, 9H *INTR(, I3, 8H) = , 10A1, 4X, A1, 4X, 10A1, * 10X, 17A1) 99997 FORMAT (I5, 9H INTR(, I3, 8H) = , 10A1, 4X, A1, 4X, 10A1, * 10X, 17A1) 99996 FORMAT (8H *OUT(, I2, 5H) IS , 10A1, 5X, 17A1) 99995 FORMAT (37H1*DATA(I) DENOTES THE I-TH DATA VALUE//) 99994 FORMAT (5X, 32H*** THERE ARE NO DATA VALUES ***//) 99993 FORMAT (//45H *INTR(I) DENOTES THE I-TH INTERMEDIATE VALUE//) 99992 FORMAT (29H+* SHOWS COMPOSITION BOUNDARY) 99991 FORMAT (5X, 40H*** THERE ARE NO INTERMEDIATE VALUES ***//) 99990 FORMAT (//38H *OUT(I) DENOTES THE I-TH OUTPUT VALUE//) 99989 FORMAT (5X, 34H*** THERE ARE NO OUTPUT VALUES ***) 99988 FORMAT (//35H *CONS(I) DENOTES THE I-TH CONSTANT//) 99987 FORMAT (I5, 9H *INTR(, I3, 5H) =, 14X, 8HSQRT , 10A1, 10X, * 17A1) 99986 FORMAT (I5, 9H INTR(, I3, 5H) =, 14X, 8HSQRT , 10A1, 10X, * 17A1) 99985 FORMAT (9H *CONS(, I2, 5H) IS , 10A1) 99984 FORMAT (I5, 9H *INTR(, I3, 5H) =, 17X, 5H- , 10A1, 10X, * 17A1) 99983 FORMAT (I5, 9H INTR(, I3, 5H) =, 17X, 5H- , 10A1, 10X, * 17A1) 99982 FORMAT (I3) 99981 FORMAT (I3, I2, I4) 99980 FORMAT (I2) 99979 FORMAT (10A1) 99978 FORMAT (1H0, 19X, 27HMINICOMPILER VERSION 2.1.79) END SUBROUTINE GETDIM(INDEX, D1, D2) C C ****************************************************************** C * * C * GETDIM * C * * C * GIVEN A POINTER INTO THE SYMBOL TABLE, GETDIM RETURNS THE * C * DIMENSIONS OF THE CONSTANT, VARIABLE, OR ARRAY AT THAT * C * LOCATION. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL * /MISC/ INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, * AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N LOGICAL DEFIND(50) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300), INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, * VAR, AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N C C INDEX POINTER INTO THE SYMBOL TABLE C D1 ROW DIMENSION AS RETRIEVED FROM SYMBOL TABLE -- ZERO C FOR CONSTANTS AND VARIABLES C D2 COLUMN DIMENSION AS RETRIEVED FROM SYMBOL TABLE -- ZERO C FOR CONSTANTS, VARIABLES, AND ONE-DIMENSIONAL ARRAYS C INTEGER INDEX, D1, D2 D1 = ROWS(INDEX) D2 = COLS(INDEX) RETURN END SUBROUTINE GETNAM(INDEX, NAM) C C ****************************************************************** C * * C * GETNAM * C * * C * GIVEN A POINTER INTO THE SYMBOL TABLE, GETNAM RETURNS THE * C * NAME OF THE CONSTANT, VARIABLE, OR ARRAY AT THAT LOCATION. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL * /MISC/ INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, * AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N LOGICAL DEFIND(50) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300), INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, * VAR, AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N C C INDEX POINTER INTO THE SYMBOL TABLE C NAM NAME OF CONSTANT, VARIABLE, OR ARRAY AS RETRIEVED FROM C SYMBOL TABLE C INTEGER INDEX, NAM(10) DO 10 J=1,10 NAM(J) = NAME(INDEX,J) 10 CONTINUE RETURN END SUBROUTINE GETSTM(STMCAR, STMCLS, KSTM) C ************************** C ************************** LEXICAL ANALYSER C ************************** SUBROUTINE GETSTM C ************************** C C CALLING SEQUENCE: C C CALL GETSTM(STMCAR,STMCLS,KSTM), C WHERE STMCAR AND STMCLS ARE 330 ELEMEMT INTEGER ARRAYS AND C KSTM IS AN INTEGER VARIABLE WHOSE VALUE WILL BE DEFINED BY C GETSTM. C C ARGUMENTS: C C STMCAR -- THE SIGNIFICANT CHARACTERS OF THE NEXT PROGRAM STATEMENT. C STMCLS -- THE CLASS OF EACH OF THE ABOVE CHARACTERS. C KSTM -- THE NUMBER OF CHARACTERS IN STMCAR. C C PURPOSE: C C TO RETURN THE CHARACTER REPRESENTATION THE NEXT STATEMENT, PLUS C THE CLASS OF THE CHARACTERS IN THE STATEMENT. C CLASS INFORMATION AIDS IN THE LEXICAL ANALYSIS AND IN DETERMINING C THE ACTUAL VALUE OF INTEGER CONSTANTS -- CHARACTER/CLASS GROUPINGS C ARE DEFINED BELOW. C C CHARACTER CLASS C --------- ----- C 0-9 0-9 C A-Z 10 C BLANK 12 C = 18 C + 19 C - 20 C * 21 C / 22 C ( 23 C ) 24 C , 25 C . 37 C C OTHER DUTIES ASSUMED BY GETSTM: C C DETECTION OF END-OF-FILE C HANDLE STATEMENT-TOO-LONG ERROR C HANDLE CONTINUED STATEMENTS C C PROCEDURE: C C GETSTM ASSUMES THE FOLLOWING SYNTAX RULES: C C (1) A STATEMENT IS TERMINATED BY A COMMENT CARD OR THE FIRST C CARD OF THE NEXT STATEMENT. C C (2) A COMMENT CARD IS ANY CARD WITH A "C" IN COLUMN ONE. C C (3) A STATEMENT MAY BE CONTINUED BY PUNCHING A "1" IN COLUMN SIX C OF THE FOLLOWING CARD, AND CONTINUING THE STATEMENT ON THAT C CARD. C C - COLUMN 72 OF THE PRECEEDING CARD, AND COLUMN 7 OF THE CONTIN- C UATION CARD WILL BE CONSIDERED CONTIGUOUS. C - AT LEAST 4 CONTINUATION CARDS MAY BE USED (SEE (4)). C C (4) A STATEMENT MAY CONSIST OF AT MOST 330 SIGNIFICANT CHARACTERS. C C - A SIGNIFICANT CHARACTER IS: C - ANY NON-BLANK CHARACTER C - ANY BLANK FOLLOWING A CHARACTER OR A DIGIT C C (5) ANY ADJACENT IDENTIFIERS, CONSTANTS, OR KEYWORDS MUST BE C SEPARATED BY AT LEAST ONE BLANK. ALSO, NO IDENTIFIER, C CONSTANT, OR KEYWORD MAY CONTAIN IMBEDDED BLANKS. C C THE BASIC ALGORITHM USED IS AS FOLLOWS. C C (1) INITIALIZATION. C C - SET KSTM TO 1. C - SET ENDCOL TO 1 (USED TO CHECK FOR END=OF=FILE). C - SET COL TO 7. C C (2) IF COL <= 72, GOTO (3), ELSE READ NEXT CARD. C C - IF NOT CONTINUATION CARD, GOTO (5), ELSE SET COL TO 7 AND C GOTO (2). C C (3) IF CHARACTER NOT EQUAL TO ENDCON(ENDCOL), SET ENDCOL TO 1 AND C GOTO (4), ELSE ADVANCE ENDCOL. C C - IF CHARACTER WAS BLANK, THE END-OF-FILE TOKEN HAS BEEN C ENCOUNTERED. RETURN END-OF-FILE AS ONLY TOKEN IN STATEMENT. C (ENDCON IS AN INTEGER ARRAY CONTAINING THE END-OF-FILE TOKEN C FOLLOWED BY ONE BLANK: PRESENTLY IT CONTAINS THE CHARACTERS C S, T, O, P, AND BLANK) C C (4) IF CHARACTER IS NON-SIGNIFICANT, ADVANCE COL AND GOTO (2). C ELSE, PERFORM BINARY SEARCH TO DETERMINE CLASS OF CHARACTER, C STORE CHARACTER IN STMCAR AND ITS CLASS IN STMCLS, ADVANCE C KSTM AND GOTO (2). C C (5) ADD END-OF-STATEMENT TOKEN TO STMCLS, RETURN. C C ======================================= C C COMMON; COMMON VARIABLES REFERENCED: C /STATE/ STMTNO: THE STATEMENT NUMBER (WHICH APPEARS ON LISTING) C FOR THIS STATEMENT. C C LOCAL INTEGER STRUCTURES: C CARD(80): INPUT CARD BEING SCANNED. C CHAR(45): VALID INPUT CHARACTERS. C -- R(45): USED TO DATA-INITIALIZE ARRAY CHAR. C CLASS(45): CLASS OF CORRESPONDING CHARACTERS IN CHAR. C -- S(45) : USED TO DATA-INITIALIZE ARRAY CLASS. C ENDCON(6): SYMBOL WHICH SIGNALS END OF INPUT DATA. C -- T(6) : USED TO DATA-INITIALIZE ARRAY ENDCON. C C LOCAL INTEGER VARIABLES: C COL: COLUMN OF CARD BEING PROCESSED. C CAR: TEMPORARY PLACE FOR CHARACTER BEING PROCESSED. C LCLASS: CLASS OF THE PREVIOUS CHARACTER. C LEFT, MID, RIT: POINTERS USED IN BINARY SEARCH. C -- CONSTANTS USED BY GETSTM -- C CONB: BLANK. C CONQ: PERIOD (REPLACES INVALID CHARACTERS IN TEXT). C CONC: CHARACTER C. C CON1: DIGIT 1. C ENDCOL: POINTER TO NEXT CHARACTER OF END-OF-INPUT TOKEN WHICH C MUST BE MATCHED. C KIN: NUMBER OF STATEMENT BEING PROCESSED, USED TO DEFINE STMTNO. C C LOCAL LOGICAL VARIABLES: C FIRST : TRUE WHEN THIS IS THE FIRST CALL TO GETSTM. C FERR10: TRUE WHEN ERROR # 10 HAS BEEN DETECTED ON THIS CARD. C FERR12: TRUE WHEN ERROR # 12 HAS BEEN DETECTED ON THIS CARD. C FEND : TRUE WHEN SCANNING ON THIS CARD IS COMPLETE. C C ======================================= COMMON /STATE/ STMTNO COMMON /OPTS/ F0, F1, OPT COMMON /IO/ NREAD, NPRINT, NPUNCH COMMON /INTCOD/ ICODE(500,11), LINE INTEGER STMCAR(330), STMCLS(330), CARD(80), CHAR(45), CLASS(45) INTEGER ENDCON(6), R(45), S(45), T(6), F0, F1, OPT INTEGER RD5, STMTNO, ENDCOL, COL, LEFT, RIT, CAR, CONB, CONQ, * CONC, CON1 LOGICAL FEND, FBLANK, FIRST, FERR10, FERR12, COMPO1, COMPOX EQUIVALENCE (CHAR(1),R(1)), (CLASS(1),S(1)), (ENDCON(1),T(1)) DATA R(1), R(2), R(3), R(4), R(5), R(6), R(7), R(8), R(9), R(10) * /1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ/, R(11), R(12), R(13), * R(14), R(15), R(16), R(17), R(18), R(19), R(20) /1HK,1HL,1HM,1HN, * 1HO,1HP,1HQ,1HR,1HS,1HT/, R(21), R(22), R(23), R(24), R(25), * R(26), R(27), R(28), R(29), R(30) /1HU,1HV,1HW,1HX,1HY,1HZ,1H0, * 1H1,1H2,1H3/, R(31), R(32), R(33), R(34), R(35), R(36), R(37), * R(38), R(39), R(40) /1H4,1H5,1H6,1H7,1H8,1H9,1H.,1H(,1H+,1H*/, * R(41), R(42), R(43), R(44), R(45) /1H),1H-,1H/,1H,,1H=/ DATA S(1), S(2), S(3), S(4), S(5), S(6), S(7), S(8), S(9), S(10) * /10*10/, S(11), S(12), S(13), S(14), S(15), S(16), S(17), S(18), * S(19), S(20) /10*10/, S(21), S(22), S(23), S(24), S(25), S(26), * S(27), S(28), S(29), S(30) /6*10,0,1,2,3/, S(31), S(32), S(33), * S(34), S(35), S(36), S(37), S(38), S(39), S(40) * /4,5,6,7,8,9,30,23,19,21/, S(41), S(42), S(43), S(44), S(45) * /24,20,22,25,18/ DATA T(1), T(2), T(3), T(4), T(5), T(6) /1H*,1HS,1HT,1HO,1HP,1H / DATA FIRST, FBLANK, FERR10, FERR12 /.TRUE.,3*.FALSE./ DATA CONB, CONQ, CONC, CON1 /1H ,1H.,1HC,1H1/, ENDCOL, KIN /1,0/ KSTM = 1 LCLASS = 12 FBLANK = .TRUE. IF (.NOT.FIRST) GO TO 10 C === C HERE IF THIS IS THE FIRST CALL TO THE SUBROUTINE C - READ THE FIRST INPUT CARD C - SET LOGICAL VARIABLE FIRST TO .FALSE. C === FIRST = .FALSE. WRITE (NPRINT,99997) READ (NREAD,99999) CARD COMPOX = COMPO1(CARD) 10 IF (.NOT.COMPOX) GO TO 20 KIN = KIN + 1 WRITE (NPRINT,99998) KIN, CARD LINE = LINE + 1 IF (LINE.GT.500) CALL TERROR(2) ICODE(LINE,1) = 99 READ (NREAD,99999) CARD COMPOX = COMPO1(CARD) GO TO 10 20 IF (CARD(1).NE.CONC) GO TO 30 WRITE (NPRINT,99996) CARD READ (NREAD,99999) CARD COMPOX = COMPO1(CARD) GO TO 10 30 DO 40 I=1,6 IF (CARD(I).EQ.CONB) GO TO 40 FERR10 = .TRUE. GO TO 50 40 CONTINUE C === C THIS LOOP WILL CONTINUE TO PROCESS CARDS UNTIL END-OF-STATEMENT IS C REACHED. LOGICAL VARIABLE FEND SIGNALS END-OF-STATEMENT WHEN TRUE C === 50 FEND = .FALSE. KIN = KIN + 1 STMTNO = KIN 60 IF (FEND) GO TO 250 C === C THIS LOOP WILL PROCESS EVERY COLUMN OF THE INPUT CARD C === COL = 7 WRITE (NPRINT,99998) KIN, CARD IF (.NOT.FERR10) GO TO 70 FERR10 = .FALSE. CALL IERROR(10) 70 IF (COL.GT.72) GO TO 200 CAR = CARD(COL) C === C HERE IF CHECKING IS IN EFFECT FOR THE END-OF-FILE KEYWORD C - CHARACTERS MUST OCCUR IN THE FOLLOWING ORDER: C ENDCOL -- CHARACTER C 1 S C 2 T C 3 O C 4 P C 5 BLANK (OR 1) C - NOTE THAT SCANNING IS INITIATED BY THE OCCURENCE OF A * C IN THE INPUT STREAM C - IF THE END-OF-FILE KEYWORD IS DETECTED, C THEN THE END-OF-FILE TOKEN ONLY IS SENT C (ANY PREVIOUS TOKENS ARE DELETED) C - IF *STOP1 IS USED AS END OF FILE, THE OUTPUT CODE C WILL NOT BE OPTIMIZED C === IF (CAR.EQ.ENDCON(ENDCOL)) GO TO 80 ENDCOL = 1 GO TO 90 80 ENDCOL = ENDCOL + 1 IF (ENDCOL.LE.5) GO TO 90 COL = COL + 1 IF (COL.GT.72) GO TO 200 CAR = CARD(COL) ENDCOL = 1 IF (CAR.NE.CONB .AND. CAR.NE.CON1) GO TO 90 IF (CAR.EQ.CON1) OPT = 0 KSTM = 1 STMCLS(1) = 28 GO TO 260 90 IF (CAR.NE.CONB) GO TO 100 C === C HERE IF THE CHARACTER IS A BLANK: C - IF PREVIOUS CHARACTER WAS A BLANK, OR C WAS NOT A VALID NAME CHARACTER, IGNORE THIS BLANK C === IF (LCLASS.GT.11) GO TO 170 IF (KSTM.EQ.330) GO TO 180 FBLANK = .TRUE. STMCAR(KSTM) = CAR STMCLS(KSTM) = 12 LCLASS = 12 KSTM = KSTM + 1 GO TO 170 C === C HERE IF THE CHARACTER IS NOT A BLANK: C - DETERMINE CLASS OF CHARACTER C - REPLACE INVALID CHARACTERS BY '.', TREAT AS NULL STRING C === 100 FBLANK = .FALSE. IF (KSTM.EQ.330) GO TO 180 LEFT = 0 RIT = 46 MID = 23 110 IF (CAR.EQ.CHAR(MID)) GO TO 150 IF (CAR.LT.CHAR(MID)) GO TO 120 GO TO 130 C === C HERE IF CHARACTER LESS THAN CHARACTER IN TABLE C === 120 RIT = MID GO TO 140 C === C HERE IF CHARACTER GREATER THAN CHARACTER IN TABLE C - UNNECESSARY BLANKS DELETED HERE C === 130 LEFT = MID 140 IF (RIT-LEFT.EQ.1) GO TO 160 MID = (LEFT+RIT)/2 GO TO 110 C === C HERE IF CHARACTER EQUAL TO CHARACTER IN TABLE C BACKSPACE ONE CHARACTER IF THIS IS SPECIAL CHARACTER C FOLLOWING A BLANK (UNLESS THIS IS THE FIRST CHARACTER) C === 150 IF (CLASS(MID).GT.11 .AND. LCLASS.EQ.12 .AND. KSTM.GT.1) KSTM = * KSTM - 1 STMCAR(KSTM) = CAR LCLASS = CLASS(MID) STMCLS(KSTM) = LCLASS KSTM = KSTM + 1 GO TO 170 C === C HERE IF CHARACTER IS INVALID C === 160 CARD(COL) = CONQ FERR12 = .TRUE. C === C PROCEED TO NEXT CHARACTER ON CARD C === 170 COL = COL + 1 GO TO 70 C === C HERE IF STATEMENT LENGTH EXCEEDED C - PRINT ERROR MESSAGE C - FLUSH CARDS UP TO NEXT STATEMENT C - PUT END-OF-FILE TOKEN ON END OF STATEMENT C === 180 CALL IERROR(11) 190 READ (NREAD,99999) CARD IF (CARD(6).NE.CON1) GO TO 250 WRITE (NPRINT,99998) KIN, CARD GO TO 190 C === C READ NEXT CARD: C - FIRST OUTPUT ERRORS FROM PREVIOUS CARD C - CHECK COLUMNS 1-6 FOR CORRECTNESS C - SET FEND = .TRUE. IF NOT A CONTINUATION CARD C === 200 IF (.NOT.FERR12) GO TO 210 CALL IERROR(12) FERR12 = .FALSE. WRITE (NPRINT,99998) KIN, CARD 210 READ (NREAD,99999) CARD COMPOX = COMPO1(CARD) IF (COMPOX) GO TO 250 IF (CARD(1).NE.CONC .AND. CARD(6).EQ.CON1) GO TO 220 FEND = .TRUE. GO TO 240 220 DO 230 I=1,5 IF (CARD(I).EQ.CONB) GO TO 230 FERR10 = .TRUE. GO TO 240 230 CONTINUE 240 GO TO 60 C === C HERE ON END-OF-STATEMENT C === 250 STMCLS(KSTM) = 27 260 RETURN 99999 FORMAT (80A1) 99998 FORMAT (1X, I4, 5X, 80A1) 99997 FORMAT (7H STMT /7H NUMBER, 9X, 17H*** STATEMENT ***) 99996 FORMAT (10X, 80A1) END SUBROUTINE GETVAL(INDEX, IC1, IC2, VAL) C C ****************************************************************** C * * C * GETVAL * C * * C * GIVEN A POINTER INTO THE SYMBOL TABLE (AND ROW AND COLUMN * C * POINTERS FOR AN ARRAY ELEMENT), GETVAL RETURNS THE VALUE OF * C * A CONSTANT OR A DEFINED VARIABLE OR ARRAY ELEMENT. IF AN * C * INTEGER VARIABLE IS UNDEFINED, THE VALUE RETURNED IS 1. IF * C * A REAL VARIABLE OR ARRAY ELEMENT IS UNDEFINED, THE VALUE * C * RETURNED IS -1. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL * /MISC/ INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, * AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N /SUM/ DUM, NULTAB, NULVAL, * NULSTM LOGICAL DEFIND(50) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300), INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, * VAR, AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N C C INDEX POINTER INTO THE SYMBOL TABLE C C1 ROW POINTER FOR AN ARRAY ELEMENT -- SET TO 1 IF OUT C OF RANGE C C2 COLUMN POINTER FOR AN ARRAY ELEMENT -- SET TO 1 IF C OUT OF RANGE C VAL VALUE OF THE ITEM POINTED TO BY INDEX (AND POSSIBLY C C1 AND C2); SET TO 1 FOR UNDEFINED INTEGER VARIABLE, C TO -1 FOR UNDEFINED REAL VARIABLE OR ARRAY ELEMENT C NAM NAME OF ITEM POINTED TO BY INDEX -- USED IN CALLS TO C ERROR ROUTINE C PTR POINTER TO A PARTICULAR ELEMENT IN AN ARRAY C INTEGER INDEX, C1, C2, VAL, NAM(10), PTR C1 = IC1 C2 = IC2 IF (.NOT.(TYPE(INDEX).EQ.ONEDIM .OR. TYPE(INDEX).EQ.TWODIM)) GO * TO 60 C ELSE ARRAY -- CHECK OUT SUBSCRIPTS IF (C1.GT.0 .AND. C1.LE.ROWS(INDEX)) GO TO 10 C ELSE C1 NOT VALID CALL GETNAM(INDEX, NAM) CALL ERROR(1, NAM, C1, C2) C1 = 1 10 IF (TYPE(INDEX).EQ.ONEDIM) GO TO 30 C ELSE CHECK OUT C2 IF (C2.GT.0 .AND. C2.LE.COLS(INDEX)) GO TO 20 C ELSE C2 NOT VALID CALL GETNAM(INDEX, NAM) CALL ERROR(2, NAM, C1, C2) C2 = 1 20 PTR = VALUE(INDEX) + ((C1-1)*COLS(INDEX)) + C2 - 1 GO TO 40 C THEN SET PTR 30 PTR = VALUE(INDEX) + C1 - 1 40 IF (AUXVAL(PTR).NE.0) GO TO 50 C ELSE NOT DEFINED -- USE -1 CALL GETNAM(INDEX, NAM) CALL ERROR(30, NAM, C1, C2) VAL = -1 GO TO 90 C THEN GET VALUE 50 VAL = AUXVAL(PTR) GO TO 90 C THEN NOT AN ARRAY 60 IF (DEFIND(INDEX)) GO TO 80 C ELSE NOT DEFINED -- USE 1 OR -1 DEPENDING ON TYPE CALL GETNAM(INDEX, NAM) IF (TYPE(INDEX).EQ.INTVAR) GO TO 70 C ELSE IT'S A REAVAR CALL ERROR(30, NAM, C1, C2) VAL = NULVAL CALL STORE(INDEX, C1, C2, NULVAL) GO TO 90 C THEN 70 CALL ERROR(4, NAM, C1, C2) VAL = 1 GO TO 90 C THEN GET VALUE 80 VAL = VALUE(INDEX) 90 RETURN END SUBROUTINE IERROR(ERR) C C ****************************************************************** C * * C * IERROR * C * * C * GIVEN AN ERROR OR WARNING NUMBER, IERROR PRINTS THE * C * APPROPRIATE ERROR OR WARNING MESSAGE. FOR ERRORS (NOT * C * WARNINGS) IERROR INCREMENTS THE GLOBAL ERROR COUNT. * C * NOTE THE ERRORS AND WARNINGS ARE DISTRIBUTED AS FOLLOWS: * C * 10-19 LEXICAL ANALYZER * C * 20-29 PARSING AND INTERMEDIATE CODE GENERATION * C * A CALL OF IERROR (0) PRODUCES A MESSAGE CONCERNING THE * C * TOTAL NUMBER OF ERRORS DETECTED DURING COMPILATION. IF THE * C * TOTAL IS NOT ZERO THE PROGRAM TERMINATES. A CALL OF * C * IERROR (50) PRODUCES A MESSAGE CONCERNING THE TOTAL NUMBER * C * OF ERRORS DETECTED DURING INTERPRETATION. IF THE TOTAL IS * C * NOT ZERO THE PROGRAM IS TERMINATED. * C * * C ****************************************************************** C COMMON /ERRNUM/ ERRCT COMMON /IO/ NREAD, NPRINT, NPUNCH INTEGER ERRCT C C ERR NUMBER OF ERROR OR WARNING TO BE PRINTED; C IF ERR IS 0 OR 50 A MESSAGE IS PRINTED CONCERNING C THE TOTAL NUMBER OF ERRORS DETECTED UP TO THAT POINT C AND ACTION IS TAKEN AS DESCRIBED ABOVE C INTEGER ERR, MSGS(26), M(26) EQUIVALENCE (MSGS(1),M(1)) DATA M(1), M(2), M(3), M(4), M(5), M(6), M(7), M(8), M(9), M(10) * /9*1,2/, M(11), M(12), M(13), M(14), M(15), M(16), M(17), M(18), * M(19), M(20) /3,4,1,1,1,1,5,1,1,6/, M(21), M(22), M(23), M(24), * M(25), M(26) /7,8,9,10,11,12/ IF (ERR.EQ.0) GO TO 130 IF (ERR.EQ.50) GO TO 140 C INCREMENT THE GLOBAL ERROR COUNT FOR ERRORS (NOT WARNINGS) IF (ERR.NE.25) ERRCT = ERRCT + 1 MSGERR = MSGS(ERR) GO TO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 120, 110), MSGERR 10 WRITE (NPRINT,99999) ERRCT GO TO 160 20 WRITE (NPRINT,99998) GO TO 160 30 WRITE (NPRINT,99997) GO TO 160 40 WRITE (NPRINT,99996) GO TO 160 50 WRITE (NPRINT,99995) GO TO 160 60 WRITE (NPRINT,99994) GO TO 160 70 WRITE (NPRINT,99993) GO TO 160 80 WRITE (NPRINT,99992) GO TO 160 90 WRITE (NPRINT,99991) GO TO 160 100 WRITE (NPRINT,99990) GO TO 160 110 WRITE (NPRINT,99988) GO TO 160 120 WRITE (NPRINT,99989) GO TO 160 130 WRITE (NPRINT,99987) ERRCT IF (ERRCT.EQ.0) GO TO 160 GO TO 150 140 WRITE (NPRINT,99986) ERRCT IF (ERRCT.EQ.0) GO TO 160 150 WRITE (NPRINT,99985) WRITE (NPRINT,99984) 160 RETURN 99999 FORMAT (17H *** ERROR NUMBER, I3, 4H ***) 99998 FORMAT (48H *** FIRST SIX COLUMNS OF CARD NON-BLANK AND/OR , * 35HCONTINUATION CHARACTER NOT A 1. ***) 99997 FORMAT (46H *** STATEMENT TOO LONG. FIRST 329 CHARACTERS , * 12HARE USED ***) 99996 FORMAT (47H *** INVALID CHARACTER(S) IN INPUT. CHARACTERS , * 46HIGNORED, REPLACED BY A . IN SOURCE LISTING ***) 99995 FORMAT (46H *** INVALID SYNTAX FOR SUMMATION VARIABLE ***/ * 37H (MISSING = OR CLOSE PARENTHESIS)) 99994 FORMAT (52H *** DIMENSION STATEMENT FOLLOWS EXECUTABLE CODE ***) 99993 FORMAT (21H *** SYNTAX ERROR ***) 99992 FORMAT (46H *** INVALID FOR LOOP INCREMENT. 1 IS USED ***) 99991 FORMAT (51H *** EXTRANEOUS END OR INVALID FOR LOOP NESTING ***) 99990 FORMAT (44H *** ATTEMPT TO RE-DEFINE FOR LOOP INDEX ***) 99989 FORMAT (47H *** (WARNING) MISSING END. ONE IS SUPPLIED ***) 99988 FORMAT (43H *** MORE THAN ONE COMPOSITION EXECUTED ***) 99987 FORMAT (20X, I5, 1X, 26HCOMPILATION ERROR(S) FOUND) 99986 FORMAT (20X, I5, 1X, 24HEXECUTION ERROR(S) FOUND) 99985 FORMAT (54H *** PROGRAM TERMINATED DUE TO NON-ZERO ERROR COUNT **, * 1H*) 99984 FORMAT (1H0, 19X, 27HMINICOMPILER VERSION 2.1.79) END C SUBROUTINE INSERT(ILOP, IOPER, IROP, NBR, ISOLD, INISH, IER) C ---------------------------------------------------------------------- C THIS SUBROUTINE PERFORMS SEARCHES AND INSERTIONS IN A HASH TABLE OF C ALL OPERATIONS IN THE 'OPTIMIZED' PROGRAM. C ILOP, IOPER, IROP - INPUT PARAMETERS GIVING THE LEFT OPERAND, C OPERATOR AND RIGHT OPERAND OF THE OPERATION C TO BE LOCATED. C NBR - OUTPUT POINTER TO THE OPERATION IN THE REDUCED C CODE. C ISOLD - OUTPUT PARAMETER. 0 = OPERATION IS NOT C REDUNDANT AND SHOULD BE INSERTED AS THE NBR-TH C LINE OF THE REDUCED CODE. 1 = OPERATION C IS ALREADY IN THE TABLE. C INISH - INPUT PARAMETER. 0 = NORMAL ENTRY. 1 = SET NBR C TO THE TABLE SIZE (LENGTH OF REDUCED CODE). -1 C = INITIALIZE THE HASH TABLE. C IER - OUTPUT PARAMETER. 0 = NORMAL. 1 = TABLE C OVERFLOW. C ---------------------------------------------------------------------- INTEGER HASH(211), PACKED(500), NEXT(500), STKTOP, HASHPT, * CURSOR, TRY, PKDOPR, PC IER = 0 IF (INISH.NE.0) GO TO 50 PKDOPR = 10000*(ILOP+100) + 1000*IOPER + (IROP+100) C FOR + AND * OPERATIONS SEE IF THE OPERATION HAS OCCURRED WITH C OPERANDS IN THE OTHER ORDER. IF ((IOPER.EQ.1 .OR. IOPER.EQ.3) .AND. ILOP.GT.IROP) PKDOPR = * 10000*(IROP+100) + 1000*IOPER + (ILOP+100) CURSOR = 211 NMD211 = 1 + PKDOPR - (PKDOPR/211)*211 HASHPT = HASH(NMD211) IF (HASHPT.EQ.0) GO TO 20 CURSOR = HASHPT 10 PC = PACKED(CURSOR) IF (PC.EQ.PKDOPR) GO TO 30 TRY = NEXT(CURSOR) IF (TRY.EQ.0) GO TO 20 CURSOR = TRY GO TO 10 C C INSERT THE OPERATION SINCE IT IS NOT REDUNDANT. 20 STKTOP = STKTOP + 1 IF (STKTOP.GT.500) GO TO 70 IF (HASHPT.NE.0) NEXT(CURSOR) = STKTOP IF (HASHPT.EQ.0) HASH(NMD211) = STKTOP PACKED(STKTOP) = PKDOPR NEXT(STKTOP) = 0 NBR = STKTOP + 100 ISOLD = 0 GO TO 40 C C THE OPERATION IS REDUNDANT. 30 NBR = CURSOR + 100 ISOLD = 1 40 RETURN C C INITIALIZE OR TERMINATE. 50 IF (INISH.EQ.1) NBR = STKTOP IF (INISH.EQ.1) GO TO 40 DO 60 I=1,211 HASH(I) = 0 60 CONTINUE STKTOP = 0 GO TO 40 C C STACK OVERFLOW. 70 IER = 1 GO TO 40 END SUBROUTINE INTERP C ************************** C ************************** INTERPRETER C ************************** MAIN SUBROUTINE INTERP C ************************** C C CALLING SEQUENCE: C C CALL INTERP C C ARGUMENTS: NONE C C INTERP OPERATES ON THE INTEGER ARRAY ICODE IN COMMON WHICH CONTAINS C INTERMEDIATE CODE GENERATED BY THE PARSER/CODE GERATOR ROUTINES. C INTERP PLACES ITS RESULTS IN THREE MORE INTEGER ARRAYS IN COMMON C (FDAT, FINT, FOUT). C C PURPOSE: C C TO EXECUTE THE INTERMEDIATE CODE IN ICODE, RECORDING ALL SIGNIFICANT C OPERATIONS WHICH TAKE PLACE (REAL ARITHMETIC, INPUT AND OUTPUT OF C VARIABLES). C C PROCEDURE: C C INCLUDING INTERP, THERE ARE THREE SUBROUTINES INVOLVED IN C THE INTERPRETATION PROCESS. THEIR OBJECTIVES ARE BRIEFLY LISTED C BELOW. C C INTERP: THE MAIN ROUTINE, RESPONSIBLE FOR DIRECTING THE C EXECUTION OF EACH INSTRRUCTION. INTERP ITSELF C DOES NOT PRODUCE ANY OUTPUT. C OPER: THE ROUTINE WHICH HANDLES ALL GENERATION OF C OUTPUT IN THE FORM OF ARRAY ENTRIES. C REALOP: THE ROUTINE WHICH CHECKS ALL REAL OPERATIONS FOR C POSSIBLE OPTIMIZATION. THIS INVOLVES BYPASSING C OPERATIONS WHOSE RESULT WAS KNOWN BECAUSE ONE OR C MORE OF THE OPERANDS HAD THE VALUE ZERO. C C BASIC ELEMENTS OF THE INTERPRETATION PROCESS WILL BE DESCRIBED HERE. C DETAILED DESCRIPTIONS OF EACH INSTRUCTION WILL APPEAR IN THE DOCU- C MENTATION FOR SUBROUTINE OPER. C C - THE INTERPRETER EXECUTES A PROGRAM BY RECORDING THE OCCURENCE C OF OPERATIONS INVOLVING REAL VARIABLES. THIS IS POSSIBLE C BASICALLY BECAUSE ALL BRANCHING DECISIONS ARE BASED ON THE C VALUES OF INTEGER VARIABLES ONLY (NO REAL IF STATEMENT). C C - INTEGER EXPRESSIONS ARE EVALUATED AS THEY ARE ENCOUNTERED. C THAT IS, AT ANY TIME THE INTERPRETER KNOWS EXACTLY WHAT THE C VALUE OF ANY INTEGER VARIABLE IS. C C - REAL OPERATIONS ARE NOT PERFORMED, THEIR OCCURENCE IN THE C EXECUTION PHASE IS "RECORDED", AND VALUE OF REAL VARIABLES C IS CHANGED ACCORDINGLY. C C - EVERY REAL VARIABLE HAS ASSOCIATED WITH IT AN INTEGER CODE C WHICH DESCRIBES ITS VALUE. POSSIBLE CODES AND THEIR C MEANINGS ARE: C C (1) UNDEFINED (VALUE = 0): C C ALL REAL VARIABLES ARE INITIALIZED TO THIS VALUE. C C (2) THE I-TH CONSTANT (VALUE = -I): C C ALL CONSTANTS CODED IN THE PREGRAM ARE GIVEN A VALUE C LESS THAN ZERO. A VARIABLE MAY ALSO TAKE ON A VALUE C < 0 AS THE RESULT OF SOME REAL OPERATION. IT SHOULD C BE NOTED THAT ONLY ONE REAL ZERO CONSTANT AND ONE C REAL CONSTANT ONE ARE STORED, NO MATTER HOW MANY C ARE CODED. C C (3) THE I-TH INPUT VALUE (VALUE = I): C C A REAL VARIABLE IS ASSIGNED THIS VALUE AS THE RESULT C OF AN INPUT STATEMENT (OR AS THE RESULT OF A REAL C OPERATION). IT IS THE PROGRAMMERS RESPONSIBILITY TO C SEE THAT VALUES IN THE INPUT MATCH THE VARIABLES IN C THE INPUT STATEMENTS. C C (4) THE I-TH INTERMEDIATE VALUE (VALUE = 100+I): C THE I-TH INTERMEDIATE VALUE IS THAT WHICH IS THE C REAULT OF THE I-TH REAL OPERATION. C C (5) THE NULL VALUE (VALUE = 50): C THIS VALUE INDICATES THAT THIS REAL VARIABLE IS C EXACTLY ZERO.THE VALUE ZERO CAN BE GENERATED BY A C CONSTANT ZERO OR BY A NULL SUMMATION VARIABLE, AND C CODE OPTIMIZATION IS PERFORMED ON THE NULL VALUE C WHENEVER POSSIBLE (SEE SUBROUTINE REALOP). IT SHOULD C BE NOTED THAT IF A CONSTANT ZERO MUST BE ENTERED INTO C THE SYMBOL TABLE, THE NULL VALUE WILL BECOME THE C VALUE OF THE CONSTANT ZERO IN THE TABLE. C C INTERP WILL DISTINGUISH BETWEEN SIMPLE AND COMPLEX OPERATIONS. C SIMPLE OPERATIONS ARE HANDLED BY CALLING SUBROUTINE OPER, WHILE C COMPLEX OPERATIONS WILL REQUIRE ONE OR MORE CALLS TO OPER, PLUS C POSSIBLY SOME OTHER ACTIONS. COMPLEX OPERATIONS ARE INPUT, C OUTPUT, FOR, AND SUMMATION. C C THE BASIC ALGORITHM USED IS AS FOLLOWS. C C (0) INITIALIZATION. C SET LOCATION COUNTER = 1. C C (1) FETCH. C TRANSFER INSTRUCTION POINTED TO BY LOCATION COUNTER FROM ICODE C INTO INS ARRAY (DONE FOR FASTER ACCESS TO THE INSTRUCTION). C ADVANCE LOCATION COUNTER BY ONE. C C (2) PERFORM SIMPLE INSTRUCTION. C IF INSTRUCITON IS NOT SIMPLE TYPE, GOTO (3). C IF OPERATION IS REAL ARITHMETIC, CALL REALOP, ELSE CALL OPER. C GOTO (1). C C (3) PERFORM INPUT/OUTPUT OPERATIONS. C IF INSTRUCTION IS NOT INPUT OR OUTPUT, GOTO (4). C IF THIS IS INPUT/OUTPUT OF A VARIABLE OR OF ONE ELEMENT OF AN C ARRAY, CALL OPER, GOTO (1). C IF THIS INPUT/OUTPUT OF AN ARRAY, C - GET DIMENSIONS OF ARRAY FROM SUBROUTINE GETDIM. C - USING THESE DIMENSIONS, CALL OPER ONCE FOR EACH OF THE C ELEMENTS OF THE ARRAY, IN COLUMN-MAJOR ORDER. C GOTO (1). C C (4) PERFORM SUMMATION OPERATION. C IF INSTRUCTION IS NOT SUMMATION, GOTO (5). C IF INITIAL VALUE OF THE INDEX EXCEEDS THE BOUND VALUE, SET C THE RESULT EQUAL TO THE NULL VALUE, GOTO (1). C SET THE RESULT EQUAL TO THE FIRST PRODUCT IN THE SUMMATION. C FOR EACH TERM REMAINING IN THE SUMMATION, C SET A TEMPORARY EQUAL TO THE VALUE OF THAT PRODUCT. C SET THE RESULT EQUAL TO THE SUM OF THE RESULT AND THE C TEMPORARY VALUE. C GOTO (1). C C (5) PERFORM FOR OPERATION. C IF THIS IS THE FIRST TIME THROUGH THE FOR INSTRUCTION, SET C INS(6) = LOOP BOUND, INS(7) = 1 AND STORE BACK INTO THE C ICODE ARRAY. C CALL OPER. C IF THIS WAS THE LAST TIME THROUGH THE FOR LOOP C (OPER WOULD HAVE SET INS(7) = 0), STORE THE INSTRUCTION C BACK INTO THE ICODE ARRAY. C C ======================================= C C COMMON; COMMON VARIABLES REFERENCED: C /STATE/ STMTNO: NUMBER OF STATEMENT CONTAINING THIS INSTRUCTION. C /INTCOD/ ICODE(500,11): CONTAINS INSTRUCTIONS TO BE EXECUTED. C IKNT : NUMBER OF INSTRUCTIONS IN ICODE. C /SUM/ NULVAL: THE CODED VALUE OF THE REAL CONSTANT ZERO. C DUM : FLAG INDICATING A SUMMATION INSTRUCTION IS BEING C EXECUTED. C /ITEMPS/ ITEMP(30): ARRAY CONTAINING INTEGER TEMPORARIES. C C LOCAL INTEGER STRUCTURES: C INS(10): TEMPORARY ARRAY INTO WHICH EACH INSTRUCTION IS FETCHED. C -- TEMPORARIES USED IN SUMMATION INSTRUCTION -- C SMULT(10): THE MULTIPLICATION INSTRUCTION. C SADD(10): THE ADDITION INSTRUCTION. C IS(4): USED IN COMPUTING ARRAY SUBSCRIPTS. C C LOCAL LOGICAL STRUCTURES: C DUM2(4): USED IN THE SUMMATION INSTRUCTION. C (DUM2(I) = .TRUE. IF THE I'TH SUBSCRIPT IS THE DUMMY C VARIABLE: FOUR SUBSCRIPTS ARE POSSIBLE, TWO FOR EACH C REAL VARIABLE). C C LOCAL INTEGER VARIABLES: C OLDLOC: LOCATION IN ICODE OF THE CURRENT INSTRUCTION. C LOCNTR: LOCATION IN ICODE OF NEXT INSTRUCTION TO BE EXECUTED. C (MAY BE ALTERED BY A BRANCH, OR A TEST). C OP : OP CODE FOR THIS INSTRUCTION (EQUIVALENCED TO INS(1)). C IS1,IS2,IS3,IS4: TEMPORARIES USED IN SUBSCRIPT CALCULATION. C ITYP,ID1,ID2: TEMPORARIES USED IN THE INPUT/OUTPUT INSTRUCTIONS. C LSTART,LEND,LTIMES: TEMPORARIES USED IN SUMMATION INSTRUCTION. C C ======================================= COMMON /STATE/ STMTNO COMMON /INTCOD/ ICODE, IKNT COMMON /SUM/ DUM, NULTAB, NULVAL, NULSTM COMMON /ITEMPS/ ITEMP, ITOP COMMON /SUBS/ NDUMMY INTEGER ITEMP(30), ICODE(500,11), INS(10), SMULT(10), SADD(10), * IS(4), NDUMMY(6), OP, OLDLOC, RD5, BT7, STMTNO LOGICAL DUM, DUM2(4), NULSTM INTEGER ZERO(10) EQUIVALENCE (INS(1),OP) DATA SMULT(1), SMULT(2), SMULT(4) /3,1,0/, SADD(1), SADD(2), * SADD(4), SADD(5), SADD(7), SADD(8), SADD(9), SADD(10) * /1,1,0,1,0,1,1,0/, DUM2(1), DUM2(2), DUM2(3), DUM2(4) /4*.FALSE./ DATA ZERO(1), ZERO(2), ZERO(3), ZERO(4), ZERO(5), ZERO(6), * ZERO(7), ZERO(8), ZERO(9), ZERO(10) /1H0,1H.,1H0,7*1H / LOCNTR = 1 10 IF (LOCNTR.GT.IKNT) GO TO 180 OP = ICODE(LOCNTR,1) IF (OP.EQ.99) CALL COMPO2(LOCNTR) DO 20 I=1,10 INS(I) = ICODE(LOCNTR,I) 20 CONTINUE OLDLOC = LOCNTR STMTNO = ICODE(LOCNTR,11) LOCNTR = LOCNTR + 1 C === C DETERMINE TYPE OF OPERATION C - SIMPLE OR COMPLEX C IF (OP.EQ.17 .OR. OP.EQ.18) GO TO 40 IF (OP.EQ.12) GO TO 160 IF (OP.EQ.21) GO TO 80 IF (OP.GT.6) GO TO 30 CALL REALOP(INS, LOCNTR) CALL OPER(INS, OP, LOCNTR) GO TO 10 C === C HERE FOR SIMPLE OPERATIONS: CALL OPER C 30 CALL OPER(INS, OP, LOCNTR) GO TO 10 C === C HERE FOR INPUT/OUTPUT OPERATIONS C - CALL OPER FOR FOR EACH ELEMENT TO BE HANDLED C 40 ITYP = INS(5) IF (ITYP.GE.3 .AND. INS(3).EQ.0) GO TO 50 C === C HERE IF ONLY ONE ELEMENT IS BEING HANDLED C IS1 = INS(3) IS2 = INS(4) IF (IS1.NE.0) IS1 = ITEMP(IS1) IF (IS2.NE.0) IS2 = ITEMP(IS2) INS(3) = IS1 INS(4) = IS2 CALL OPER(INS, OP, LOCNTR) GO TO 10 C === C HERE FOR AN ENTIRE ARRAY: C GET DIMENSIONS, HANDLE ARRAY IN COLUMN-MAJOR ORDER C 50 CALL GETDIM(INS(2), ID1, ID2) IF (ID2.EQ.0) ID2 = 1 DO 70 I1=1,ID2 DO 60 I2=1,ID1 INS(3) = I2 IF (ITYP.EQ.4) INS(4) = I1 CALL OPER(INS, OP, LOCNTR) 60 CONTINUE 70 CONTINUE GO TO 10 C === C HERE FOR SUMMATION VARIABLE C 80 CONTINUE LSTART = INS(8) LEND = INS(9) LSTART = ITEMP(LSTART) + 1 LEND = ITEMP(LEND) IF (LSTART-1.LE.LEND) GO TO 90 N5 = 5 CALL ADD(ZERO, N5, NVAL) CALL GETVAL(NVAL, 0, 0, IVAL) CALL STORE(1, INS(10), 0, IVAL) GO TO 10 90 IS(1) = INS(3) IS(2) = INS(4) IS(3) = INS(6) IS(4) = INS(7) SMULT(3) = INS(10) SMULT(5) = INS(2) SMULT(8) = INS(5) DUM = .TRUE. DO 120 I=1,4 IF (IS(I)) 100, 120, 110 100 DUM2(I) = .TRUE. IS(I) = LSTART - 1 GO TO 120 110 IS1 = IS(I) IS(I) = ITEMP(IS1) 120 CONTINUE SMULT(6) = IS(1) SMULT(7) = IS(2) SMULT(9) = IS(3) SMULT(10) = IS(4) CALL REALOP(SMULT, LOCNTR) CALL OPER(SMULT, 3, LOCNTR) SMULT(3) = 1 SADD(3) = INS(10) SADD(6) = INS(10) LTIMES = LEND - LSTART + 1 IF (LTIMES.EQ.0) GO TO 140 DO 130 I2=1,LTIMES I = I2 + LSTART - 1 IF (DUM2(1)) SMULT(6) = I IF (DUM2(2)) SMULT(7) = I IF (DUM2(3)) SMULT(9) = I IF (DUM2(4)) SMULT(10) = I CALL REALOP(SMULT, LOCNTR) CALL OPER(SMULT, 3, LOCNTR) CALL REALOP(SADD, LOCNTR) CALL OPER(SADD, 1, LOCNTR) 130 CONTINUE 140 DO 150 I=1,4 DUM2(I) = .FALSE. 150 CONTINUE DUM = .FALSE. GO TO 10 C === C HERE FOR THE FOR OPERATION C - HANDLE FIRST AND LAST TIMES THROUGH AS SPECIAL CASES C 160 CONTINUE IF (INS(7).NE.0) GO TO 170 ITMP = INS(3) INS(6) = ITEMP(ITMP) ICODE(OLDLOC,6) = INS(6) INS(7) = 1 ICODE(OLDLOC,7) = 1 170 CALL OPER(INS, OP, LOCNTR) IF (INS(7).EQ.0) ICODE(OLDLOC,7) = 0 GO TO 10 180 RETURN END SUBROUTINE KFIND(SYMBOL, ICODE) C ************************** C ************************** LEXICAL ANALYZER C ************************** SUBROUTINE KFIND C ************************** C C CALLING SEQUENCE: C C CALL KFIND(SYMBOL,ICODE), C WHERE SYMBOL IS A TEN ELEMENT ARRAY CONTAINING THE SYMBOL TO C BE TESTED AND ICODE IS AN INTEGER VARIABLE WHOSE VALUE IS DE- C FINED BY KFIND. C C ARGUMENTS: C C SYMBOL -- THE SYMBOL WHICH IS TO BE TESTED. C ICODE -- THE RESULT OF THE TEST. C C PURPOSE: C C TO RETURN ICODE = 0 IF THE IDENTIFIER IN ARRAY SYMVOL IS NOT A C KEYWORD. ELSE, (IF THE IDENTIFIER IS A KEYWORD) TO RETURN THE C TYPE OF THAT KEYWORD. C C (FOR RELATION KEYWORDS, AND THE KEYWORDS INPUT AND OUTPUT, C SPECIAL VALUES ARE RETURNED FROM WHICH THE TYPE AND VALUE C ARE LATER DERIVED) C C PROCEDURE: C C SUBROUTINE KFIND EXECUTES A BINARY SEARCH ON A TABLE OF KEYWORDS C TO DETERMINE IF THE SYMBOL IS A KEYWORD. C C - IF IT IS, THE ICODE VALUE IS RETRIEVED FROM ANOTHER PRE- C DEFINED ARRAY (AN ARRAY OF ICODE VALUES CORRESPONDING TO C THE ARRAY OF KEYWORDS). C C - IF IT IS NOT, ICODE = 0 IS RETURNED. C C ======================================= C C LOCAL INTEGER STRUCTURES: C KEYCAR(10,18): CHARACTER REPRESENTATIONS OF ALL THE KEYWORDS. C --K(93),L(83): USED TO DATA-INITIALIZE ARRAY KEYCAR. C KEYTOK(18): TOKENS FOR THE CORRESPONDING KEYWORDS IN KEYCAR. C --M(18) : USED TO DATA-INITIALIZE KEYTOK. C C LOCAL INTEGER VARIABLES: C LEFT, MID, RIT: USED IN THE BINARY SEARCH. C -- CONSTANTS USED BY KFIND -- C BLK: BLANK. C C ======================================= INTEGER SYMBOL(10), KEYCAR(10,18), KEYTOK(18), BLK, LEFT, RIT, MID INTEGER K(93), L(83), M(18) EQUIVALENCE (KEYCAR(1),K(1)), (KEYCAR(1,11),L(1)), * (KEYTOK(1),M(1)) DATA BLK /1H / DATA K(1), K(2), K(3) /1HB,1HY,1H / DATA K(11), K(12), K(13), K(14), K(15), K(16), K(17), K(18), * K(19), K(20) /1HD,1HI,1HM,1HE,1HN,1HS,1HI,1HO,1HN,1H / DATA K(21), K(22), K(23), K(24) /1HE,1HN,1HD,1H / DATA K(31), K(32), K(33) /1HE,1HQ,1H / DATA K(41), K(42), K(43), K(44) /1HF,1HO,1HR,1H / DATA K(51), K(52), K(53) /1HG,1HE,1H / DATA K(61), K(62), K(63) /1HG,1HT,1H / DATA K(71), K(72), K(73) /1HI,1HF,1H / DATA K(81), K(82), K(83), K(84), K(85), K(86) /1HI,1HN,1HP,1HU, * 1HT,1H / DATA K(91), K(92), K(93) /1HL,1HE,1H / DATA L(1), L(2), L(3) /1HL,1HT,1H / DATA L(11), L(12), L(13) /1HN,1HE,1H / DATA L(21), L(22), L(23), L(24), L(25), L(26), L(27) /1HO,1HU,1HT, * 1HP,1HU,1HT,1H / DATA L(31), L(32), L(33), L(34), L(35) /1HS,1HQ,1HR,1HT,1H / DATA L(41), L(42), L(43), L(44), L(45), L(46), L(47), L(48), * L(49), L(50) /1HS,1HU,1HM,1HM,1HA,1HT,1HI,1HO,1HN,1H / DATA L(51), L(52), L(53), L(54), L(55) /1HT,1HE,1HS,1HT,1H / DATA L(61), L(62), L(63), L(64), L(65) /1HT,1HH,1HE,1HN,1H / DATA L(71), L(72), L(73) /1HT,1HO,1H / DATA M(1), M(2), M(3), M(4), M(5), M(6), M(7), M(8), M(9), M(10) * /10,6,13,31,8,36,34,11,67,35/ DATA M(11), M(12), M(13), M(14), M(15), M(16), M(17), M(18) * /33,32,68,17,7,16,12,9/ LEFT = 0 RIT = 19 MID = 10 C == C BEGIN BINARY SEARCH ON KEYWORD SYMBOL TABLE C === 10 DO 30 I=1,10 IF (SYMBOL(I).EQ.KEYCAR(I,MID)) GO TO 20 IF (SYMBOL(I).GT.KEYCAR(I,MID)) GO TO 60 GO TO 50 20 IF (SYMBOL(I).EQ.BLK) GO TO 40 30 CONTINUE C === C HERE IF SYMBOL EQUAL TO THIS KEYWORD C === 40 ICODE = KEYTOK(MID) GO TO 90 C === C HERE IF SYMBOL LESS THAN THIS KEYWORD C === 50 RIT = MID GO TO 70 C === C HERE IF SYMBOL GREATER THAN THIS KEYWORD C === 60 LEFT = MID 70 IF (RIT-LEFT.EQ.1) GO TO 80 MID = (LEFT+RIT)/2 GO TO 10 C === C HERE IF SYMBOL IS NOT A KEYWORD C === 80 ICODE = 0 90 RETURN END SUBROUTINE LEXAN(TYPE, VALUE) C ************************** C ************************** LEXICAL ANALYZER C ************************** MAIN SUBROUTINE LEXAN C ************************** C C CALLING SEQUENCE: C C CALL LEXAN(TYPE,VALUE), C WHERE TYPE AND VALUE ARE INTEGER VARIABLES WHOSE VALUE WILL BE C DEFINED BY THE LEXICAL ANALYZER. C C ARGUMENTS: C C TYPE -- TYPE OF THE NEXT TOKEN IN THE INPUT STREAM C VALUE -- THE VALUE ASSOCIATED WITH THE TOKEN (IF THIS TOKEN HAS NO C VALUE ASSOCIATED WITH IT, VALUE = -1 IS RETURNED) C C PURPOSE: C C TO RETURN THE TYPE AND VALUE OF THE NEXT TOKEN IN THE INPUT STREAM C WHEN CALLED BY THE PARSER. TYPE AND VALUE MEANINGS FOR TOKENS ARE C INDICATED BELOW. C C TOKEN TYPE VALUE C ----- ---- ----- C >>> (VARIABLES AND CONSTANTS) <<< C INTEGER VARIABLE 0 SYMBOL TABLE LOCATION OF VARIABLE C INTEGER CONSTANT 1 SYMBOL TABLE LOCATION OF CONSTANT C REAL VARIABLE 2 SYMBOL TABLE LOCATION OF VARIABLE C REAL 1-D ARRAY 3 SYMBOL TABLE LOCATION OF ARRAY C REAL 2-D ARRAY 4 SYMBOL TABLE LOCATION OF ARRAY C REAL CONSTANT 5 SYMBOL TABLE LOCATION OF CONSTANT C >>> (KEYWORDS) <<< C DIMENSION 6 -1 C SUMMATION 7 -1 C FOR 8 -1 C TO 9 -1 C BY 10 -1 C IF 11 -1 C THEN 12 -1 C END 13 -1 C INPUT 15 17 C OUTPUT 15 18 C TEST 16 -1 C SQRT 17 -1 C EQ 26 1 C NE 26 2 C LT 26 3 C GT 26 4 C LE 26 5 C GE 26 6 C >>> (SYMBOLS AND DELIMITERS) <<< C = (ASSIGNMENT) 18 -1 C + (ADDITION) 19 -1 C - (SUBTRACTION) 20 -1 C * (MULTIPLICATION) 21 -1 C / (DIVISION) 22 -1 C ( (OPEN PARENTHESIS) 23 -1 C ) (CLOSE PARENTHESIS) 24 -1 C , (COMMA SEPARATOR) 25 -1 C . (PERIOD) 30 -1 C END-OF-STATEMENT 27 -1 C END-OF-FILE 28 -1 C DUMMY VARIABLE 29 -1 C C OTHER DUTIES ASSUMED BY THE LEXICAL ANALYZER: C C DETECT END-OF-FILE C CHECK FOR SOME OF THE USER SYNTAX ERRORS C - NAMES, CONSTANTS TOO LONG C - STATEMENT TOO LONG C - INVALID CHARACTERS IN STATEMENT C ADD ALL SYMBOLS AND CONSTANTS TO THE SYMBOL TABLE C - DONE BY CALLING ADD C - VALUE OF INTEGER CONSTANTS STORED BY CALLING STORE C - THE (REAL) CONSTANT ZERO MUST BE ADDED ONLY ONCE C REPLACE OCCURENCES OF THE SUMMATION INDEX VARIABLE BY THE TOKEN C FOR DUMMY (TYPE = 29, VALUE = -1). THIS RELACEMENT MUST ONLY BE C DONE INSIDE THE SUMMATION VARIABLE. C C PROCEDURE: C C LEXAN MAKES USE OF TWO SUBROUTINES, GETSTM AND KFIND, WHICH ARE C BRIEFLY DESCRIBED HERE (DETAILED DESCRIPTIONS APPEAR LATER). C C - SUBROUTINE GETSTM RETURNS THE CHARACTER REPRESENTATION OF C THE NEXT STATEMENT. IT CHECKS FOR END-OF-FILE AND HANDLES C SOME OF THE ABOVE MENTIONED USER SYNTAX ERRORS. C C - SUBROUTINE KFIND DETERMINES WHETHER OR NOT A GIVEN SYMBOL C IS A KEYWORD. C C THE BASIC ALGORITHM USED IS AS FOLLOWS. C C (1) IF THE TEXT FOR THIS STATEMENT HAS BEEN EXHAUSTED, CALL GETSTM C FOR THE NEXT STATEMENT. GOTO (2) C C (2) LOOK AT THE CLASS OF THE NEXT CHARACTER (THE CLASS OF EACH C CHARACTER IS RETURNED BY GETSTM). C C - IF CLASS = 12, THIS IS A BLANK: C ADVANCE THE INPUT POINTER AND GOTO (2). C - IF CLASS < 10, THIS IS A DIGIT AND THE BEGINNING OF A C CONSTANT: GOTO (3). C - IF CLASS = 10, THIS IS A CHARACTER AND THE BEGINNING OF A C NAME: GOTO (4). C - IF CLASS > 12, THIS IS A DELIMITER (WHICH INCLUDES END-OF- C STATEMENT AND END-OF-FILE): GOTO (5). C C (3) GATHER FIRST TEN CHARACTERS OF THE CONSTANT, ENTER INTO C SYMBOL TABLE. IF CONSTANT IS INTEGER TYPE, ENTER VALUE INTO C SYMBOL TABLE (USING SUBROUTINE STORE). GENERATE ERROR MESSAGE C IF CONSTANT EXCEEDS TEN CHARACTERS, TRUNCATE CONSTANT. IF C CONSTANT IS A REAL ZERO, ENTER BY CALLING SUBROUTINE ADDZRO. C RETURN TYPE AND VALUE OF THE SYMBOL. C C (4) GATHER FIRST TEN CHARACTERS OF THE SYMBOL. GENERATE ERROR C MESSAGE IF SYMBOL EXCEEDS TEN CHARACTERS, TRUNCATE SYMBOL. C C - IF THIS SYMBOL IS THE SUMMATION VARIABLE DUMMY PARAMETER, C RETURN TOKEN FOR DUMMY. C - IF THIS SYMBOL IS A KEYWORD, RETURN TYPE, VALUE FOR THAT C KEYWORD. C - IF THE KEYWORD WAS SUMMATION, SCAN AHEAD FOR AND SAVE C THE DUMMY PARAMETER AND THE LOCATION OF THE CLOSE PAREN- C THESIS OF THE SUMMATION VARIABLE. C - IF NONE OF THE ABOVE, ENTER SYMBOL INTO SYMBOL TABLE AND C RETURN TYPE AND VALUE OF THE SYMBOL. C C (5) RETURN CLASS OF CHARACTER (RETURNED BY GETSTM IN A SEPARATE C ARRAY) AFTER CHECKING THE BELOW SPECIAL CASES. C C - IF CHARACTER IS A PERIOD AND THIS IS NOT AN IF STATEMENT, C THEN THIS IS THE BEGINNING OF A REAL CONSTANT, GOTO (3). C - IF THIS IS THE CLOSE PARENTHESIS OF A SUMMATION VARIABLE, C TERMINATE SCANNING FOR THE DUMMY VARIABLE (AND BLANK OUT C DUMMY ARRAY). C C ======================================= C C COMMON; COMMON VARIABLES REFERENCED: C /SUM/ NULTAB: TABLE LOCATION OF REAL CONSTANT ZERO. C C LOCAL INTEGER STRUCTURES: C STMCAR(330): CHARACTER REPRESENTATION OF STATEMENT BEING ANALYZED. C VALUES DEFINED BY GETSTM. C STMCLS(330): CLASS OF EACH OF THE CHARACTERS IN STMCAR. C VALUES DEFINED BY GETSTM. C SYMBOL(10): EITHER THE SYMBOL OR THE CONSTANT BEING ANALYZED. C DUMMY(10): THE DUMMY VARIABLE OF A SUMMATION TERM. C C LOCAL INTEGER VARIABLES: C STMPTR: POINTER TO CHARACTER CURRNETLY BEING PROCESSED. C STMSIZ: NUMBER OF CHARACTERS IN THE STATEMENT, DEFINED BY GETSTM. C KSYMB : LENGTH OF THE SYMBOL BEING PROCESSED. C -- SUMMATION SCANNING TEMPORARIES -- C IDMBEG: POINTER TO FIRST CHARACTER OF DUMMY VARIABLE. C IDMEND: POINTER TO LAST CHARACTER OF DUMMY VARIABLE. C SCNPTR: POINTER TO CHARACTER BEING SCANNED. C CLAS : CLASS OF CHARACTER BEING SCANNED. C PCNT : COUNT OF PARENTHESIS LEVELS ENCOUNTERED DURING C SUMMATION SCANNING. C PCNT = 0 MEANS CURRENTLY OUTSIDE OF PARENTHESIS NESTS C PCNT > 0 MEANS INSIDE PCNT LEVELS OF PARENTHESIS NESTS. C PCNT < 0 MEANS PCNT EXTRA )'S HAVE BEEN ENCOUNTERED. C LSCOL : POINTER TO ) WHICH END SUMMATION TERM. C LKEY : TYPE OF FIRST KEYWORD IN STATEMENT. C INTVAL: VALUE OF INTEGER CONSTANT. C -- CONSTANTS USED BY LEXAN -- C CONB : BLANK. C ZRO : DIGIT ZERO. C PRD : PERIOD. C C LOCAL LOGICAL VARIABLES: C IFLAG : WHEN TRUE, ARRAY INITIALIZATION HAS BEEN DONE. C (I.E., THIS IS NOT THE FIRST CALL TO LEXAN). C FSUM : WHEN TRUE, ALL SYMBOLS ARE CHECKED AGAINST THE SUMMATION C DUMMY VARIABLE (AFTER CHECKING FOR KEYWORDS). C FERR16: WHEN TRUE, ERROR # 16 HAS BEEN ENCOUNTERED ON THIS CARD C C ======================================= COMMON /SUM/ DUM, NULTAB, NULVAL, NULSTM COMMON /IO/ NREAD, NPRINT, NPUNCH INTEGER STMPTR, STMSIZ, TYPE, VALUE, SCNPTR, CLAS, PCNT, CONB INTEGER SYMBOL(10), DUMMY(10), STMCAR(330), STMCLS(330) LOGICAL NULSTM, DUM, FSUM, FERR16 DATA STMPTR, STMSIZ, LSCOL, LKEY /1,3*0/ DATA FERR16, FSUM, CONB /2*.FALSE.,1H / DATA DUMMY(1), DUMMY(2), DUMMY(3), DUMMY(4), DUMMY(5), DUMMY(6), * DUMMY(7), DUMMY(8), DUMMY(9), DUMMY(10) /10*1H /, SYMBOL(1), * SYMBOL(2), SYMBOL(3), SYMBOL(4), SYMBOL(5), SYMBOL(6), * SYMBOL(7), SYMBOL(8), SYMBOL(9), SYMBOL(10) /10*1H / TYPE = -1 VALUE = -1 C === C READ IN NEXT STATEMENT IF NECESSARY C === IF (STMPTR.LE.STMSIZ) GO TO 10 CALL GETSTM(STMCAR, STMCLS, STMSIZ) STMPTR = 1 LKEY = 0 C === C THE CLASS OF THE FIRST CHARACTER WILL BE USED TO DETERMINE WHICH OF C OF THREE SECTIONS WILL GAIN CONTROL. C CLASS = 0 TO 9: THE CONSTANTS HANDLER C CLASS = 10: THE SYMBOL HANDLER C CLASS > 10: THE DELIMITER/OPERATOR HANDLER C AN ARITHMETIC IF STATEMENT IS USED TO MAKE THE THREE-WAY BRANCH C === 10 IF (STMCLS(STMPTR).NE.12) GO TO 20 STMPTR = STMPTR + 1 GO TO 10 20 IF (STMCLS(STMPTR)-10) 30, 120, 300 C === C CONSTANTS HANDLER C - CHECK FOR CONSTANT TOO LARGE (ERROR NUMBER 14) C - DETERMINE TYPE OF CONSTANT (INTEGER OR REAL) C - DETERMINE VALUE OF INTEGER CONSTANTS C === 30 TYPE = 1 GO TO 50 40 TYPE = 5 50 SYMBOL(1) = STMCAR(STMPTR) INTVAL = STMCLS(STMPTR) STMPTR = STMPTR + 1 KSYMB = 1 60 IF (STMCLS(STMPTR).GT.9) GO TO 70 C === C HERE IF CHARACTER IS A DIGIT C - CHECK FOR SYMBOL TOO LARGE C - ADJUST SYMBOL VALUE IF INTEGER CONSTANT C === IF (KSYMB.EQ.10) GO TO 90 IF (TYPE.NE.1) GO TO 80 INTVAL = INTVAL*10 + STMCLS(STMPTR) GO TO 80 C === C HERE IF CHARACTER WAS NOT A DIGIT C IF NOT A PERIOD, THIS IS END OF CONSTANT: ELSE, C - IF LAST KEYWORD WAS IF, THIS IS END OF THE CONSTANT C - ELSE, C - IF TYPE IS REAL, THIS IS END OF CONSTANT (AND ERROR) C - ELSE, - CHECK FOR SYMBOL TOO LARGE C - CHANGE TYPE TO REAL C === 70 IF (STMCLS(STMPTR).NE.30) GO TO 100 IF (LKEY.EQ.11) GO TO 100 IF (KSYMB.EQ.10) GO TO 90 IF (TYPE.EQ.5) GO TO 100 TYPE = 5 C === C PROCEED TO NEXT CHARACTER C === 80 KSYMB = KSYMB + 1 SYMBOL(KSYMB) = STMCAR(STMPTR) STMPTR = STMPTR + 1 GO TO 60 C === C HERE IF CONSTANT TOO LARGE C - PRINT ERROR MESSAGE C - FLUSH CHARACTERS UP TO FIRST NON-DIGIT C === 90 STMPTR = STMPTR + 1 IF (STMCLS(STMPTR).LE.9) GO TO 90 CALL ERROR(15, SYMBOL, 0, 0) C === C HERE TO ENTER SYMBOL IN TABLE C === 100 CALL ADD(SYMBOL, TYPE, VALUE) IF (TYPE.EQ.1) CALL STORE(VALUE, 0, 0, INTVAL) DO 110 I=1,KSYMB SYMBOL(I) = CONB 110 CONTINUE GO TO 330 C === C SYMBOL HANDLER: C - DETERMINE IF SYMBOL IS A KEYWORD, NAME, OR DUMMY VARIABLE C - INITIALIZE SUMMATION SCANNING VARIABLES IF NECESSARY C - HANDLE THE FOLLOWING ERRORS: C 13: SYMBOL TOO LONG C === 120 KSYMB = 1 SYMBOL(1) = STMCAR(STMPTR) 130 STMPTR = STMPTR + 1 IF (STMCLS(STMPTR).GT.10) GO TO 150 IF (KSYMB.EQ.10) GO TO 140 KSYMB = KSYMB + 1 SYMBOL(KSYMB) = STMCAR(STMPTR) GO TO 130 C === C HERE IF SYMBOL IS TOO LONG C === 140 STMPTR = STMPTR + 1 IF (STMCLS(STMPTR).LE.10) GO TO 140 CALL ERROR(16, SYMBOL, 0, 0) C === C CALL KFIND TO DETERMINE IF SYMBOL IS A KEYWORD C === 150 CALL KFIND(SYMBOL, TYPE) IF (TYPE.EQ.0) GO TO 250 C === C HERE IF SYMBOL IS A KEYWORD C === IF (LKEY.EQ.0) LKEY = TYPE IF (TYPE.LT.31 .OR. TYPE.GT.36) GO TO 160 C === C HANDLE TYPE, VALUE DETERMINATION FOR RELATIONS C AND INPUT/OUTPUT STATEMENTS C === VALUE = TYPE - 30 TYPE = 26 160 IF (TYPE.LT.50) GO TO 170 VALUE = TYPE - 50 TYPE = 15 C === C IF KEYWORD WAS SUMMATION, INITIALIZE SCANNING VARIABLES C === 170 IF (TYPE.NE.7) GO TO 280 C === C GET THE DUMMY VARIABLE INTO ARRAY DUMMY C === SCNPTR = STMPTR 180 IF (SCNPTR.NE.STMSIZ) GO TO 190 C === C HERE IF THE EQUAL SIGN WAS NOT FOUND C - SEND AN END-OF-STATEMENT TOKEN C - PRINT ERROR MESSAGE C === CALL IERROR(17) TYPE = 27 STMPTR = STMSIZ + 1 GO TO 280 190 IF (STMCLS(SCNPTR).EQ.18) GO TO 200 IF (STMCLS(SCNPTR).EQ.10 .AND. STMCLS(SCNPTR-1).GT.10) IDMBEG = * SCNPTR SCNPTR = SCNPTR + 1 GO TO 180 200 IDMEND = SCNPTR - 1 IDMSIZ = IDMEND - IDMBEG + 1 IF (IDMSIZ.LE.10) GO TO 210 IDMSIZ = 10 IDMEND = IDMBEG + 9 FERR16 = .TRUE. 210 IDMPTR = 0 DO 220 I=IDMBEG,IDMEND IDMPTR = IDMPTR + 1 DUMMY(IDMPTR) = STMCAR(I) 220 CONTINUE IF (FERR16) CALL ERROR(16, DUMMY, 0, 0) FERR16 = .FALSE. C === C SET FLAG FSUM TO .TRUE. AND C DETERMINE VALUE OF LSCOL C === FSUM = .TRUE. PCNT = 0 230 SCNPTR = SCNPTR + 1 CLAS = STMCLS(SCNPTR) IF (CLAS.NE.13) GO TO 240 C === C HERE IF THE CLOSE PARENTHESIS WAS NOT FOUND C - SEND AN END-OF-STATEMENT TOKEN C - PRINT ERROR MESSAGE C === CALL IERROR(17) TYPE = 27 STMPTR = STMSIZ + 1 GO TO 280 240 IF (CLAS.EQ.23) PCNT = PCNT + 1 IF (CLAS.EQ.24) PCNT = PCNT - 1 IF (PCNT.GE.0) GO TO 230 LSCOL = SCNPTR GO TO 280 C === C HERE IF SYMBOL NOT A KEYWORD C - COMPARE WITH DUMMY VARIABLE IF NECESSARY C - IF NOT, ADD TO SYMBOL TABLE C === 250 IF (.NOT.FSUM) GO TO 270 IF (KSYMB.NE.IDMSIZ) GO TO 270 DO 260 I=1,KSYMB IF (SYMBOL(I).NE.DUMMY(I)) GO TO 270 260 CONTINUE C === C HERE IF SYMBOL IS THE DUMMY C === TYPE = 29 GO TO 280 C === C HERE IF SYMBOL NOT DUMMY C === 270 TYPE = -1 CALL ADD(SYMBOL, TYPE, VALUE) GO TO 280 C === C BLANK OUT SYMBOL ARRAY C === 280 DO 290 I=1,KSYMB SYMBOL(I) = CONB 290 CONTINUE GO TO 330 C === C DELIMITER/OPERATOR HANDLER C === 300 TYPE = STMCLS(STMPTR) IF (TYPE.EQ.30 .AND. LKEY.NE.11) GO TO 40 IF (STMPTR.NE.LSCOL) GO TO 320 C === C HERE IF END OF SUMMATION SCAN C - RESET FSUM TO .FALSE., LSCOL TO 0 C - BLANK OUT DUMMY ARRAY C === FSUM = .FALSE. LSCOL = 0 DO 310 I=1,IDMSIZ DUMMY(I) = CONB 310 CONTINUE 320 STMPTR = STMPTR + 1 330 RETURN END SUBROUTINE NEXT C C THE SUBROUTINE NEXT IS CALLED BY CODGEN TO GET ANOTHER LINE OF C INTERMEDIATE CODE. C COMMON /INTCOD/ ICODE(500,11), LINE /STATE/ ST INTEGER ICODE, LINE, ST LINE = LINE + 1 IF (LINE.GT.500) CALL TERROR(2) ICODE(LINE,11) = ST RETURN END SUBROUTINE OPER(INS, OP, LOCNTR) C ************************** C ************************** INTERPRETER C ************************** SUBROUTINE OPER C ************************** C C CALLING SEQUENCE: C C CALL OPER(INS,OP,LOCNTR) C C WHERE INS IS A TEN ELEMENT ARRAY, AND OP AND LOCNTR ARE INTEGER C VARIABLES. C C ARGUMENTS: C C LOCNTR -- THE LOCATION OF THIS INSTRUCTION+1. C INS -- THE INSTRUCTION TO BE PERFORMED. C OP -- THE OP CODE FOR THE INSTRUCTION (OP = INS(1)). C C PURPOSE: C C TO EXECUTE THE BASIC INSTRUCTION LOCATED IN ARRAY INS. C C OPER WILL ASSUME THE OPERATIONS CONFORM TO THE FOLLOWING FORMATS AND C RULES (ANY OTHER ASSUMPTIONS -- PREVIOUS PROCESSING, ETC. -- WILL C ALSO BE DESCRIBED HERE). C C FORMATS: C C OP CODES 1 THROUGH 6: REAL ARITHMETIC. C C INS(1) = OP CODE, (1,2,3,4,5,6) = (ADDITION, SUBTRACTION, C MULTIPLICATION, DIVISION, SQUARE ROOT, UNARY MINUS). C INS(2) = SYMBOL TABLE POINTER FOR REAL TEMPORARY ARRAY (= 1). C INS(3) = LOCATION IN REAL TEMPORARY ARRAY OF TARGET. C INS(4) = 0. C INS(5) = SYMBOL TABLE POINTER FOR FIRST ARGUMENT. C INS(6), INS(7) = SUBSCRIPTS FOR FIRST ARGUMENT. C INS(8) = SYMBOL TABLE POINTER FOR SECOND ARGUMENT. C INS(9), INS(10) = SUBSCRIPTS FOR SECOND ARGUMENT. C C OP CODES 7 THROUGH 10: INTEGER ARITHMETIC. C C INS(1) = OP CODE, (7,8,9,10) = (ADDITION, SUBTRACTION, C MULTIPLICATION, DIVISION). C INS(2) = TARGET. C INS(3) = LEFT OPERAND. C INS(4) = RIGHT OPERAND. C C OP CODE 11: INTEGER INCREMENT/DECREMENT. C C INS(1) = OP CODE = 11. C INS(2) = POINTER TO INTEGER TEMPORARY TO BE CHANGED. C INS(5) = INCREMENT/DECREMENT CODE. C = 0 FOR INCREMENT, = 1 FOR DECREMENT. C C OP CODE 12: FOR LOOP INSTRUCTION C C INS(1) = OP CODE = 12. C INS(2) = POINTER TO INTEGER TEMPORARY SERVING AS LOOP INDEX. C INS(4) = FOR LOOP DIRECTION INDICATOR. C = 0 FOR DECREASING LOOP INDEX. C = 1 FOR INCREASING LOOP INDEX. C INS(5) = BRANCH POINT IF LOOP IS COMPLETED. C INS(6) = LIMIT OF FOR LOOP. C INS(7) = RETURNED VALUE. C INS(7) IS SET TO ZERO WHEN LOOP IS COMPLETED: C SUBROUTINE INTERP MUST KNOW WHEN THE FOR IS COMPLETE. C C OP CODE 13: INTEGER TEST. C C INS(1) = OP CODE = 13. C INS(2) = POINTER TO INTEGER TEMPORARY FOR LEFT OPERAND. C INS(3) = POINTER TO INTEGER TEMPORARY FOR RIGHT OPERAND. C INS(4) = COMPARE CODE. C = 1 FOR LEFT .EQ. RIGHT. C = 2 FOR LEFT .NE. RIGHT. C = 3 FOR LEFT .LT. RIGHT. C = 4 FOR LEFT .GT. RIGHT. C = 5 FOR LEFT .LE. RIGHT. C = 6 FOR LEFT .GE. RIGHT. C INS(5) = BRANCH POINT FOR SUCCESSFUL TEST. C C OP CODE = 14: BRANCH. C C INS(1) = OP CODE = 14. C INS(2) = BRANCH POINT. C C OP CODE 15: REAL STORE. C C INS(1) = OP CODE = 15. C INS(2) = SYMBOL TABLE POINTER FOR TARGET. C INS(3), INS(4) = SUBSCRIPTS FOR TARGET. C INS(5) = SYMBOL TABLE POINTER FOR VALUE TO BE STORED. C INS(6), INS(7) = SUBSCRIPTS FOR VALUE TO BE STORED. C C OP CODE 16: END OF EXECUTION. C C INS(1) = OP CODE = 16. C C OP CODE 17: INPUT OF A SINGLE VARIABLE. C C INS(1) = OP CODE = 17. C INS(2) = SYMBOL TABLE LOCATION OF VARIABLE. C INS(3), INS(4) = SUBSCRIPTS OF VARIABLE. C C OP CODE 18: OUTPUT OF A SINGLE VARIABLE. C C INS(1) = OP CODE = 18. C INS(2) = SYMBOL TABLE LOCATION OF VARIABLE. C INS(3), INS(4) = SUBSCRIPTS OF VARIABLE. C C OP CODE 19: LOADING AN INTEGER TEMPORARY. C C INS(1) = OP CODE = 19. C INS(2) = POINTER TO INTEGER TEMPORARY CONTAINING VALUE. C (IF = 0, 0 IS VALUE TO BE LOADED). C INS(3) = POINTER TO INTEGER TEMPORARY TO BE LOADED. C C OP CODE 20: INTEGER STORE INTO INTEGER VARIABLE. C C INS(1) = OP CODE = 20. C INS(2) = SYMBOL TABLE LOCATION OF VARIABLE TO BE CHANGED. C INS(3) = POINTER TO INTEGER TEMPORARY CONTAINING VALUE. C C RULES: C C RETRIEVING THE VALUE OF A REAL VARIABLE. C REAL VARIABLES ARE DESCRIBED IN THE INSTRUCTIONS AS A SYMBOL TABLE C POINTER WITH TWO SUBSCRIPTS. THE FOLLOWING PROCESS MUST BE FOLLOWED C IN ORDER TO GET THE VARIABLE'S VALUE FROM THE TABLE. C C - SET SUB1, SUB2 TO ZERO. C - FOR I = 1 TO 2, IF THE I'TH SUBSCRIPT IS NOT ZERO, C AND IF LOGICAL VARIABLE DUM(I) IS .FALSE., C SUB(I) TO ITEMP(SUBSCRIPT(I)). C C - CALL GETVAL(POINTER,SUB1,SUB2,VAL1) TO GET THE VALUE OF THE C VARIABLE INTO VAL1. C ** THE LOGICAL VARIABLE DUM(I) IS NECESSARY TO DISTINGUISH C A NON-ZERO SUBSCRIPT BEING AN INDEX INTO ITEMP OR THE C DUMMY VARIABLE FOR A SUMMATION VARIABLE. ** C C RETRIEVING AN INTEGER VALUE. C FOR INTEGER VARIABLES: C SINCE THERE ARE NO INTEGER ARRAYS, THERE ARE NO SUBSCRIPTS TO C EVALUATE IN RETRIEVING AN INTEGER VARIABLE -- ONLY THE SYMBOL C TABLE INDEX IS NEEDED (IF THE INDEX IS GIVEN AS 0, IT IS AS- C SUMED THAT THE VALUE 0 IS DESIRED). C C FOR INTEGER TEMPORARIES: C INTEGER TEMPORARIES ARE VALUES CONTAINED IN THE ITEMP ARRAY. C THESE VALUES ARE USED TO CALCULATE SUBSCRIPTS, FOR LOOP C INDICIES, AND IN INTEGER TEST STATEMENTS. THE VALUE IS C RETRIEVING BY USING THE POINTER AS AN INDEX INTO THE ITEMP C ARRAY. C C PROCEDURE: C C THE FOLLOWING ARE DESCRIPTIONS OF THE MOST IMPORTANT OPERATIONS C PERFORMED BY SUBROUTINE OPER. THESE DESCRIPTIONS WILL BE REFERRED C TO IN LATER SECTIONS OF THE DOCUMENTATION. C C INCREMENT INTERMEDIATE CODE COUNTER: C THIS COUNTER WILL REMEMBER HOW MANY LINES OF INTERME- C DIATE CODE HAVE BEEN GENERATED. WHEN INCREMENTED, IT C IS CHECKED AGAINST ITS MAXIMUM VALUE, AND OVERFLOW RE- C SULTS IN TERMINATION OF THE INTERPRETER. IT IS USED C AS AN INDEX INTO THE ARRAY CONTAINING THE INTERMEDIATE C GENERATED BY THE PROGRAM. C C INCREMENT INPUT, OUTPUT COUNTERS: C THESE COUNTERS REMEMBER HAVE MANY VARIABLES HAVE BEEN C INPUT OR OUTPUT. THESE TOO ARE CHECKED WHEN INCREMENTED, C AND ARE USED AS INDICES INTO ARRAYS WHICH RECORD THE C OCCURENCE OF AN INPUT OR OUTPUT OPERATION. C C RECORD REAL ARITHMETIC INSTRUCTION IN ARRAY INT: C ARRAY INT WILL CONTAIN ALL REAL ARITHMETIC OPERATIONS C IN THE FOLLOWING MANNER. C INT(*,1) = VALUE OF FIRST OPERAND. C INT(*,2) = VALUE OF THE SECOND OPERAND. C INT(*,3) = OP CODE. C (1,2,3,4,5,6) ==> C ADD, SUBTRACT, MULTIPLY, DIVIDE, C SQUARE ROOT, UNARY MINUS C + C 10*(THE SYMBOL TABLE POINTER OF THE C TARGET OF THIS OPERATION, IF IT WAS C NOT A REAL TEMPORARY). C INT(*,4) = 101*(THE FIRST SUBSCRIPT) C + C (THE SECOND SUBSCRIPT) C C RECORD INPUT INSTRUCTION IN ARRAY FDAT: C ARRAY FOUT WILL CONTAIN ALL INPUT VARIABLES IN THE C FOLLOWING MANNER. NOTE THAT WHAT IS REMEMBERED IS C WHICH INPUT VALUE CORRESPONDS TO WHICH VARIABLE. C FDAT(*,1) = SYMBOL TABLE POINTER OF THE VARIABLE C BEING INPUT. C FDAT(*,2) = 101*(THE FIRST SUBSCRIPT) C + C (THE SECOND SUBSCRIPT) C C RECORD OUTPUT INSTRUCTION IN ARRAY FOUT: C ARRAY FOUT WILL REMEMBER OUTPUT VARIABLES IN THE C FOLLOWING WAY. WITH OUTPUT, BOTH THE VARIABLE NAME, AND C ITS VALUE, AT THE TIME OF THE OUTPUT INSTRUCITON, ARE C REMEMBERED. C FOUT(1) = SYMBOL TABLE POINTER FOR VARIABLE C FOUT(2) = 101*(FIRST SUBSCRIPT) C + C (SECOND SUBSCRIPT) C FOUT(3) = THE VARIABLE'S VALUE AT TIME OF OUTPUT C C DEPENDING ON THE VALUE OF OP (THE OP CODE), PERFORM ONE OF THE C FOLLOWING PROCEDURES. C FOLLOWING IS A BRIEF DESCRIPTION OF WHAT IS DONE FOR EACH C INSTRUCTION. C C REAL ARITHMETIC: OP CODES 1 TO 6 C - ASSUME THAT SUBROUTINE REALOP HAS ALREADY CALCULATED THE VALUES C OF THE TWO ARGUMENTS. C - INCREMENT INTERMEDIATE CODE COUNTER. C - RECORD REAL ARITHMETIC INSTRUCTION. C C INTEGER ARITHMETIC INSTRUCTION: OP CODES 7 TO 10 C - GET INTEGER TEMPORARY VALUES. C - PERFORM OPERATION SPECIFIED BY OP CODE C (ON DIVISION BY ZERO, GENERATE ERROR MESSAGE, C SET RESULT TO DIVIDEND). C - STORE RESULT INTO SPECIFIED INTEGER TEMPORARY. C C INTEGER INCREMENT/DECREMENT: OP CODE 11 C - EITHER ADD OR SUBTRACT ONE FROM THE SPECIFIED INTEGER TEMPORARY, C STORE BACK INTO THAT TEMMORARY. C C FOR OPERATION: OP CODE 12 C - GET INDEX, BOUND VALUES FORM INTEGER TEMPORARIES. C - COMPARE THEM ACCORDING TO SPECIFIED COMPARE CODE. C - IF COMPARISON IS SUCCESSFUL, SET LOCNTR TO SPECIFIED C BRANCH ADDRESS, SET FLAG IN INSTRUCTION FOR INTERP C (TO LET IT KNOW THE LOOP IS COMPLETED). C C INTEGER TEST: OP CODE 13 C - GET LEFT, RIGHT VALUES FOR COMPARISON FROM INTEGER TEMPORARIES. C - COMPARE ACCORDING TO SPECIFIED COMPARED CODE. C - IF COMPARISON IS SUCCESSFUL, SET LOCNTR TO SPECIFIED C BRANCH ADDRESS. C C BRANCH: OPOCDE 14 C - SET LOCNTR TO SPECIFIED BRANCH ADDRESS. C C REAL STORE: OP CODE 15 C - GET THE REAL VALUE TO BE STORED. C - THE LOCATION ARGUMENTS TO SUBROUTINE STORE FOR THE TARGET C ARE OBTAINED IN THE SAME WAY AS THOSE TO SUBROUTINE GETVAL C FOR THE VALUE BEING STORED: USE THESE ARGUMENTS TO STORE C THE REAL VALUE JUST OBTAINED. C - IF THE VALUE BEING STORED WAS A TEMPORARY (AND THE STATEMENT C WAS NOT NULL -- I.E., NO REAL ARITHMETIC PERFORMED BECAUSE C OF CODE OPTIMIZATION), ALTER THE PREVIOUSLY REAL ARITHMETIC C INSTRUCTION TO REMEMBER THE VARIABLE IT WAS STORED INTO. C C END: OP CODE 16 C - CALL SUBROUTINE FINISH C C INPUT OF A SINGLE VARIABLE: OP CODE 17 C - INCREMENT INPUT COUNTER. C - RECORD INPUT INSTRUCTION. C C OUTPUT OF A SINGLE VARIABLE: OP CODE 18 C - INCREMENT OUTPUT COUNTER. C - RECORD OUTPUT INSTRUCTION. C C LOADING AN INTEGER TEMPORARY: OP CODE 19 C - GET VALUE TO BE LOADED FROM INTEGER TEMPORARY C (IF INDEX TO TEMPORARY ARRAY IS = 0, ASSUME THAT THE VALUE 0 C IS TO BE STORED). C - STORE INTEGER VALUE INTO SPECIFIED INTEGER TEMPORARY. C C STORING INTO AN INTEGER VARIABLE: OP CODE 20 C - GET VALUE TO BE STORED FROM INTEGER TEMPORARY. C - STORE INTO SPECIFIED INTEGER VARIABLE (USING SUBROUTINE C STORE TO ACCESS SYMBOL TABLE). C C ======================================= C C COMMON; COMMON VARIABLES REFERENCED: C /STATE/ STMTNO: NUMBER OF STATEMENT CONTAINING THIS INSTRUCTION. C /SUM/ NULVAL: THE CODED VALUE OF THE REAL CONSTANT ZERO. C NULSTM: FLAG INDICATING THAT NO REAL OPERATIONS HAVE TAKEN C PLACE FOR THIS STATMENT AS YET. C DUM : FLAG INDICATING THE SUMMATION INSTRUCTION IS BEING C EXECUTED (I.E., THAT THE SUBSCRIPTS HAVE ALREADY C BEEN CALCULATED BY SUBROUTINE INTERP). C /SUBS/ IS1,IS2,VAL1: SUBSCRIPTS, AND CODED VALUE FOR THE FIRST C OPERAND OF A REAL OPERATION C IS3,IS4,VAL2: SUBSCRIPTS, AND CODED VALUE FOR THE SECOND C OPERAND OF A REAL OPERATION C (ALL VALUES IN COMMON BLOCK SUBS ARE COMPUTED BY REALOP) C /ITEMPS/ ITEMP(30): ARRAY CONTAINING INTEGER TEMPORARIES. C /FIN/ FDAT,FINT,FOUT: ARRAYS INTO WHICH RESULTS OF THE PROGRAM C ARE PLACED, TO BE USED BY ROUTINE FINISH. C KDAT,KINT,KOUT: NUMBER OF ELEMENTS IN ARRAYS FDAT, FINT, C AND FOUT, RESPECTIVELY. C C LOCAL INTEGER STRUCTURES: C HOLDT(10): ARRAY CONTAINING NAMES OF C VARIABLES, WITH SUBSCRIPTS. C C LOCAL INTEGER VARIABLES: C ILOC: THE LOCATION IN ICODE OF THIS INSTRUCTION. C KINT: COUNT OF NUMBER OF REAL INTERMEDIATE VALUES GENERATED. C INTVAL: CODED VALUE FOR THIS REAL INTERMEDIATE VALUE. C -- TEMPORARY VALUES USED THROUGHOUT PROGRAM -- C -- FOR INTEGER TESTS AND BRANCH: C COMP: INTEGER CODE FOR TYPE OF COMPARE IN TEST. C BRCH: BRANCH POINT ON SUCCESSFUL TEST. C -- FOR INTEGER OPERATIONS: C IY,IZ: INTEGER TEMPORARY ARRAY LOCATIONS FOR LEFT AND RIGHT C OPERANDS, RESPECTIVELY. C IX: INTEGER TEMPORARY ARRAY LOCATION FOR RESULT OF OPERATION. C IRES: RESULT OF THE OPERATION. C IOP2: USED AS COMPUTED GOTO INDEX. C -- FOR RETRIEVING INTEGER TEMPORARY VALUES: C ITMP: USED TO PREVENT HAVING A SUBSCRIPTED VALUE AS A C SUBSCRIPT (ILLEGAL IN STANDARD FORTRAN). C C ======================================= COMMON /OPTS/ F0, F1, OPT COMMON /ERRNUM/ ERR COMMON /STATE/ STMTNO COMMON /SUM/ DUM, NULTAB, NULVAL, NULSTM COMMON /SUBS/ IS1, IS2, IS3, IS4, VAL1, VAL2 COMMON /ITEMPS/ ITEMP, ITOP COMMON /FIN/ FDAT, INT, FOUT, KDAT, KINT, KOUT COMMON /COMPOZ/ NCUT INTEGER ITEMP(30), INS(10), HOLDT(10), ERR INTEGER FDAT(50,2), INT(500,5), FOUT(20,3) INTEGER STMTNO, OP, VAL1, VAL2, COMP, BRCH, F0, F1, OPT LOGICAL DUM, NULSTM GO TO (10, 10, 10, 10, 10, 10, 20, 20, 20, 20, 90, 100, 140, 180, * 190, 210, 220, 230, 250, 260), OP C === C HERE FOR: REAL ADD, SUBTRACT, MULTIPLY, DIVIDE C - ADD TO THE PUNCHED CODE ARRAY: C INT(*,1) = ITEMP TABLE VALUE FOR FIRST VARIABLE C INT(*,2) = ITEMP TABLE VALUE FOR FIRST VARIABLE C INT(*,3) = OPERATION (1,2,3,4 ===> +,-,*,/) C INT(*,5) = WHICH INTERMEDIATE VALUE THIS IS C 10 KINT = KINT + 1 INTVAL = 100 + KINT IF (OP.GE.5) VAL2 = 0 IF (KINT.GT.500) CALL TERROR(3) CALL STORE(1, INS(3), 0, INTVAL) NULSTM = .FALSE. INT(KINT,1) = VAL1 INT(KINT,2) = VAL2 INT(KINT,3) = OP INT(KINT,5) = STMTNO GO TO 270 C === C HERE FOR INTEGER ARITHMETIC C 20 CONTINUE IOP2 = OP - 6 IX = INS(2) IY = INS(3) IZ = INS(4) GO TO (30, 40, 50, 60), IOP2 30 IRES = ITEMP(IY) + ITEMP(IZ) GO TO 80 40 IRES = ITEMP(IY) - ITEMP(IZ) GO TO 80 50 IRES = ITEMP(IY)*ITEMP(IZ) GO TO 80 60 IF (ITEMP(IZ).NE.0) GO TO 70 IRES = ITEMP(IY) CALL ERROR(27, HOLDT, IRES, 0) GO TO 80 70 IRES = ITEMP(IY)/ITEMP(IZ) 80 ITEMP(IX) = IRES GO TO 270 C === C HERE FOR INTEGER INCREMENT/DECREMENT C 90 CALL GETVAL(INS(2), 0, 0, VAL1) IF (INS(5).EQ.0) VAL1 = VAL1 + 1 IF (INS(5).EQ.1) VAL1 = VAL1 - 1 CALL STORE(INS(2), 0, 0, VAL1) GO TO 270 C === C HERE FOR THE FOR OPERATION C TEST LOOP INDEX AGAINST LIMIT C 100 CONTINUE CALL GETVAL(INS(2), 0, 0, VAL1) VAL2 = INS(6) COMP = 4 - INS(4) BRCH = INS(5) IF (COMP.EQ.3) GO TO 110 IF (VAL1.GT.VAL2) GO TO 120 GO TO 130 110 IF (VAL1.LT.VAL2) GO TO 120 GO TO 130 120 INS(7) = 0 LOCNTR = BRCH 130 GO TO 270 C === C HERE FOR INTEGER TEST C 140 COMP = INS(4) BRCH = INS(5) VAL1 = INS(2) VAL2 = INS(3) VAL1 = ITEMP(VAL1) VAL2 = ITEMP(VAL2) IF (VAL2-VAL1) 150, 160, 170 150 IF (COMP.EQ.3 .OR. COMP.EQ.1 .OR. COMP.EQ.5) LOCNTR = BRCH GO TO 270 160 IF (COMP.EQ.2 .OR. COMP.EQ.3 .OR. COMP.EQ.4) LOCNTR = BRCH GO TO 270 170 IF (COMP.EQ.1 .OR. COMP.EQ.4 .OR. COMP.EQ.6) LOCNTR = BRCH GO TO 270 C === C HERE FOR BRANCH - ALTER LOCNTR C 180 LOCNTR = INS(2) GO TO 270 C === C HERE FOR REAL STORE C - STORE ONE REAL VALUE INTO ANOTHER C - IF VALUE BEING STORED IS A TEMPORARY, C ALTER THE LAST STRAIGHT-LINE CODE ENTRY C 190 IS1 = INS(3) IS2 = INS(4) IS3 = INS(6) IS4 = INS(7) IF (IS1.NE.0) IS1 = ITEMP(IS1) IF (IS2.NE.0) IS2 = ITEMP(IS2) IF (IS3.NE.0 .AND. INS(5).NE.1) IS3 = ITEMP(IS3) IF (IS4.NE.0) IS4 = ITEMP(IS4) CALL GETVAL(INS(5), IS3, IS4, VAL1) CALL STORE(INS(2), IS1, IS2, VAL1) IF (INS(5).NE.1 .OR. NULSTM) GO TO 200 INT(KINT,3) = INT(KINT,3) + INS(2)*10 INT(KINT,4) = IS1*101 + IS2 200 NULSTM = .TRUE. GO TO 270 C === C HERE FOR THE END: CALL FINISH C 210 CONTINUE CALL IERROR(50) IF (ERR.NE.0) GO TO 270 IF (OPT.EQ.1 .AND. NCUT.EQ.0) CALL CODOPT CALL FINISH GO TO 270 C === C HERE FOR INPUT OF A SINGLE VARIABLE C 220 KDAT = KDAT + 1 IS1 = INS(3) IS2 = INS(4) IF (KDAT.GT.50) CALL TERROR(2) CALL STORE(INS(2), IS1, IS2, KDAT) FDAT(KDAT,1) = INS(2) FDAT(KDAT,2) = IS1*101 + IS2 GO TO 270 C === C HERE FOR OUTPUT OF A SINGLE VARIABLE C 230 KOUT = KOUT + 1 IF (KOUT.GT.20) CALL TERROR(3) IS1 = INS(3) IS2 = INS(4) CALL GETVAL(INS(2), IS1, IS2, VAL1) IF (VAL1.GT.100) GO TO 240 CALL GETNAM(INS(2), HOLDT) CALL ERROR(31, HOLDT, IS1, IS2) GO TO 270 240 FOUT(KOUT,1) = INS(2) FOUT(KOUT,2) = IS1*101 + IS2 FOUT(KOUT,3) = VAL1 GO TO 270 C === C HERE FOR LOADING A TEMPORARY VALUE C 250 VAL1 = 0 IF (INS(2).NE.0) CALL GETVAL(INS(2), 0, 0, VAL1) ITMP = INS(3) ITEMP(ITMP) = VAL1 GO TO 270 C === C HERE FOR INTEGER STORE (ALTER VALUE OF INTEGER VARIABLE) C 260 VAL1 = INS(3) VAL1 = ITEMP(VAL1) CALL STORE(INS(2), 0, 0, VAL1) 270 RETURN END SUBROUTINE RDIM(INDEX, C1, C2) C C ****************************************************************** C * * C * RDIM * C * * C * GIVEN A POINTER INTO THE SYMBOL TABLE AND TWO DIMENSIONS * C * (THE SECOND OF WHICH MAY BE ZERO),RDIM CHANGES THE REAL * C * VARIABLE AT THAT LOCATION TO A ONE OR TWO-DIMENSIONAL ARRAY. * C * DIM ALSO ALLOCATES STORAGE FOR THE ARRAY. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL * /MISC/ INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, * AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N LOGICAL DEFIND(50) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300), INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, * VAR, AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N C C INDEX POINTER INTO THE SYMBOL TABLE C C1 ROW DIMENSION FOR THE ARRAY -- MAY NEVER BE ZERO C C2 COLUMN DIMENSION FOR THE ARRAY -- WILL BE ZERO IF C THE ARRAY IS ONE-DIMENSIONAL C INTEGER INDEX, C1, C2, NAM(10) IF (.NOT.DEFIND(INDEX)) GO TO 10 C ELSE ATTEMPT TO REDIMENSION A REAVAR CALL GETNAM(INDEX, NAM) CALL ERROR(3, NAM, 0, 0) GO TO 40 C THEN ALLOCATE STORAGE BASED ON DIMENSION 10 VALUE(INDEX) = AUXPTR + 1 DEFIND(INDEX) = .TRUE. IF (C2.NE.0) GO TO 20 C ELSE ONE DIMENSIONAL ARRAY TYPE(INDEX) = ONEDIM AUXPTR = AUXPTR + C1 GO TO 30 C THEN TWO DIMENSIONAL ARRAY 20 TYPE(INDEX) = TWODIM AUXPTR = AUXPTR + (C1*C2) COLS(INDEX) = C2 30 ROWS(INDEX) = C1 IF (AUXPTR.GT.AUXLIM) CALL TERROR(1) 40 RETURN END SUBROUTINE REALOP(INS, LOCNTR) COMMON /SUM/ DUM, NULTAB, NULVAL, NULSTM COMMON /SUBS/ IS1, IS2, IS3, IS4, IVAL1, IVAL2 COMMON /ITEMPS/ ITEMP, ITOP INTEGER INS(10), ITEMP(30) LOGICAL DUM, NULSTM ILOC = LOCNTR - 1 IOP = INS(1) NI = INS(3) IS1 = INS(6) IS2 = INS(7) IS3 = INS(9) IS4 = INS(10) IP1 = INS(5) IP2 = INS(8) IF (DUM) GO TO 10 IF (IS1.NE.0 .AND. IP1.NE.1) IS1 = ITEMP(IS1) IF (IS2.NE.0) IS2 = ITEMP(IS2) IF (IS3.NE.0 .AND. IP2.NE.1) IS3 = ITEMP(IS3) IF (IS4.NE.0) IS4 = ITEMP(IS4) 10 CALL GETVAL(IP1, IS1, IS2, IVAL1) IVAL2 = 0 IF (IOP.LE.4) CALL GETVAL(IP2, IS3, IS4, IVAL2) RETURN END SUBROUTINE STORE(INDEX, IC1, IC2, CONST) C C ****************************************************************** C * * C * STORE * C * * C * GIVEN A POINTER INTO THE SYMBOL TABLE (AND ROW AND COLUMN * C * POINTERS FOR AN ARRAY ELEMENT) AND A VALUE, STORE WILL ASSIGN * C * THE VALUE TO THE UNDEFINED INTEGER CONSTANT, THE VARIABLE, OR * C * THE ARRAY ELEMENT. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL * /MISC/ INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, VAR, * AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N LOGICAL DEFIND(50) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300), INTVAR, INTCON, REAVAR, ONEDIM, TWODIM, REACON, * VAR, AUXPTR, AUXLIM, SYMPTR, SYMLIM, I, N C C INDEX POINTER INTO SYMBOL TABLE -- POINTS TO ITEM TO BE C ASSIGNED A VALUE (UNLESS IT POINTS TO AN ARRAY) C C1 ROW POINTER FOR AN ARRAY ELEMENT -- SET TO ONE IF C OUT OF RANGE C C2 COLUMN POINTER FOR AN ARRAY ELEMENT -- SET TO ONE C IF OUT OF RANGE C CONST VALUE TO WHICH ITEM IS TO BE SET C NAM NAME OF ITEM BEING DEFINED -- USED IN CALLS TO ERROR C PTR POINTER TO A PARTICULAR ELEMENT IN AN ARRAY C INTEGER INDEX, C1, C2, CONST, NAM(10), PTR C1 = IC1 C2 = IC2 IF (TYPE(INDEX).NE.REACON) GO TO 10 C ELSE ERROR -- CANNOT GIVE NEW VALUE TO CONSTANT CALL GETNAM(INDEX, NAM) CALL ERROR(5, NAM, 0, 0) GO TO 70 C THEN CHECK WHETHER ARRAY OR NOT 10 IF (TYPE(INDEX).EQ.ONEDIM .OR. TYPE(INDEX).EQ.TWODIM) GO TO 20 C ELSE THIS IS REAVAR, INTVAR, OR UNDEFINED INTCON VALUE(INDEX) = CONST DEFIND(INDEX) = .TRUE. GO TO 70 C THEN THIS IS ARRAY -- CHECK OUT C1, C2 FOR VALIDITY 20 IF (C1.GT.0 .AND. C1.LE.ROWS(INDEX)) GO TO 30 C ELSE C1 NOT VALID -- USE 1 CALL GETNAM(INDEX, NAM) CALL ERROR(1, NAM, C1, C2) C1 = 1 30 IF (TYPE(INDEX).EQ.ONEDIM) GO TO 50 C ELSE CHECK OUT C2 IF (C2.GT.0 .AND. C2.LE.COLS(INDEX)) GO TO 40 C ELSE C2 NOT VALID -- USE 1 CALL GETNAM(INDEX, NAM) CALL ERROR(2, NAM, C1, C2) C2 = 1 40 PTR = VALUE(INDEX) + ((IC1-1)*COLS(INDEX)) + IC2 - 1 GO TO 60 C THEN GET PTR INTO ONEDIM ARRAY 50 PTR = VALUE(INDEX) + C1 - 1 60 AUXVAL(PTR) = CONST 70 RETURN END SUBROUTINE SYMINT C C ****************************************************************** C * * C * SYMINT * C * * C * SYMINT PROVIDES INITIAL VALUES FOR PARTS OF THE SYMBOL * C * TABLE, I.E. ROWS, COLS, DEFIND, AND AUXVAL. * C * * C ****************************************************************** C COMMON /SYMTAB/ NAME, TYPE, VALUE, ROWS, COLS, DEFIND, AUXVAL LOGICAL DEFIND(50) INTEGER NAME(50,10), TYPE(50), VALUE(50), ROWS(50), COLS(50), * AUXVAL(300) C C SET ALL ROWS AND COLS TO ZERO SINCE ALL ITEMS TO BE PUT IN THE C TABLE ARE CONSIDERED SCALAR UNTIL THERE IS A SPECIFIC REQUEST MADE C TO DIMENSION AN ITEM. MARK ALL POSITIONS IN THE TABLE AS C UNDEFINED INITIALLY. C DO 10 K=1,50 ROWS(K) = 0 COLS(K) = 0 DEFIND(K) = .FALSE. 10 CONTINUE C THE FIRST POSITION IN THE TABLE IS INITIALIZED AS AN ARRAY. ROWS(1) = 200 DEFIND(1) = .TRUE. C C FILL AUXILIARY STORAGE WITH ZEROS. THE VALUE ZERO INDICATES C THAT A POSITION IN AUXILIARY STORAGE IS UNDEFINED. C DO 20 K=1,300 AUXVAL(K) = 0 20 CONTINUE RETURN END SUBROUTINE TERROR(TERNUM) C C ****************************************************************** C * * C * TERROR * C * * C * GIVEN THE NUMBER OF ONE OF THE SEVEN TERMINAL ERROR * C * MESSAGES, TERROR PRINTS THE MESSAGE AND TERMINATES EXECUTION. * C * * C ****************************************************************** C C TERNUM THE NUMBER OF THE TERMINAL ERROR MESSAGE TO BE PRINTED C C ****************************************************************** C * * C * TABLE OF TERMINAL ERROR MESSAGES * C * * C * 1 SYMBOL TABLE OVERFLOW * C * 2 INTERMEDIATE CODE OVERFLOW * C * 3 STRAIGHT LINE CODE OVERFLOW * C * 4 PARSE STACK OVERFLOW * C * 5 INTEGER EXPRESSION TOO COMPLEX * C * 6 TOO MANY INTERMEDIATE REAL VALUES * C * 7 EXCESSIVE NESTING OF FOR/IF BLOCKS * C * * C ****************************************************************** C COMMON /IO/ NREAD, NPRINT, NPUNCH INTEGER TERNUM WRITE (NPRINT,99999) GO TO (10, 20, 30, 40, 50, 60, 70), TERNUM 10 WRITE (NPRINT,99998) GO TO 80 20 WRITE (NPRINT,99997) GO TO 80 30 WRITE (NPRINT,99996) GO TO 80 40 WRITE (NPRINT,99995) GO TO 80 50 WRITE (NPRINT,99994) GO TO 80 60 WRITE (NPRINT,99993) GO TO 80 70 WRITE (NPRINT,99992) 80 WRITE (NPRINT,99991) STOP 99999 FORMAT (19H-*** FATAL ERROR --) 99998 FORMAT (1H+, 19X, 25HSYMBOL TABLE OVERFLOW ***) 99997 FORMAT (1H+, 19X, 30HINTERMEDIATE CODE OVERFLOW ***) 99996 FORMAT (1H+, 19X, 31HSTRAIGHT LINE CODE OVERFLOW ***/9H (PRO, * 24HGRAM EXECUTION TOO LONG)) 99995 FORMAT (1H+, 19X, 24HPARSE STACK OVERFLOW ***/16H (STATEMENT T, * 11HOO COMPLEX)) 99994 FORMAT (1H+, 19X, 34HINTEGER EXPRESSION TOO COMPLEX ***) 99993 FORMAT (1H+, 19X, 37HTOO MANY REAL INTERMEDIATE VALUES ***) 99992 FORMAT (1H+, 19X, 44HLIMIT EXCEEDED FOR NESTING OF FOR/IF BLOCKS , * 3H***) 99991 FORMAT (1H0, 19X, 27HMINICOMPILER VERSION 2.1.79) END C.......... ROUNDING ERROR ANALYSIS OF A SINGLE ALGORITHM C C THE USER SUPPLIES: C C THE OUTPUT FROM THE MINICOMPILER. C C THE ENTRIES OF THE INITIAL SET OF DATA. ONE ENTRY PER LINE, EACH C ENTRY WRITTEN WITH A DECIMAL POINT AND CONTAINED IN THE FIRST C TWENTY COLUMNS. C C ONE OF THE ERROR-COMPARING OPTIONS 'JWE', 'JWL', 'WKE', 'WKL', C 'ERE', 'ERL', 'EXP' TYPED IN THE FIRST THREE COLUMNS OF ITS LINE. C 'EXP' INVOKES THE USER-SUPPLIED FUNCTION 'XPRMNT' TO COMPUTE C AN EXPERIMENTAL ERROR-COMPARING VALUE. ONLY THE OUTPUT VALUES C OF THE STRAIGHT-LINE PROGRAM AT THE INITIAL DATA ARE FOUND IF C ANY OTHER THREE LETTERS APPEAR. C C THE STOPPING VALUE FOR THE MAXIMIZER. WRITTEN WITH A DECIMAL C POINT AND CONTAINED IN THE FIRST TWENTY COLUMNS OF ITS LINE. C THIS VALUE IS UNNECESSARY IF NONE OF THE SIX STANDARD ERROR- C COMPARING VALUES IS REQUESTED. C C THE SOFTWARE RETURNS: C C AN ANNOTATED LISTING OF THE USER-SUPPLIED INFORMATION, PLUS THE C ERROR-COMPARING VALUE, THE CONSTRAINT VALUES (IF ANY) AND C THE OUTPUT COMPUTED AT THE INITIAL SET OF DATA. C C A LIST OF SELECTED VALUES FOUND BY THE MAXIMIZER. C C THE FINAL SET OF DATA. C C IF INSTABILITY IS DIAGNOSED, THEN THE CONDITION NUMBER AND C ALL ARITHMETIC OPERATIONS AT THE FINAL SET OF DATA ARE LISTED. C C OTHER INFORMATION IS RETURNED IF EXCEPTIONS ARISE. C C ------------------------------------------------------------------ C C THE USER CAN AVOID THE MINICOMPILER BY SUPPLYING: C C THE NUMBER OF OPERATIONS IN THE PROGRAM BEING TESTED. GE.1 C FORMAT(I3). THE NUMBER OF OPERATIONS PLUS THE NUMBER OF DATA C ITEMS MAY NOT EXCEED 300. (INSTRUCTIONS ARE PROVIDED BELOW FOR C RAISING THE UPPER BOUND TO TEST LONGER PROGRAMS, OR LOWERING IT C TO CONSERVE STORAGE.) C C THE OPERATIONS OF THE STRAIGHT-LINE PROGRAM. FORMAT(I3,I2,I4). C THE I-TH DATA ENTRY IS ENCODED AS I, THE J-TH COMPUTED VALUE AS C 100 + J AND THE K-TH CONSTANT AS -K. THE OPERATIONS +, -, *, /, C SQRT AND UNARY MINUS ARE ENCODED AS 1-6, RESPECTIVELY. SQRT AND C UNARY MINUS REQUIRE 0 AS THEIR SECOND OPERAND. NEGATIVE CODES C ARE USED FOR ERROR-FREE OPERATIONS. C C THE NUMBER OF OUTPUTS OF THE STRAIGHT-LINE PROGRAM. C GE.1 AND LE.20. FORMAT(I2) C C THE INSTRUCTIONS AT WHICH THE OUTPUTS ARE COMPUTED. FORMAT(I3). C C THE NUMBER OF CONSTANTS. LE.20. FORMAT(I2). C C THE CONSTANTS. FORMAT(G20.16) C C THE NUMBER OF ENTRIES IN A SET OF DATA. LE.30. FORMAT(I2). C C ----------------------------------------------------------------- C C THE MAIN PROGRAM PERFORMS INPUT AND OUTPUT DUTIES. C C THE SUBPROGRAMS ARE: C C LISTOP - A ROUTINE CALLED BY THE MAIN PROGRAM TO LIST C INSTRUCTIONS OF THE TEST PROGRAM. C C MAXIM - A 'DIRECT SEARCH' NUMERICAL MAXIMIZER CALLED BY THE C MAIN PROGRAM. C C GRAM - A GRAM-SCHMIDT ROUTINE USED BY MAXIM. C C F1 - A FUNCTION CALLED BY MAXIM WHICH EVALUATES THE PENALIZED C ERROR-COMPARING VALUE. C C ROUND1 - A ROUTINE CALLED BY THE MAIN PROGRAM AND F1 TO EVALUATE C SENSITIVITY TO ERRORS. C C GETER1 - A ROUTINE CALLED BY ROUND1 IF THE USER OPTS TO TEST C ERROR RATIOS ERE,ERL. C C OMEGA1 - A ROUTINE CALLED BY ROUND1 TO EVALUATE JWE,JWL,WKE, C OR WKL. C C CONDIT - A ROUTINE CALLED BY ROUND1 TO COMPUTE THE CONDITION C NUMBER. C C SQUARE - A ROUTINE CALLED BY CONDIT AND OMEGA1 TO REDUCE A C RECTANGULAR MATRIX TO A SQUARE MATRIX. C C DIAGON - A ROUTINE CALLED BY CONDIT AND OMEGA1 TO DIAGONALIZE C A SQUARE MATRIX, I.E., TO COMPUTE ITS SINGULAR VALUES. C C XPRMNT - A USER-SUPPLIED FUNCTION TO COMPUTE EXPERIMENTAL C ERROR-COMPARING VALUES. C C POSITV - A USER-SUPPLIED ROUTINE TO EVALUATE CONSTRAINTS. C C ------------------------------------------------------------------ C COMMON VALUE(300), DERIVS(300,20), CONS(20), RHO, STOPX, * NLOP(300), NOPER(300), NROP(300), NDXOUT(20), NVARY, NVARYP, * NODES, NFIND, NPICK, NTOP, NERR(5) DOUBLE PRECISION C(30), D(30), V(300) DOUBLE PRECISION F1, AAT, BBT, ONE, RHO, ARGL, ARGR, CONS, ZERO, * STOPX, VALUE DOUBLE PRECISION CONMIN, DERIVS INTEGER CHE, CHJ, CHK, CHL, CHP, CHR, CHW, CHX, CH0, CH1, CH2, * CH3, CH4 INTEGER BLK, MNS, C1, C2, C3 EXTERNAL F1 C ------------------------------------------------------------------ C C C VALUE(I) - THE I-TH PROGRAM VALUE. DATA VALUES ARE FOLLOWED C BY INTERMEDIATE COMPUTED VALUES. THUS THE I-TH COMPUTED C VALUE IS VALUE(NVARY+I). C C DERIVS(I,J) - THE DERIVATIVE OF THE J-TH OUTPUT WRT THE I-TH C INPUT (IF I.LE.NVARY) OR WRT THE I-TH ROUNDING ERROR C (IF I.GT.NVARY). THE NORMAL SUBSCRIPT ORDER IS REVERSED TO C MAKE INNER LOOPS CHANGE THE ROW INDEX (THEREBY REDUCING TIME C ON MACHINES WITH PAGED MEMORY). C C CONS - THE CONSTANTS. C C RHO - THE ERROR-COMPARING VALUE. C C STOPX - EXECUTION STOPS IF RHO REACHES STOPX. C C NLOP(I), NOPER(I), NROP(I) - THE LEFT OPERAND, THE OPERATOR C AND THE RIGHT OPERAND OF THE I-TH INSTRUCTION. C C NDXOUT(I) - INSTRUCTION WHICH COMPUTES THE I-TH OUTPUT (NVARY C IS ADDED TO IT LATER SO IT WILL CORRESPOND TO 'VALUE'). C C NVARY - NUMBER OF VARIABLE INPUTS. C C NVARYP - NVARY + 1. C C NODES - NVARY PLUS THE NUMBER OF ARITHMETIC OPERATIONS. C C NFIND - NUMBER OF OUTPUTS. C C NPICK - PICKS THE ERROR-COMPARING VALUE. JWE,WKE,JWL,WKL,EXP, C ERE,ERL ARE CODED AS 1,2,3,4,5,-1,-3 RESPECTIVELY. C C NTOP - ZERO IF ALL OPERATIONS EXCEPT UNARY MINUS SUFFER ERRORS. C OTHERWISE IT IS THE FIRST OPERATION WITH AN ERROR. C C NERR - ERROR FLAGS. C C C - ARRAY OF CONSTRAINTS. C C D - HOLDS THE DATA VALUES INITIALLY. C C ----------------------------------------------------------------- C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C NIN = STANDARD INPUT UNIT C NOUT = STANDARD OUTPUT UNIT DATA NIN /5/, NOUT /6/, ZERO /0.0D0/, ONE /1.0D0/ C DATA CHE, CHJ, CHK, CHL, CHP, CHR, CHW, CHX /1HE,1HJ,1HK,1HL,1HP, * 1HR,1HW,1HX/ DATA CH0, CH1, CH2, CH3, CH4, BLK, MNS /1H0,1H1,1H2,1H3,1H4,1H , * 1H-/ C C READ THE STRAIGHT-LINE PROGRAM. READ (NIN,99999) NOP C C ------------------------------------------------------------------ C C TO TEST PROGRAMS WITH NODES.GT.300, JUST (1) CHANGE THE 'COMMON' C DECLARATIONS, HERE AND IN SUBROUTINES F1,ROUND1,GETER1,OMEGA1 AND C CONDIT (2) REDIMENSION ARRAYS WGTLFT AND WGTRGT IN SUBROUTINE ROUND1 C AND (3) MAKE THE APPROPRIATE CHANGE IN THE NEXT CARD AND A LATER C TEST ON NODES WHICH OCCURS ABOUT 100 LINES FURTHER ON. IF ((NOP.LE.0) .OR. (NOP.GT.300)) GO TO 280 C C ------------------------------------------------------------------ C WRITE (NOUT,99998) NTOP = 0 MINUS1 = -1 C NTOP = MINUS1 MEANS THAT ONLY ERROR-FREE OPERATIONS HAVE BEEN SEEN C SO FAR. DO 10 I=1,NOP READ (NIN,99997) NLOP(I), NOPER(I), NROP(I) IIOPER = NOPER(I) IF (I.EQ.1 .AND. IIOPER.LT.0) NTOP = MINUS1 IF (NTOP.EQ.MINUS1 .AND. IIOPER.GT.0) NTOP = I IF (NTOP.EQ.0 .AND. I.GT.1 .AND. IIOPER.LT.0) NTOP = 1 10 CONTINUE C C READ THE LOCATIONS OF THE OUTPUTS. READ (NIN,99996) NFIND IF (NFIND.LE.0) GO TO 310 DO 20 I=1,NFIND READ (NIN,99999) NDXOUT(I) 20 CONTINUE C C READ AND WRITE THE CONSTANTS. READ (NIN,99996) NFIX IF ((NFIX.LT.0) .OR. (NFIX.GT.20)) GO TO 290 IF (NFIX.EQ.0) GO TO 40 WRITE (NOUT,99995) DO 30 I=1,NFIX READ (NIN,99994) CONS(I) WRITE (NOUT,99993) I, CONS(I) 30 CONTINUE 40 READ (NIN,99996) NVARY C C CHECK AND LIST THE STRAIGHT-LINE PROGRAM. WRITE (NOUT,99992) MFIX = -NFIX DO 50 I=1,NOP MLOP = NLOP(I) IIOPER = NOPER(I) MOPER = IABS(IIOPER) MROP = NROP(I) II = I + 100 IF ((MLOP.LT.MFIX) .OR. (MLOP.EQ.0) .OR. (MLOP.GE.II)) GO TO 300 IF ((MLOP.GT.NVARY) .AND. (MLOP.LE.100)) GO TO 300 IF ((MOPER.LE.0) .OR. (MOPER.GE.7)) GO TO 300 IF ((MOPER.LE.4) .AND. (MROP.EQ.0)) GO TO 300 IF ((MOPER.GE.5) .AND. (MROP.NE.0)) GO TO 300 IF ((MROP.LT.MFIX) .OR. (MROP.GT.II)) GO TO 300 IF ((MROP.GT.NVARY) .AND. (MROP.LE.100)) GO TO 300 CALL LISTOP(I, MLOP, IIOPER, MROP) 50 CONTINUE C C CHECK AND LIST THE LOCATIONS OF THE OUTPUT. IF ((NFIND.LE.0) .OR. (NFIND.GT.20)) GO TO 310 WRITE (NOUT,99991) NFIND DO 60 I=1,NFIND MDXOUT = NDXOUT(I) WRITE (NOUT,99990) MDXOUT IF ((MDXOUT.LE.0) .OR. (MDXOUT.GT.NOP)) GO TO 320 60 CONTINUE C C READ AND LIST THE INITIAL DATA. IF ((NVARY.LE.0) .OR. (NVARY.GT.30)) GO TO 330 WRITE (NOUT,99989) DO 70 I=1,NVARY READ (NIN,99994) D(I) WRITE (NOUT,99988) I, D(I) 70 CONTINUE C C SEE WHICH ERROR-COMPARING VALUE IS TO BE MAXIMIZED. READ (NIN,99987) C1, C2, C3 NPICK = 0 IF (C1.EQ.CHJ .AND. C2.EQ.CHW .AND. C3.EQ.CHE) NPICK = 1 IF (C1.EQ.CHW .AND. C2.EQ.CHK .AND. C3.EQ.CHE) NPICK = 2 IF (C1.EQ.CHJ .AND. C2.EQ.CHW .AND. C3.EQ.CHL) NPICK = 3 IF (C1.EQ.CHW .AND. C2.EQ.CHK .AND. C3.EQ.CHL) NPICK = 4 IF (C1.EQ.CHE .AND. C2.EQ.CHR .AND. C3.EQ.CHE) NPICK = -1 IF (C1.EQ.CHE .AND. C2.EQ.CHR .AND. C3.EQ.CHL) NPICK = -3 IF (C1.EQ.CHE .AND. C2.EQ.CHX .AND. C3.EQ.CHP) NPICK = 5 IF (NPICK.NE.0 .OR. C3.NE.BLK) GO TO 80 IF (C1.NE.BLK .AND. C1.NE.MNS .AND. C1.NE.CH0) GO TO 80 C NUMERICAL CODES ARE PERMITTED FOR COMPATIBILITY WITH EARLIER C VERSIONS OF THIS SOFTWARE (TOMS, DEC. 1978). IF (C2.EQ.CH1) NPICK = 1 IF (C2.EQ.CH2) NPICK = 2 IF (C2.EQ.CH3) NPICK = 3 IF (C2.EQ.CH4) NPICK = 4 IF (C1.EQ.MNS) NPICK = -NPICK 80 IF (NPICK.NE.0) WRITE (NOUT,99986) C1, C2, C3 IF (NPICK.EQ.0) WRITE (NOUT,99985) C C RECODE OPERATION K AS THE INTEGER NVARY+K BY ADJUSTING C POINTERS TO PROGRAM OPERANDS AND OUTPUT POINTERS. NVARYP = NVARY + 1 NODES = NVARY + NOP IF (NTOP.GT.0) NTOP = NTOP + NVARY C ------------------------------------------ TEST ON NODES ------ IF (NODES.GT.300) GO TO 280 C ---------------------------------------------------------------- NOPP = NOP + 1 NSHIFT = 100 - NVARY DO 90 J=1,NOP IF (NLOP(J).GT.100) NLOP(J) = NLOP(J) - NSHIFT IF (NROP(J).GT.100) NROP(J) = NROP(J) - NSHIFT 90 CONTINUE DO 100 J=1,NOP I = NOPP - J C I = NOP,...,2,1 IPNV = I + NVARY NLOP(IPNV) = NLOP(I) NOPER(IPNV) = NOPER(I) NROP(IPNV) = NROP(I) 100 CONTINUE DO 110 I=1,NFIND NDXOUT(I) = NDXOUT(I) + NVARY 110 CONTINUE C SET UP THE DATA VALUES. DO 120 I=1,NVARY VALUE(I) = D(I) 120 CONTINUE C ZERO THE ERROR FLAGS. DO 130 I=1,5 NERR(I) = 0 130 CONTINUE C C COMPUTE AND LIST THE ERROR-COMPARING VALUE, THE CONSTRAINT VALUES C (IF ANY) AND THE OUTPUT AT THE INITIAL DATA. CALL ROUND1 IF (NPICK.EQ.0) GO TO 170 WRITE (NOUT,99984) RHO CALL POSITV(C, D, VALUE(NVARYP), NUMBER) CONMIN = ONE IF (NUMBER.LE.0) GO TO 160 WRITE (NOUT,99983) DO 150 I=1,NUMBER WRITE (NOUT,99982) I, C(I) IF (C(I).LT.CONMIN) CONMIN = C(I) 150 CONTINUE GO TO 170 160 WRITE (NOUT,99981) 170 WRITE (NOUT,99980) DO 180 I=1,NFIND NDX = NDXOUT(I) NDXM = NDX - NVARY WRITE (NOUT,99979) NDXM, VALUE(NDX) 180 CONTINUE IF (NPICK.EQ.0) GO TO 270 IF (CONMIN.LE.ZERO) GO TO 260 READ (NIN,99994) STOPX WRITE (NOUT,99978) STOPX IF (RHO.GE.STOPX) GO TO 220 C C MAXIMIZE. WRITE (NOUT,99977) JVARY = NVARY CALL MAXIM(F1, D, JVARY) DO 190 I=1,NVARY D(I) = VALUE(I) 190 CONTINUE WRITE (NOUT,99976) DO 210 I=1,NVARY WRITE (NOUT,99988) I, D(I) 210 CONTINUE IF (RHO.LT.STOPX) GO TO 260 220 NPICK = 6 CALL ROUND1 WRITE (NOUT,99962) RHO CALL POSITV(C, D, VALUE(NVARYP), NUMBER) IF (NUMBER.LE.0) GO TO 240 WRITE (NOUT,99975) DO 230 I=1,NUMBER WRITE (NOUT,99982) I, C(I) 230 CONTINUE 240 WRITE (NOUT,99974) DO 250 I=NVARYP,NODES ISHIFT = I - NVARY ILOP = NLOP(I) IIOPER = NOPER(I) IOPER = IABS(IIOPER) IROP = NROP(I) MILOP = -ILOP IF (ILOP.LT.0) ARGL = CONS(MILOP) IF (ILOP.GT.0) ARGL = VALUE(ILOP) IF (IOPER.EQ.5) WRITE (NOUT,99969) ISHIFT, VALUE(I), ARGL IF (IOPER.EQ.6) WRITE (NOUT,99968) ISHIFT, VALUE(I), ARGL IF (IOPER.GE.5) GO TO 250 MIROP = -IROP IF (IROP.LT.0) ARGR = CONS(MIROP) IF (IROP.GT.0) ARGR = VALUE(IROP) IF (IOPER.EQ.1) WRITE (NOUT,99973) ISHIFT, VALUE(I), ARGL, ARGR IF (IOPER.EQ.2) WRITE (NOUT,99972) ISHIFT, VALUE(I), ARGL, ARGR IF (IOPER.EQ.3) WRITE (NOUT,99971) ISHIFT, VALUE(I), ARGL, ARGR IF (IOPER.EQ.4) WRITE (NOUT,99970) ISHIFT, VALUE(I), ARGL, ARGR 250 CONTINUE C C LIST EXCEPTIONS. 260 IF (NERR(1).GT.0) WRITE (NOUT,99967) NERR(1) IF (NERR(2).GT.0) WRITE (NOUT,99966) NERR(2) IF (NERR(3).GT.0) WRITE (NOUT,99965) NERR(3) IF (NERR(4).GT.0) WRITE (NOUT,99964) NERR(4) IF (NERR(5).GT.0) WRITE (NOUT,99963) NERR(5) 270 WRITE (NOUT,99961) STOP C C MESSAGES FOR DATA ERRORS. 280 WRITE (NOUT,99960) GO TO 340 290 WRITE (NOUT,99959) GO TO 340 300 WRITE (NOUT,99958) GO TO 340 310 WRITE (NOUT,99957) GO TO 340 320 WRITE (NOUT,99956) GO TO 340 330 WRITE (NOUT,99955) 340 WRITE (NOUT,99954) GO TO 270 99999 FORMAT (I3) 99998 FORMAT (1H1, 9X, 27HSTRAIGHT-LINE PROGRAM CODE.//10X, 9HD(I) DENO, * 31HTES THE I-TH ENTRY OF THE DATA.) 99997 FORMAT (I3, I2, I4) 99996 FORMAT (I2) 99995 FORMAT (//10X, 31HA(I) DENOTES THE I-TH CONSTANT.) 99994 FORMAT (G20.16) 99993 FORMAT (13X, 2HA(, I2, 3H) =, G16.8) 99992 FORMAT (//10X, 41HV(I) DENOTES THE I-TH INTERMEDIATE VALUE.) 99991 FORMAT (//10X, 3HTHE, I3, 12H OUTPUTS ARE) 99990 FORMAT (13X, 2HV(, I3, 1H)) 99989 FORMAT (///10X, 16HTHE INITIAL DATA) 99988 FORMAT (13X, 2HD(, I3, 3H) =, G16.8) 99987 FORMAT (3A1) 99986 FORMAT (///10X, 36HTHE CHOSEN ERROR-COMPARING VALUE IS , 3A1) 99985 FORMAT (///10X, 36HNO ERROR-COMPARING VALUE IS COMPUTED) 99984 FORMAT (///10X, 46HAT THE INITIAL DATA THE ERROR-COMPARING VALUE , * 7HEQUALS /20X, G12.4) 99983 FORMAT (///10X, 35HTHE CONSTRAINTS AT THE INITIAL DATA) 99982 FORMAT (13X, 2HC(, I2, 3H) =, G16.8) 99981 FORMAT (///10X, 25HTHERE ARE NO CONSTRAINTS.) 99980 FORMAT (///10X, 30HTHE OUTPUT AT THE INITIAL DATA) 99979 FORMAT (13X, 2HV(, I3, 3H) =, G16.8) 99978 FORMAT (///10X, 22HTHE STOPPING VALUE IS , G11.4) 99977 FORMAT (/10X, 20HAPPLY THE MAXIMIZER.) 99976 FORMAT (///10X, 21HTHE FINAL SET OF DATA) 99975 FORMAT (///10X, 24HHERE THE CONSTRAINTS ARE) 99974 FORMAT (///10X, 25HTHE FINAL COMPUTED VALUES) 99973 FORMAT (13X, 2HV(, I3, 1H), D20.8, 4H = , D16.8, 2H +, D16.8) 99972 FORMAT (13X, 2HV(, I3, 1H), D20.8, 4H = , D16.8, 2H -, D16.8) 99971 FORMAT (13X, 2HV(, I3, 1H), D20.8, 4H = , D16.8, 2H *, D16.8) 99970 FORMAT (13X, 2HV(, I3, 1H), D20.8, 4H = , D16.8, 2H /, D16.8) 99969 FORMAT (13X, 2HV(, I3, 1H), D20.8, 3H =, 15X, 4HSQRT, D16.8) 99968 FORMAT (13X, 2HV(, I3, 1H), D20.8, 3H =, 18X, 1H-, D16.8) 99967 FORMAT (/I10, 28H ATTEMPTED DIVISIONS BY ZERO) 99966 FORMAT (/I10, 26H ATTEMPTED SQRT(V), V.LT.0) 99965 FORMAT (/I10, 16H GETER1 FAILURES) 99964 FORMAT (/I10, 16H OMEGA1 FAILURES) 99963 FORMAT (/I10, 16H DIAGON FAILURES) 99962 FORMAT (/10X, 23HTHE CONDITION NUMBER IS, G16.8) 99961 FORMAT (/40X, 35H ROUNDOFF ANALYZER VERSION 07/01/79) 99960 FORMAT (51H NUMBER OF INPUTS AND CONSTANTS MAY NOT EXCEED 300.) 99959 FORMAT (39H NUMBER OF CONSTANTS MAY NOT EXCEED 20.) 99958 FORMAT (33H INCORRECT CODE FOR AN OPERATION.) 99957 FORMAT (37H NUMBER OF OUTPUTS MAY NOT EXCEED 20.) 99956 FORMAT (25H IMPOSSIBLE OUTPUT INDEX.) 99955 FORMAT (36H NUMBER OF INPUTS MAY NOT EXCEED 30.) 99954 FORMAT (44H EXECUTION TERMINATED BECAUSE OF DATA ERROR.) END DOUBLE PRECISION FUNCTION F1(D, IERR) C C COMPUTE THE PENALIZED ERROR-COMPARING VALUE AT THE CURRENT DATA X. C THE UNPENALIZED VALUE IS LISTED AT INTERVALS OF 5*NVARY (SO LONG AS C THE CONSTRAINTS ARE SATISFIED). THE SEARCH IS TERMINATED (BY C SETTING IERR TO 1) AFTER 50*NVARY EVALUATIONS. C COMMON VALUE(300), DERIVS(300,20), CONS(20), RHO, STOPX, * NLOP(300), NOPER(300), NROP(300), NDXOUT(20), NVARY, NVARYP, * NODES, NFIND, NPICK, NTOP, NERR(5) DOUBLE PRECISION C(30), D(30) DOUBLE PRECISION ONE, CONS, RHO, ZERO, STOPX, VALUE, DERIVS DOUBLE PRECISION PENLTY DATA NCALLS /0/, NPRINT /0/ C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. DATA NOUT /6/, ONE /1.0D0/, ZERO /0.0D0/ C C COMPUTE THE UNPENALIZED ERROR-COMPARING VALUE. DO 10 I=1,NVARY VALUE(I) = D(I) 10 CONTINUE CALL ROUND1 NCALLS = NCALLS + 1 C C THE CONSTRAINTS ARE THAT C(I) BE POSITIVE, 1.LE.I.LE.NUMBER. CALL POSITV(C, D, VALUE(NVARYP), NUMBER) C C COMPUTE PENALTY = MIN (1, MIN C(I)). PENLTY = ONE IF (NUMBER.LE.0) GO TO 40 DO 30 I=1,NUMBER IF (C(I).LT.PENLTY) PENLTY = C(I) 30 CONTINUE 40 F1 = PENLTY*RHO IF ((RHO.GT.STOPX) .AND. (PENLTY.GT.ZERO)) GO TO 80 C C NORMAL RETURN (THE SEARCH FOR INSTABILITY MAY BE CALLED OFF). IERR = 0 IF (PENLTY.LE.ZERO) GO TO 60 LISTX = 5*NVARY IF ((NCALLS/LISTX)*LISTX.NE.NCALLS) GO TO 60 IF (NPRINT.EQ.1) GO TO 50 WRITE (NOUT,99999) NPRINT = 1 50 WRITE (NOUT,99998) NCALLS, RHO 60 IF (NCALLS.GE.50*NVARY) IERR = 1 70 RETURN C C RHO PUSHED ABOVE STOPX. C SETTING IERR TO 1 FORCES THE MAXIMIZER TO TERMINATE. 80 WRITE (NOUT,99997) NCALLS, RHO IERR = 1 GO TO 70 99999 FORMAT (/10X, 48HCOLUMN 1 GIVES THE NUMBER OF EVALUATIONS OF THE , * 22HERROR-COMPARING VALUE./10X, 30HCOLUMN 2 GIVES THE CURRENT ERR, * 19HOR-COMPARING VALUE.) 99998 FORMAT (I15, G15.4) 99997 FORMAT (///10X, 20HINSTABILITY LOCATED./10X, 5HAFTER, I5, * 45H EVALUATIONS THE ERROR-COMPARING VALUE EQUALS/20X, G11.4) END SUBROUTINE GETER1 C C THIS SUBROUTINE COMPUTES ERROR RATIOS ERE,ERL AS RHO = TOP/BOTTOM, C WHERE TOP = (INFINITY NORM OF DERIVATIVE OF RESULT WRT ROUNDING C ERRORS) AND BOTTOM = (INFINITY NORM OF DERIVATIVE OF RESULT WRT THE C APPROPRIATE PERTURBATIONS). TWO OTHER RATIOS ARE ALSO COMPUTED TO C MAINTAIN COMPATIBILITY WITH EARLIER VERSIONS OF THIS SOFTWARE. C COMMON VALUE(300), DERIVS(300,20), CONS(20), RHO, STOPX, * NLOP(300), NOPER(300), NROP(300), NDXOUT(20), NVARY, NVARYP, * NODES, NFIND, NPICK, NTOP, NERR(5) DOUBLE PRECISION T, RHO, SUM, TOP, CONS, ZERO, DNORM, VNORM, STOPX DOUBLE PRECISION VALUE, BOTTOM, DERIVS DOUBLE PRECISION DABS C C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C ALSO CHANGE 'DABS'. DATA ZERO /0.0D0/ C MPICK = -NPICK C C GET NORM OF DATA, IF NEEDED. IF (MPICK.LE.2) GO TO 20 DNORM = ZERO DO 10 I=1,NVARY T = DABS(VALUE(I)) IF (T.GT.DNORM) DNORM = T 10 CONTINUE C 20 TOP = ZERO DO 40 I=1,NFIND LIM = NDXOUT(I) SUM = ZERO DO 30 K=NVARYP,LIM SUM = SUM + DABS(DERIVS(K,I)) 30 CONTINUE IF (SUM.GT.TOP) TOP = SUM 40 CONTINUE C BOTTOM = ZERO GO TO (50, 80, 110, 140), MPICK C ERE. 50 DO 70 I=1,NFIND SUM = ZERO DO 60 K=1,NVARY SUM = SUM + DABS(DERIVS(K,I)*VALUE(K)) 60 CONTINUE IF (SUM.GT.BOTTOM) BOTTOM = SUM 70 CONTINUE GO TO 170 C RHO2. 80 DO 100 I=1,NFIND SUM = ZERO DO 90 K=1,NVARY SUM = SUM + DABS(DERIVS(K,I)*VALUE(K)) 90 CONTINUE IOUT = NDXOUT(I) SUM = SUM + DABS(VALUE(IOUT)) IF (SUM.GT.BOTTOM) BOTTOM = SUM 100 CONTINUE GO TO 170 C ERL. 110 DO 130 I=1,NFIND SUM = ZERO DO 120 K=1,NVARY SUM = SUM + DABS(DERIVS(K,I)) 120 CONTINUE SUM = SUM*DNORM IF (SUM.GT.BOTTOM) BOTTOM = SUM 130 CONTINUE GO TO 170 C RHO4. 140 VNORM = ZERO DO 160 I=1,NFIND SUM = ZERO DO 150 K=1,NVARY SUM = SUM + DABS(DERIVS(K,I)) 150 CONTINUE SUM = SUM*DNORM IF (SUM.GT.BOTTOM) BOTTOM = SUM IOUT = NDXOUT(I) T = DABS(VALUE(IOUT)) IF (T.GT.VNORM) VNORM = T 160 CONTINUE BOTTOM = BOTTOM + VNORM 170 IF (BOTTOM.EQ.ZERO) GO TO 190 RHO = TOP/BOTTOM 180 RETURN 190 RHO = ZERO NERR(3) = NERR(3) + 1 GO TO 180 END SUBROUTINE GRAM(S, N, NDIM, IERR) C APPLIES THE MODIFIED GRAM-SCHMIDT METHOD TO THE FIRST N C COLUMNS OF S (AS N-VECTORS). DOUBLE PRECISION S(NDIM,NDIM) DOUBLE PRECISION SUM, ZERO DOUBLE PRECISION DSQRT C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C ALSO CHANGE 'DSQRT'. DATA NOUT /6/, ZERO /0.0D0/ C DO 60 J=1,N SUM = ZERO DO 10 I=1,N SUM = SUM + S(I,J)**2 10 CONTINUE IF (SUM.EQ.ZERO) GO TO 80 SUM = DSQRT(SUM) DO 20 I=1,N S(I,J) = S(I,J)/SUM 20 CONTINUE IF (J.EQ.N) GO TO 60 JP = J + 1 DO 50 K=JP,N SUM = ZERO DO 30 I=1,N SUM = SUM + S(I,J)*S(I,K) 30 CONTINUE DO 40 I=1,N S(I,K) = S(I,K) - SUM*S(I,J) 40 CONTINUE 50 CONTINUE 60 CONTINUE IERR = 0 70 RETURN C 80 WRITE (NOUT,99999) IERR = 1 GO TO 70 99999 FORMAT (47H RANK DEFICIENCY IN SUBROUTINE GRAM. TERMINATE.) END SUBROUTINE LISTOP(I, MLOP, IIOPER, MROP) INTEGER PLUS, MINUS, STAR, SLASH, A, D, V, LEFT, OP, RIGHT DATA PLUS, MINUS, STAR, SLASH, A, D, V, NOUT /1H+,1H-,1H*,1H/,1HA, * 1HD,1HV,6/ C MOPER = IABS(IIOPER) C GET THE LEFT OPERAND. IF (MLOP.LT.0) LEFT = A IF (MLOP.LT.0) LISTL = -MLOP IF ((MLOP.GT.0) .AND. (MLOP.LE.100)) LEFT = D IF ((MLOP.GT.0) .AND. (MLOP.LE.100)) LISTL = MLOP IF (MLOP.GT.100) LEFT = V IF (MLOP.GT.100) LISTL = MLOP - 100 IF (IIOPER.GE.5) GO TO 20 MINUS5 = -5 IF (IIOPER.LE.MINUS5) GO TO 40 C C GET THE OPERATOR. IF (MOPER.EQ.1) OP = PLUS IF (MOPER.EQ.2) OP = MINUS IF (MOPER.EQ.3) OP = STAR IF (MOPER.EQ.4) OP = SLASH C C GET THE RIGHT OPERAND. IF (MROP.LT.0) RIGHT = A IF (MROP.LT.0) LISTR = -MROP IF ((MROP.GT.0) .AND. (MROP.LE.100)) RIGHT = D IF ((MROP.GT.0) .AND. (MROP.LE.100)) LISTR = MROP IF (MROP.GT.100) RIGHT = V IF (MROP.GT.100) LISTR = MROP - 100 C C LIST THE OPERATION. IF (IIOPER.LT.0) GO TO 30 WRITE (NOUT,99999) I, LEFT, LISTL, OP, RIGHT, LISTR 10 RETURN 20 IF (MOPER.EQ.5) WRITE (NOUT,99998) I, LEFT, LISTL IF (MOPER.EQ.6) WRITE (NOUT,99997) I, LEFT, LISTL GO TO 10 30 WRITE (NOUT,99996) I, LEFT, LISTL, OP, RIGHT, LISTR GO TO 10 40 IF (MOPER.EQ.5) WRITE (NOUT,99995) I, LEFT, LISTL IF (MOPER.EQ.6) WRITE (NOUT,99994) I, LEFT, LISTL GO TO 10 99999 FORMAT (13X, 2HV(, I3, 4H) = , A1, 1H(, I3, 2H) , A1, 1H , A1, * 1H(, I3, 1H)) 99998 FORMAT (13X, 2HV(, I3, 13H) = SQRT , A1, 1H(, I3, 1H)) 99997 FORMAT (13X, 2HV(, I3, 13H) = - , A1, 1H(, I3, 1H)) 99996 FORMAT (13X, 2HV(, I3, 4H) = , A1, 1H(, I3, 2H) , A1, 1H , A1, * 1H(, I3, 1H), 15H ERROR-FREE) 99995 FORMAT (13X, 2HV(, I3, 13H) = SQRT , A1, 1H(, I3, 1H), * 15H ERROR-FREE) 99994 FORMAT (13X, 2HV(, I3, 13H) = - , A1, 1H(, I3, 1H), * 15H ERROR-FREE) END SUBROUTINE MAXIM(F, D, NVARY) C A VARIANT OF ROSENBROCK'S METHOD, PP. 21-22 OF 'NUMERICAL C METHODS FOR UNCONSTRAINED OPTIMIZATION', W. MURRAY,ED. C ACADEMIC PRESS, 1972. INTEGER NITER(2) DOUBLE PRECISION P(30,30), DEL(30), EPS(2), DOLD(30) DOUBLE PRECISION D(30), DSAVE(30), BIGDEL(30) DOUBLE PRECISION B, F, ONE, RHO, BETA, DELI, SIZE, ZERO, ALPHA, * DELTA DOUBLE PRECISION DNORM, CHANGE, RHOSAV, THEMIN, DABSBD DOUBLE PRECISION DABS C C P'S COLUMNS ARE THE SEARCH DIRECTIONS. C DOLD STORES THE POSITION OF D AFTER THE MOST RECENT ROTATION. C DSAVE IS THE SAVE AREA FOR D WHEN A STEP IS TRIED. C DEL(I) IS THE STEP LENGTH IN THE I-TH DIRECTION. C BIGDEL(I) IS THE ALGEBRAIC SUM OF ALL SUCCESSFUL STEPS IN THE I-TH C DIRECTION. C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C ALSO CHANGE 'DABS'. DATA ALPHA /3.0D0/, BETA /-0.5D0/, CHANGE /20.0D0/, EPS(1) * /0.03D0/, EPS(2) /0.001D0/, ONE /1.0D0/, ZERO /0.0D0/, NITER(1) * /5/, NITER(2) /9/, NFLAG /1/, NOUT /6/ C C INITIALIZE THE SEARCH DIRECTIONS TO THE COORDINATE AXES. DO 20 I=1,NVARY DO 10 J=1,NVARY P(I,J) = ZERO 10 CONTINUE P(I,I) = ONE 20 CONTINUE RHO = F(D,IERR) IF (IERR.EQ.1) GO TO 150 C C NROT-1 IS THE CURRENT NUMBER OF ROTATIONS OF THE SEARCH DIRECTIONS. C THE SEARCH PROCEDURE IS REFINED IF RHO .GT. CHANGE. DO 140 NROT=1,10 IF (RHO.GT.CHANGE) NFLAG = 2 DNORM = ZERO DO 30 I=1,NVARY SIZE = DABS(D(I)) IF (SIZE.GT.DNORM) DNORM = SIZE DOLD(I) = D(I) 30 CONTINUE DELTA = EPS(NFLAG)*DNORM DO 40 I=1,NVARY BIGDEL(I) = ZERO DEL(I) = DELTA 40 CONTINUE NTIMES = NITER(NFLAG) DO 90 ITER=1,NTIMES DO 80 I=1,NVARY DELI = DEL(I) RHOSAV = RHO DO 50 K=1,NVARY DSAVE(K) = D(K) D(K) = D(K) + DELI*P(K,I) 50 CONTINUE RHO = F(D,IERR) IF (IERR.EQ.1) GO TO 150 IF (RHO.GT.RHOSAV) GO TO 70 C C SEARCH WAS UNSUCCESSFUL. DEL(I) = BETA*DELI DO 60 K=1,NVARY D(K) = DSAVE(K) 60 CONTINUE RHO = RHOSAV GO TO 80 C C SEARCH WAS SUCCESSFUL. 70 BIGDEL(I) = BIGDEL(I) + DELI DEL(I) = ALPHA*DELI 80 CONTINUE 90 CONTINUE IF (NROT.EQ.10) GO TO 150 IF (NVARY.EQ.1) GO TO 140 C C ROTATE THE SEARCH DIRECTIONS. C GUARANTEE SOME CHANGE IN EACH DIRECTION. IF INSUFFICIENT PROGRESS C IS MADE, THEN TERMINATE THE SEARCH. THEMIN = EPS(NFLAG)*DELTA MOVE = 0 DO 100 I=1,NVARY DABSBD = DABS(BIGDEL(I)) IF (DABSBD.GT.THEMIN) MOVE = 1 IF (DABSBD.LE.THEMIN) BIGDEL(I) = THEMIN 100 CONTINUE IF (MOVE.EQ.0) GO TO 160 C C SET THE J-TH COLUMN OF P TO THE SUM OF THE SUCCESSFUL STEPS IN THE C OLD DIRECTIONS J, J-1,..., NVARY. SINCE THE OLD DIRECTIONS ARE C ORTHOGONAL AND SINCE THE BIGDELS ARE NONZERO, THE NEW COLUMNS ARE C LINEARLY INDEPENDENT. B = BIGDEL(NVARY) DO 110 I=1,NVARY P(I,NVARY) = B*P(I,NVARY) 110 CONTINUE NM1 = NVARY - 1 DO 130 JBACK=1,NM1 J = NVARY - JBACK B = BIGDEL(J) DO 120 I=1,NVARY P(I,J) = B*P(I,J) + P(I,J+1) 120 CONTINUE 130 CONTINUE C C ORTHOGONALIZE. THE J-TH COLUMN OF P IS THE MOST PROFITABLE C SEARCH DIRECTION ORTHOGONAL TO COLUMNS 1, 2,..., J-1. CALL GRAM(P, NVARY, 30, IERR) IF (IERR.EQ.1) GO TO 160 140 CONTINUE 150 RETURN C 160 WRITE (NOUT,99999) GO TO 150 99999 FORMAT (/10X, 35HINSUFFICIENT PROGRESS. SEARCH ENDS.) END SUBROUTINE ROUND1 C THIS SUBROUTINE FINDS THE INTERMEDIATE COMPUTED VALUES PLUS THEIR C PARTIAL DERIVATIVES WITH RESPECT TO THEIR ARGUMENTS. A METHOD DUE C TO LARSON AND SAMEH (EFFICIENT CALCULATION OF THE EFFECTS OF C ROUNDING ERRORS, TOMS 4 (1978), PP. 228-236), IS C APPLIED TO COMPUTE DERIVS(I,J), THE PARTIAL DERIVATIVE OF THE J-TH C OUTPUT WRT THE I-TH PROGRAM VALUE. IN STATEMENT 100 DERIVS IS C MODIFIED TO BE THE DERIVATIVE WRT THE I-TH ROUNDING ERROR. C COMMON VALUE(300), DERIVS(300,20), CONS(20), RHO, STOPX, * NLOP(300), NOPER(300), NROP(300), NDXOUT(20), NVARY, NVARYP, * NODES, NFIND, NPICK, NTOP, NERR(5) DIMENSION WGTLFT(300), WGTRGT(300) DOUBLE PRECISION DIJ, ONE, RHO, ARGL, ARGR, CONS, HALF, ZERO, * STOPX, VALUE, DERIVS, WGTLFT, WGTRGT, XPRMNT DOUBLE PRECISION DSQRT DATA ONE /1.0D0/, HALF /0.5D0/, ZERO /0.0D0/ C DO 80 I=NVARYP,NODES C COMPUTE THE I-TH VALUE AND ITS INPUT ARC WEIGHTS. ILOP = NLOP(I) MILOP = -ILOP IF (ILOP.LT.0) ARGL = CONS(MILOP) IF (ILOP.GT.0) ARGL = VALUE(ILOP) IIOPER = NOPER(I) IOPER = IABS(IIOPER) IF (IOPER.GT.4) GO TO 10 IROP = NROP(I) MIROP = -IROP IF (IROP.LT.0) ARGR = CONS(MIROP) IF (IROP.GT.0) ARGR = VALUE(IROP) 10 GO TO (20, 30, 40, 50, 60, 70), IOPER C ADDITION 20 VALUE(I) = ARGL + ARGR WGTLFT(I) = ONE WGTRGT(I) = ONE GO TO 80 C SUBTRACTION 30 VALUE(I) = ARGL - ARGR WGTLFT(I) = ONE WGTRGT(I) = -ONE GO TO 80 C MULTIPLICATION 40 VALUE(I) = ARGL*ARGR WGTLFT(I) = ARGR WGTRGT(I) = ARGL GO TO 80 C DIVISION 50 IF (ARGR.EQ.ZERO) GO TO 190 VALUE(I) = ARGL/ARGR WGTLFT(I) = ONE/ARGR WGTRGT(I) = -VALUE(I)/ARGR GO TO 80 C SQUARE ROOT 60 IF (ARGL.LE.ZERO) GO TO 200 VALUE(I) = DSQRT(ARGL) WGTLFT(I) = HALF/VALUE(I) GO TO 80 C UNARY MINUS 70 VALUE(I) = -ARGL WGTLFT(I) = -ONE 80 CONTINUE C IF (NPICK.EQ.0) GO TO 180 C COMPUTE THE PARTIAL DERIVATIVES. DO 120 J=1,NFIND JOUT = NDXOUT(J) DO 90 I=1,JOUT DERIVS(I,J) = ZERO 90 CONTINUE DERIVS(JOUT,J) = ONE JOUTP = JOUT + 1 LIM = JOUT - NVARY DO 110 IBACK=1,LIM I = JOUTP - IBACK C I = NDXOUT(J), NDXOUT(J)-1, ..., NVARY + 1 DIJ = DERIVS(I,J) IF (DIJ.EQ.ZERO) GO TO 110 ILOP = NLOP(I) IF (ILOP.GT.0) DERIVS(ILOP,J) = DERIVS(ILOP,J) + WGTLFT(I)*DIJ IIOPER = NOPER(I) IOPER = IABS(IIOPER) IF (IOPER.GT.4) GO TO 100 IROP = NROP(I) IF (IROP.GT.0) DERIVS(IROP,J) = DERIVS(IROP,J) + WGTRGT(I)*DIJ 100 DERIVS(I,J) = DIJ*VALUE(I) C UNARY MINUS OPERATIONS ARE CONSIDERED ERROR-FREE. IF (IOPER.EQ.6) DERIVS(I,J) = ZERO 110 CONTINUE 120 CONTINUE IF (NTOP.EQ.0) GO TO 170 C IF SOME OPERATIONS ARE TO BE CONSIDERED ERROR-FREE, THEN C RECOMPUTE DERIVATIVES WRT THEM, IGNORING PATHS THROUGH NODES C WITH ERRORS. C IF NTOP = -1, THEN ALL NODES ARE ERROR-FREE. MINUS1 = -1 DO 160 J=1,NFIND JOUT = NDXOUT(J) DO 130 I=NVARYP,JOUT DERIVS(I,J) = ZERO 130 CONTINUE IF (NTOP.EQ.MINUS1) GO TO 160 DERIVS(JOUT,J) = ONE JOUTP = JOUT + 1 LIM = JOUT - NTOP DO 150 IBACK=1,LIM I = JOUTP - IBACK C I = NDXOUT(J), NDXOUT(J)-1, ..., NTOP + 1 IIOPER = NOPER(I) C IF THE CURRENT NODE HAS AN ERROR, DON'T UPDATE C THE SPP'S OF ITS OPERANDS. DIJ = DERIVS(I,J) IF (IIOPER.GT.0) DERIVS(I,J) = DIJ*VALUE(I) IF (IIOPER.GT.0 .OR. DIJ.EQ.ZERO) GO TO 150 ILOP = NLOP(I) IF (ILOP.GE.NTOP) DERIVS(ILOP,J) = DERIVS(ILOP,J) + * WGTLFT(I)*DIJ IOPER = IABS(IIOPER) IF (IOPER.GT.4) GO TO 140 IROP = NROP(I) IF (IROP.GE.NTOP) DERIVS(IROP,J) = DERIVS(IROP,J) + * WGTRGT(I)*DIJ C THIS NODE IS TO BE CONSIDERED ERROR-FREE. 140 DERIVS(I,J) = ZERO 150 CONTINUE 160 CONTINUE 170 IF (NPICK.EQ.5) RHO = XPRMNT(DERIVS,VALUE,NDXOUT,NVARY,NODES, * NFIND) IF (NPICK.GT.0 .AND. NPICK.LE.4) CALL OMEGA1 IF (NPICK.EQ.6) CALL CONDIT IF (NPICK.LT.0) CALL GETER1 180 RETURN C C ATTEMPTED DIVISION BY ZERO. 190 NERR(1) = NERR(1) + 1 RHO = ZERO GO TO 180 C ATTEMPTED SQRT(V), V.LE.ZERO. 200 NERR(2) = NERR(2) + 1 RHO = ZERO GO TO 180 END SUBROUTINE OMEGA1 C WE WILL USE THE NOTATION C A = DERIVATIVE OF THE OUTPUT WITH RESPECT TO ROUNDING ERRORS C B = DERIVATIVE OF THE OUTPUT WITH RESPECT TO PROBLEM PERTURBATIONS C THIS SUBROUTINE COMPUTES OMEGA(AK,BK), WHERE K DENOTES THE C APPROPRIATE 2-NORM UNIT BALL. COMMON VALUE(300),DERIVS(300,20),CONS(20),RHO,STOPX * ,NLOP(300),NOPER(300),NROP(300),NDXOUT(20),NVARY,NVARYP * ,NODES,NFIND,NPICK,NTOP,NERR(6) DOUBLE PRECISION VALUE,DERIVS,CONS,RHO,STOPX,T,TRY,ZERO,DENOM * ,VALNRM,HUGESV,TINYSV,TEN,DNORM DOUBLE PRECISION DABS INTEGER NDCOL(20) LOGICAL MOVEA, NPICK4 DATA ZERO /0.0D0/, TEN /10.0D0/ C C FIRST REDUCE A TO A SQUARE MATRIX BY APPLYING ORTHOGONAL C TRANSFORMATIONS IN THE SPACE OF ROUNDING ERRORS. C DO 1 J = 1,NFIND NDCOL(J) = NDXOUT(J) - NVARY 1 CONTINUE NROWS = NODES - NVARY IF (NROWS .LT. NFIND) GO TO 1001 IF (NROWS .GT. NFIND) CALL * SQUARE (DERIVS(NVARYP,1),NDCOL,NFIND,.TRUE.) IF (NROWS. GT. NFIND) GO TO 4 DO 3 J = 1,NFIND NDCOLJ = NDCOL(J) IF (NDCOLJ .GE. NFIND) GO TO 3 LIM1 = NDXOUT(J) + 1 LIM2 = NVARY + NFIND DO 2 I = LIM1,LIM2 DERIVS(I,J) = ZERO 2 CONTINUE 3 CONTINUE C C SECOND, REDUCE B TO A SQUARE MATRIX BY APPLYING ORTHOGONAL C TRANSFORMATIONS IN THE SPACE OF PROBLEM PERTURBATIONS. C 4 IF (NPICK .LE. 2) GO TO 8 DNORM = ZERO DO 5 I = 1,NVARY TRY = DABS(VALUE(I)) IF (TRY .GT. DNORM) DNORM = TRY 5 CONTINUE DO 7 J = 1,NFIND DO 6 I = 1,NVARY DERIVS(I,J) = DNORM*DERIVS(I,J) 6 CONTINUE 7 CONTINUE GO TO 11 8 DO 10 J = 1,NFIND DO 9 I = 1,NVARY DERIVS(I,J) = VALUE(I)*DERIVS(I,J) 9 CONTINUE 10 CONTINUE 11 MOVEA = NPICK.EQ.2 .OR. NPICK.EQ.4 IF (MOVEA) GO TO 14 NTOPA = NVARYP DO 12 J = 1,NFIND NDCOL(J) = NVARY 12 CONTINUE GO TO 100 14 NTOPA = NVARYP + NFIND C SHIFT THE REDUCED 'A' MATRIX TO MAKE ROOM FOR THE DERIVATIVE WITH C RESPECT TO OUTPUT PERTURBATIONS. LIM = NVARY + NFIND DO 18 J = 1,NFIND DO 16 I = NVARYP,LIM IPNF = I + NFIND DERIVS(IPNF,J) = DERIVS(I,J) 16 CONTINUE 18 CONTINUE IF (NPICK.EQ.2) GO TO 40 C COMPUTE THE NORM OF THE OUTPUT IF NEEDED. VALNRM = ZERO DO 30 J = 1,NFIND JOUT = NDXOUT(J) T = DABS(VALUE(JOUT)) IF (T .GT. VALNRM) VALNRM = T 30 CONTINUE C ADD DERIVATIVES WITH RESPECT TO OUTPUT PERTURBATIONS. 40 DO 70 J = 1,NFIND NDCOLJ = NVARY + J NDCOL(J) = NDCOLJ IF (J .EQ. 1) GO TO 60 ND = NDCOLJ - 1 DO 50 I = NVARYP,ND DERIVS(I,J) = ZERO 50 CONTINUE 60 NPICK4 = NPICK .EQ. 4 IF (NPICK4) DERIVS(NDCOLJ,J) = VALNRM IF (NPICK4) GO TO 70 JOUT = NDXOUT(J) DERIVS(NDCOLJ,J) = DABS(VALUE(JOUT)) 70 CONTINUE 100 NROWS = NTOPA - 1 IF (NROWS .LT. NFIND) GO TO 1001 IF (NROWS .GT. NFIND) CALL * SQUARE (DERIVS(1,1),NDCOL,NFIND,.FALSE.) C C THIRD, DIAGONALIZE B. (ANY ORTHOGONAL TRANSFORMATIONS IN THE C OUTPUT SPACE MUST ALSO BE APPLIED TO A.) THEN FORM (B INVERSE)*A, C UNLESS B IS SO ILL-CONDITIONED AS TO RENDER THE COMPUTATIONS C MEANINGLESS. C CALL DIAGON (DERIVS(1,1),DERIVS(NTOPA,1),NFIND,.TRUE.,IERR) IF (IERR .NE. 0) GO TO 1002 IF (NFIND .EQ. 1) GO TO 108 HUGESV = DERIVS(1,1) TINYSV = HUGESV DO 104 J = 2,NFIND TRY = DERIVS(J,J) IF (TRY .LT. TINYSV) TINYSV = TRY IF (TRY .GT. HUGESV) HUGESV = TRY 104 CONTINUE T = TINYSV/TEN TRY = HUGESV + T IF (TRY .EQ. HUGESV) GO TO 1002 108 LIM = NTOPA + NFIND - 1 DO 120 J = 1,NFIND DENOM = DERIVS(J,J) DO 110 I = NTOPA,LIM DERIVS(I,J) = DERIVS(I,J)/DENOM 110 CONTINUE 120 CONTINUE C C FOURTH (AND LAST), FIND THE SINGULAR VALUES OF (B INVERSE)*A. C THE LARGEST IS OMEGA(AK,BK). C CALL DIAGON (DERIVS(NTOPA,1),DERIVS(1,1),NFIND,.FALSE.,IERR) IF (IERR .NE. 0) GO TO 1002 RHO = DERIVS(NTOPA,1) IF (NFIND .EQ. 1) GO TO 800 DO 130 I = 2,NFIND IPTOPA = I + NTOPA - 1 TRY = DERIVS(IPTOPA,I) IF (TRY .GT. RHO) RHO = TRY 130 CONTINUE 800 RETURN C C THIS CODE IS REACHED IF EITHER THE NUMBER OF ROUNDING ERRORS C OR THE NUMBER OF PROBLEM PERTURBATIONS IS LESS THAN THE NUMBER C OF OUTPUTS. 1001 NERR(4) = NERR(4) + 1 RHO = ZERO RETURN C C THIS CODE IS REACHED IF OMEGA CAN NOT BE COMPUTED ACCURATELY. 1002 NERR(5) = NERR(5) + 1 RHO = ZERO RETURN END SUBROUTINE SQUARE (A,NDCOL,NFIND,SWAP) C THIS PROCEDURE APPLIES HOUSEHOLDER TRANSFORMATIONS TO A PORTION C OF THE 'DERIVS' MATRIX, REDUCING IT TO AN NFIND-BY-NFIND MATRIX. C A IS THE MATRIX TO BE REDUCED. C NDCOL(I) IS THE END OF COLUMN I. C SWAP = .TRUE. IF THE COLUMNS NEED NOT BE IN NONDECREASING C ORDER OF LENGTH. DOUBLE PRECISION A(300,19),P,S,T,SUM,ZERO DOUBLE PRECISION DSQRT INTEGER NDCOL(20), ICOL(20) LOGICAL SWAP DATA ZERO /0.0D0/ DO 10 I = 1,NFIND 10 ICOL(I) = I IF (NFIND.EQ.1 .OR. .NOT.SWAP) GO TO 35 C BUBBLE SORT. ORDER COLUMNS BY INCREASING LENGTH. C THE K-TH SHORTEST COLUMN IS LOCATED IN A(*,ICOL(K)). NFM1 = NFIND - 1 DO 30 NSWEEP = 1,NFM1 LAST = NFIND - NSWEEP DO 20 I = 1,LAST ICI = ICOL(I) ICIP1 = ICOL(I+1) IF (NDCOL(ICIP1) .GE. NDCOL(ICI)) GO TO 20 ICOL(I) = ICIP1 ICOL(I+1) = ICI 20 CONTINUE 30 CONTINUE C 35 DO 90 KK = 1,NFIND K = ICOL(KK) LIM = NDCOL(K) SUM = ZERO DO 40 I = KK,LIM SUM = SUM + A(I,K)**2 40 CONTINUE S = DSQRT(SUM) IF (SUM .EQ. ZERO) GO TO 70 IF (A(KK,K) .LT. ZERO) S = -S A(KK,K) = A(KK,K) + S P = S*A(KK,K) IF (KK .EQ. NFIND) GO TO 90 KKP1 = KK + 1 DO 60 JJ = KKP1,NFIND J = ICOL(JJ) T = ZERO DO 50 I = KK,LIM T = T + A(I,K)*A(I,J) 50 CONTINUE T = T/P DO 60 I = KK,LIM A(I,J) = A(I,J) - T*A(I,K) 60 CONTINUE 70 DO 80 I = KKP1,NFIND A(I,K) = ZERO 80 CONTINUE 90 A(KK,K) = -S RETURN END SUBROUTINE DIAGON (B,A,NFIND,DOATOO,IERR) DOUBLE PRECISION B(300,19), A(300,19),BX,C,CS,EMM1,EL,F,G,ONE * ,P,R,S,SCALE,SHIFT,SL,SM,SMM1,SN,SUM,T,TEST,T1 * ,TWO,ZERO,ZTEST DOUBLE PRECISION DSQRT,DABS LOGICAL DOATOO DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C THIS SUBROUTINE USES ORTHOGONAL TRANSFORMATIONS TO REDUCE THE C SQUARE MATRIX B TO DIAGONAL FORM. IT IS INSPIRED BY, INDEED C MUCH OF IT IS COPIED FROM, SUBROUTINE SSVDC OF LINPACK. C IF DOATOO THEN ANY ORTHOGONAL TRANSFORMATIONS IN THE OUTPUT SPACE C MUST BE DONE TO A, TOO. OTHERWISE, A IS NOT REFERENCED IN ANY WAY. C C FIRST REDUCE B TO BIDIAGONAL FORM. C IF (NFIND .EQ. 1) GO TO 620 LIM = NFIND -1 DO 200 K = 1,LIM C PERFORM AN ORTHOGONAL TRANSFORMATION IN THE OUTPUT SPACE. KP1 = K + 1 SUM = ZERO DO 10 I = K,NFIND SUM = SUM + B(K,I)**2 10 CONTINUE IF (SUM .EQ. ZERO) GO TO 100 S = DSQRT(SUM) IF (B(K,K) .LT. ZERO) S = -S B(K,K) = B(K,K) + S P = S*B(K,K) DO 40 J = KP1,NFIND T = ZERO DO 20 I = K,NFIND T = T + B(K,I)*B(J,I) 20 CONTINUE T = T/P DO 30 I = K,NFIND B(J,I) = B(J,I) - T*B(K,I) 30 CONTINUE 40 CONTINUE IF (.NOT.DOATOO) GO TO 80 DO 70 J = 1,NFIND T = ZERO DO 50 I = K,NFIND T = T + B(K,I)*A(J,I) 50 CONTINUE T = T/P DO 60 I = K,NFIND A(J,I) = A(J,I) - T*B(K,I) 60 CONTINUE 70 CONTINUE 80 B(K,K) = -S C 100 IF (K .EQ. LIM) GO TO 200 C PERFORM AN ORTHOGONAL TRANSFORMATION IN THE ERROR SPACE. SUM = ZERO DO 110 I = KP1,NFIND SUM = SUM + B(I,K)**2 110 CONTINUE IF (SUM .EQ. ZERO) GO TO 200 S = DSQRT(SUM) IF (B(KP1,K) .LT. ZERO) S = -S B(KP1,K) = B(KP1,K) + S P = S*B(KP1,K) DO 140 J = KP1,NFIND T = ZERO DO 120 I = KP1,NFIND T = T + B(I,K)*B(I,J) 120 CONTINUE T = T/P DO 130 I = KP1,NFIND B(I,J) = B(I,J) - T*B(I,K) 130 CONTINUE 140 CONTINUE B(KP1,K) = -S 200 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MAXIT = 30 M = NFIND ITER = 0 360 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT IF (M .EQ. 0) GO TO 620 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, GO TO ERROR EXIT. C IF (ITER .GE. MAXIT) GO TO 1000 C C THIS SECTION OF THE PROGRAM INSPECTS FOR NEGLIGIBLE ELEMENTS OF B. C ON COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF B(M,M) AND B(L,L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF B(L,L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF B(L,L-1) IS NEGLIGIBLE, L.LT.M, AND B(L,L),..., C B(M,M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF B(M,M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 390 LL = 1,M L = M - LL C ...EXIT IF (L .EQ. 0) GO TO 400 TEST = DABS(B(L,L)) + DABS(B(L+1,L+1)) ZTEST = TEST + DABS(B(L+1,L)) IF (ZTEST .NE. TEST) GO TO 380 B(L+1,L) = ZERO C ......EXIT GO TO 400 380 CONTINUE 390 CONTINUE 400 CONTINUE IF (L .NE. M - 1) GO TO 410 KASE = 4 GO TO 480 410 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 430 LLS = LP1, MP1 LS = M - LLS + LP1 C .....EXIT IF (LS .EQ. L) GO TO 440 TEST = ZERO IF (LS .NE. M) TEST = TEST + DABS(B(LS+1,LS)) IF (LS .NE. L + 1) TEST = TEST + DABS(B(LS,LS-1)) ZTEST = TEST + DABS(B(LS,LS)) IF (ZTEST .NE. TEST) GO TO 420 B(LS,LS) = ZERO C ....EXIT GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (LS .NE. L) GO TO 450 KASE = 3 GO TO 470 450 CONTINUE IF (LS .NE. M) GO TO 460 KASE = 1 GO TO 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (490,520,540,570), KASE C C DEFLATE NEGLIGIBLE B(M,M). C 490 CONTINUE MM1 = M - 1 F = B(M,M-1) B(M,M-1) = ZERO DO 510 KK = L,MM1 K = MM1 - KK + L T1 = B(K,K) SCALE = DABS(F) + DABS(T1) IF (SCALE .NE. ZERO) GO TO 498 CS = ONE SN = ZERO R = ZERO GO TO 499 498 R = SCALE*DSQRT((F/SCALE)**2 + (T1/SCALE)**2) CS = T1/R SN = F/R 499 B(K,K) = R IF (K .EQ. L) GO TO 500 F = -SN*B(K,K-1) B(K,K-1) = CS*B(K,K-1) 500 CONTINUE 510 CONTINUE GO TO 610 C C SPLIT AT NEGLIGIBLE B(L,L). C 520 CONTINUE LM1 = L - 1 F = B(L,L-1) B(L,L-1) = ZERO DO 530 K = L,M T1 = B(K,K) SCALE = DABS(F) + DABS(T1) IF (SCALE .NE. ZERO) GO TO 523 CS = ONE SN = ZERO R = ZERO GO TO 524 523 R = SCALE*DSQRT((F/SCALE)**2 + (T1/SCALE)**2) CS = T1/R SN = F/R 524 B(K,K) = R IF (.NOT.DOATOO) GO TO 528 DO 525 IROW = 1,NFIND T = -SN*A(IROW,K) + CS*A(IROW,LM1) A(IROW,K) = CS*A(IROW,K) + SN*A(IROW,LM1) A(IROW,LM1) = T 525 CONTINUE 528 IF (K .EQ. M) GO TO 530 F = -SN*B(K+1,K) B(K+1,K) = CS*B(K+1,K) 530 CONTINUE GO TO 610 C C PERFORM ONE QR STEP. C 540 CONTINUE C C CALCULATE THE SHIFT. C SCALE = DABS(B(M,M)) + DABS(B(M-1,M-1)) + DABS(B(M,M-1)) * + DABS(B(L,L)) + DABS(B(L+1,L)) SM = B(M,M)/SCALE SMM1 = B(M-1,M-1)/SCALE EMM1 = B(M,M-1)/SCALE SL = B(L,L)/SCALE EL = B(L+1,L)/SCALE BX = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/TWO C = (SM*EMM1)**2 SHIFT = ZERO IF (BX .EQ. ZERO .AND. C .EQ. ZERO) GO TO 550 SHIFT = DSQRT(BX**2+C) IF (BX .LT. ZERO) SHIFT = -SHIFT SHIFT = C/(BX + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M -1 DO 560 K = L,MM1 SCALE = DABS(F) + DABS(G) IF (SCALE .NE. ZERO) GO TO 552 CS = ONE SN = ZERO R = ZERO GO TO 553 552 R = SCALE*DSQRT((F/SCALE)**2 + (G/SCALE)**2) CS = F/R SN = G/R 553 IF (K .NE. L) B(K,K-1) = R F = CS*B(K,K) + SN*B(K+1,K) B(K+1,K) = CS*B(K+1,K) - SN*B(K,K) G = SN*B(K+1,K+1) B(K+1,K+1) = CS*B(K+1,K+1) SCALE = DABS(F) + DABS(G) IF (SCALE .NE. ZERO) GO TO 556 CS = ONE SN = ZERO R = ZERO GO TO 557 556 R = SCALE*DSQRT((F/SCALE)**2 + (G/SCALE)**2) CS = F/R SN = G/R 557 B(K,K) = R F = CS*B(K+1,K) + SN*B(K+1,K+1) B(K+1,K+1) = -SN*B(K+1,K) + CS*B(K+1,K+1) IF (.NOT.DOATOO) GO TO 559 DO 558 IROW = 1,NFIND T = -SN*A(IROW,K) + CS*A(IROW,K+1) A(IROW,K) = CS*A(IROW,K) + SN*A(IROW,K+1) A(IROW,K+1) = T 558 CONTINUE 559 IF (K .EQ.MM1) GO TO 560 G = SN*B(K+2,K+1) B(K+2,K+1) = CS*B(K+2,K+1) 560 CONTINUE B(M,M-1) = F ITER = ITER + 1 GO TO 610 C C CONVERGENCE C 570 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE. C IF (B(L,L) .LT. ZERO) B(L,L) = -B(L,L) 600 CONTINUE ITER = 0 M = M - 1 610 CONTINUE GO TO 360 620 CONTINUE IERR = 0 RETURN 1000 IERR = 1 RETURN END SUBROUTINE CONDIT C THIS SUBROUTINE COMPUTES CONDITION NUMBERS OMEGA(BK,FK). HERE C B IS THE DERIVATIVE OF THE OUTPUT WITH RESPECT TO THE INPUT, C F IS A DIAGONAL MATRIX OF OUTPUT VALUES (OR THE NORM OF THE C OUTPUT), AND THE K ARE 2-NORM UNIT BALLS. COMMON VALUE(300),DERIVS(300,20),CONS(20),RHO,STOPX, * NLOP(300),NOPER(300),NROP(300),NDXOUT(20),NVARY,NVARYP, * NODES,NFIND,NPICK,NTOP,NERR(5) DOUBLE PRECISION VALUE,DERIVS,CONS,RHO,STOPX DOUBLE PRECISION DATNRM,OUTJ,VALNRM,TRY,ZERO INTEGER NDCOL(20) LOGICAL LENTRY C DATA ZERO /0.0D0/ LENTRY = IABS(NPICK) .GE. 3 IF (LENTRY) GO TO 40 C C HERE FOR JWE,WKE,ERE. C C ULP = UNIT IN THE LAST PLACE OF EACH ENTRY. DO 20 J = 1,NFIND NDCOL(J) = NVARY JOUT = NDXOUT(J) OUTJ = VALUE(JOUT) IF (OUTJ .EQ. ZERO) GO TO 1000 DO 10 I = 1,NVARY DERIVS(I,J) = VALUE(I)*DERIVS(I,J)/OUTJ 10 CONTINUE 20 CONTINUE GO TO 65 C C HERE FOR JWL,WKL,ERL. C C ULP = UNIT IN THE LAST PLACE OF THE LARGEST ENTRY. C COMPUTE THE NORM OF THE DATA. 40 DATNRM = ZERO DO 50 I = 1,NVARY TRY = DABS(VALUE(I)) IF (TRY .GT. DATNRM) DATNRM = TRY 50 CONTINUE C COMPUTE THE NORM OF THE OUTPUT OUTNRM = ZERO DO 60 J = 1,NFIND NDCOL(J) = NVARY JOUT = NDXOUT(J) TRY = DABS(VALUE(JOUT)) IF (TRY .GT. OUTNRM) OUTNRM = TRY 60 CONTINUE IF (OUTNRM .EQ. ZERO) GO TO 1000 C C FINISH UP. C 65 IF (NVARY .GT. NFIND) CALL SQUARE(DERIVS,NDCOL,NFIND,.FALSE.) CALL DIAGON (DERIVS,DERIVS,NFIND,.FALSE.,IERR) IF (IERR .NE. 0) GO TO 1000 RHO = ZERO DO 70 I = 1,NFIND TRY = DERIVS(I,I) IF (TRY .GT. RHO) RHO = TRY 70 CONTINUE IF (LENTRY) RHO = DATNRM*RHO/OUTNRM RETURN C C THE COMPUTATION FAILED. 1000 RHO = ZERO RETURN END C.......... COMPARE ROUNDING ERRORS IN TWO ALGORITHMS C C THE USER SUPPLIES: C C THE OUTPUT FROM THE MINICOMPILER FOR EACH OF THE TWO C ALGORITHMS BEING TESTED. C C THE ENTRIES OF THE INITIAL SET OF DATA. ONE ENTRY PER CARD, EACH C ENTRY WRITTEN WITH A DECIMAL POINT AND CONTAINED IN THE FIRST C TWENTY COLUMNS. C C ONE OF THE ERROR-COMPARING OPTIONS 'ER1/2', 'ER2/1', 'JW1/2', C OR 'JW2/1' TYPED IN THE FIRST FIVE COLUMNS OF ITS LINE. ANY C OTHER STRING INVOLVING AT LEAST ONE LETTER WILL CAUSE THE C SOFTWARE TO COMPUTE ONLY THE OUTPUT VALUES OF THE STRAIGHT-LINE C PROGRAMS AT THE INITIAL DATA. C C THE STOPPING VALUE FOR THE MAXIMIZER. WRITTEN WITH A DECIMAL C POINT AND CONTAINED IN THE FIRST TWENTY COLUMNS OF ITS CARD. C C THE SOFTWARE RETURNS: C C AN ANNOTATED LISTING OF THE USER-SUPPLIED INFORMATION, PLUS THE C ERROR-COMPARING VALUE, THE CONSTRAINT VALUES (IF ANY) AND C THE OUTPUT COMPUTED AT THE INITIAL SET OF DATA. C C A LIST OF SELECTED VALUES FOUND BY THE MAXIMIZER. C C THE FINAL SET OF DATA. C C OTHER INFORMATION IS RETURNED IF EXCEPTIONS ARISE. C C ------------------------------------------------------------------ C C THE USER CAN AVOID THE MINICOMPILER BY SUPPLYING: C C THE NUMBER OF OPERATIONS IN THE PROGRAM BEING TESTED. GE.1 C AND LE.300. FORMAT(I3). (INSTRUCTIONS ARE PROVIDED BELOW FOR C RAISING THE UPPER BOUND TO TEST LONGER PROGRAMS, OR LOWERING IT C TO CONSERVE STORAGE.) C C THE OPERATIONS OF THE STRAIGHT-LINE PROGRAM. FORMAT(I3,I2,I4). C THE I-TH DATA ENTRY IS ENCODED AS I, THE J-TH COMPUTED VALUE AS C 100 + J AND THE K-TH CONSTANT AS -K. THE OPERATIONS +, -, *, /, C SQRT AND UNARY MINUS ARE ENCODED AS 1-6, RESPECTIVELY. SQRT AND C UNARY MINUS REQUIRE 0 AS THEIR SECOND OPERAND. C C THE NUMBER OF OUTPUTS OF THE STRAIGHT-LINE PROGRAM. C GE.1 AND LE.20. FORMAT(I2) C C THE INSTRUCTIONS AT WHICH THE OUTPUTS ARE COMPUTED. FORMAT(I3). C C THE NUMBER OF CONSTANTS. LE.20. FORMAT(I2). C C THE CONSTANTS. FORMAT(G20.16) C C THE NUMBER OF ENTRIES IN A SET OF DATA. LE.30. FORMAT(I2). C C ----------------------------------------------------------------- C C THIS MAIN PROGRAM PERFORMS INPUT AND OUTPUT DUTIES. C C THE SUBPROGRAMS ARE: C C MAXIM - A 'DIRECT SEARCH' NUMERICAL MAXIMIZER CALLED BY THE C MAIN PROGRAM. C C GRAM - A GRAM-SCHMIDT ROUTINE USED BY MAXIM. C C F2 - FUNCTION CALLED BY MAXIM WHICH EVALUATES THE PENALIZED C ERROR-COMPARING VALUE. C C ROUND2 - ROUTINE CALLED BY THE MAIN PROGRAM AND F2 TO EVALUATE C SENSITIVITY TO ERRORS. C C GETER2 - ROUTINE CALLED BY ROUND2 IF THE USER OPTS TO TEST C ERROR RATIOS, ER. C C OMEGA2 - ROUTINE CALLED BY ROUND2 TO EVALUATE JW. C C SQUARE - A ROUTINE CALLED BY OMEGA2 TO REDUCE A RECTANGULAR C MATRIX TO A SQUARE MATRIX. C C DIAGON - A ROUTINE CALLED BY OMEGA2 TO DIAGONALIZE A SQUARE C MATRIX, I.E., TO COMPUTE ITS SINGULAR VALUES. C C POSITV - USER-SUPPLIED ROUTINE TO EVALUATE CONSTRAINTS. THE C VERSION OF POSITIV REQUIRED BY THIS RELEASE OF THE SOFTWARE FOR C ROUNDOFF ANALYSIS DOES NOT AGREE WITH THAT REQUIRED BY THE C SOFTWARE IN TRANS. ON MATH. SOFTWARE, DEC. 1978. THE SYNTAX IS C C SUBROUTINE POSITV(CONSTR, DATA, VALUE1, VALUE2, NBRCON) C DOUBLE PRECISION CONSTR(30), DATA(30), VALUE1(300), VALUE2(300) C WHERE CONSTR(I) IS THE I-TH CONSTRAINT C DATA(I) IS THE I-TH DATA ITEM C VALUEJ(I) IS THE I-TH COMPUTED VALUE OF ALGORITHM J. C C ------------------------------------------------------------------ C COMMON VALUE(300,2), DERIVS(300,20,2), D(30), CONS(20,2), RHO, * STOPX, NLOP(300,2), NOPER(300,2), NROP(300,2), NDXOUT(20,2), * NOP(2), NERR(5), NVARY, NFIND, NPICK DOUBLE PRECISION C(30), X(30) DOUBLE PRECISION D, F2, ONE, RHO, CONS, ZERO, STOPX, VALUE DOUBLE PRECISION CONMIN, DERIVS INTEGER CHE, CHJ, CHR, CHW, BLK, MNS, SLH, C1, C2, C3, C4, C5, * CH0, CH1, CH2 INTEGER NFIX(2) EXTERNAL F2 C ------------------------------------------------------------------ C C C VALUE(I,K) - THE I-TH COMPUTED VALUE OF THE K-TH ALGORITHM. C C DERIVS(J,I,K) - THE DERIVATIVE OF THE I-TH OUTPUT WRT THE J-TH C ROUNDING ERROR IN THE K-TH ALGORITHM. C C D - THE DATA. C C CONS(I,K) - THE CONSTANTS OF THE K-TH ALGORITHM. C C RHO - THE ERROR-COMPARING VALUE. C C STOPX - EXECUTION STOPS IF RHO REACHES STOPX. C C NLOP(I,K), NOPER(I,K), NROP(I,K) - THE LEFT OPERAND, THE C OPERAND AND THE RIGHT OPERAND OF THE I-TH INSTRUCTION OF C THE K-TH ALGORITHM. C C NDXOUT(I,K) - INDEX OF THE I-TH OUTPUT OF THE K-TH ALGORITHM. C C NOP(K) - THE NUMBER OF OPERATIONS IN THE K-TH ALGORITHM. C C NVARY - NUMBER OF VARIABLE INPUTS. C C NFIND - NUMBER OF OUTPUTS. C C NPICK - PICKS THE ERROR-COMPARING VALUE. C C NERR - ERROR FLAGS. C C C - ARRAY OF PENALTIES. C C ------------------------------------------------------------------ C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C NIN = STANDARD INPUT UNIT C NOUT = STANDARD OUTPUT UNIT DATA NIN /5/, NOUT /6/, ZERO /0.0D0/, ONE /1.0D0/ C DATA CHE, CHJ, CHR, CHW, BLK, MNS, SLH, CH0, CH1, CH2 /1HE,1HJ, * 1HR,1HW,1H ,1H-,1H/,1H0,1H1,1H2/ C DO 70 NALG=1,2 C READ THE STRAIGHT-LINE CODE OF THE NALG-TH ALGORITHM. READ (NIN,99999) MOP C C ------------------------------------------------------------------ C C TO TEST PROGRAMS WITH NOP.GE.300 JUST (1) CHANGE THE 'COMMON' C DECLARATIONS, HERE AND IN SUBROUTINES F, ROUND2, GETER2 AND OMEGA2, C (2) REDIMENSION ARRAYS WGTLFT AND WGTRGT IN SUBROUTINE ROUND2 C AND (3) MAKE THE APPROPRIATE CHANGE IN THE NEXT CARD. IF ((MOP.LE.0) .OR. (MOP.GT.300)) GO TO 230 C C ------------------------------------------------------------------ C NOP(NALG) = MOP WRITE (NOUT,99998) NALG DO 10 I=1,MOP READ (NIN,99997) NLOP(I,NALG), NOPER(I,NALG), NROP(I,NALG) 10 CONTINUE C C READ THE LOCATIONS OF THE OUTPUTS. READ (NIN,99996) NFIND IF (NALG.EQ.1) MFIND = NFIND IF ((NALG.EQ.2) .AND. (NFIND.NE.MFIND)) GO TO 210 IF (NFIND.LE.0) GO TO 260 DO 20 I=1,NFIND READ (NIN,99999) NDXOUT(I,NALG) 20 CONTINUE C C READ AND WRITE THE CONSTANTS. READ (NIN,99996) MFIX NFIX(NALG) = MFIX IF ((MFIX.LT.0) .OR. (MFIX.GT.20)) GO TO 240 IF (MFIX.EQ.0) GO TO 40 WRITE (NOUT,99995) DO 30 I=1,MFIX READ (NIN,99994) CONS(I,NALG) WRITE (NOUT,99993) I, CONS(I,NALG) 30 CONTINUE 40 READ (NIN,99996) NVARY IF (NALG.EQ.1) MVARY = NVARY IF ((NALG.EQ.2) .AND. (NVARY.NE.MVARY)) GO TO 220 C C CHECK AND LIST THE STRAIGHT-LINE PROGRAM. WRITE (NOUT,99992) MFIX = -MFIX DO 50 I=1,MOP MLOP = NLOP(I,NALG) MOPER = NOPER(I,NALG) MROP = NROP(I,NALG) II = I + 100 IF ((MLOP.LT.MFIX) .OR. (MLOP.EQ.0) .OR. (MLOP.GE.II)) GO TO * 250 IF ((MLOP.GT.NVARY) .AND. (MLOP.LE.100)) GO TO 250 IF ((MOPER.LE.0) .OR. (MOPER.GE.7)) GO TO 250 IF ((MOPER.LE.4) .AND. (MROP.EQ.0)) GO TO 250 IF ((MOPER.GE.5) .AND. (MROP.NE.0)) GO TO 250 IF ((MROP.LT.MFIX) .OR. (MROP.GT.II)) GO TO 250 IF ((MROP.GT.NVARY) .AND. (MROP.LE.100)) GO TO 250 CALL LISTOP(I, MLOP, MOPER, MROP) 50 CONTINUE C C CHECK AND LIST THE LOCATIONS OF THE OUTPUT. IF ((NFIND.LE.0) .OR. (NFIND.GT.20)) GO TO 260 WRITE (NOUT,99991) NFIND DO 60 I=1,NFIND MDXOUT = NDXOUT(I,NALG) WRITE (NOUT,99990) MDXOUT IF ((MDXOUT.LE.0) .OR. (MDXOUT.GT.MOP)) GO TO 270 60 CONTINUE C C END THE LOOP WHICH READS THE K-TH ALGORITHM. 70 CONTINUE C C READ AND LIST THE INITIAL DATA. IF ((NVARY.LE.0) .OR. (NVARY.GT.30)) GO TO 280 WRITE (NOUT,99989) DO 80 I=1,NVARY READ (NIN,99994) D(I) WRITE (NOUT,99988) I, D(I) 80 CONTINUE C C SEE WHICH ERROR-COMPARING VALUE IS TO BE MAXIMIZED. NPICK = 0 READ (NIN,99987) C1, C2, C3, C4, C5 IF (C1.EQ.CHE .AND. C2.EQ.CHR .AND. C3.EQ.CH1 .AND. C4.EQ.SLH * .AND. C5.EQ.CH2) NPICK = -1 IF (C1.EQ.CHE .AND. C2.EQ.CHR .AND. C3.EQ.CH2 .AND. C4.EQ.SLH * .AND. C5.EQ.CH1) NPICK = -2 IF (C1.EQ.CHJ .AND. C2.EQ.CHW .AND. C3.EQ.CH1 .AND. C4.EQ.SLH * .AND. C5.EQ.CH2) NPICK = 1 IF (C1.EQ.CHJ .AND. C2.EQ.CHW .AND. C3.EQ.CH2 .AND. C4.EQ.SLH * .AND. C5.EQ.CH1) NPICK = 2 IF (NPICK.NE.0 .OR. C3.NE.BLK .OR. C4.NE.BLK .OR. C5.NE.BLK) GO * TO 90 IF (C1.NE.BLK .AND. C1.NE.MNS .AND. C1.NE.CH0) GO TO 90 C NUMERICAL CODES ARE PERMITTED FOR COMPATIBILITY WITH EARLIER C VERSIONS OF THIS SOFTWARE (TOMS, DEC. 1978). IF (C2.EQ.CH1) NPICK = 1 IF (C2.EQ.CH2) NPICK = 2 IF (C1.EQ.MNS) NPICK = -NPICK 90 IF (NPICK.EQ.0) WRITE (NOUT,99986) IF (NPICK.NE.0) WRITE (NOUT,99985) MINUS2 = -2 IF (NPICK.EQ.MINUS2) WRITE (NOUT,99984) MINUS1 = -1 IF (NPICK.EQ.MINUS1) WRITE (NOUT,99983) IF (NPICK.EQ.1) WRITE (NOUT,99982) IF (NPICK.EQ.2) WRITE (NOUT,99981) C C ZERO THE ERROR FLAGS. DO 100 I=1,5 NERR(I) = 0 100 CONTINUE C C COMPUTE AND LIST THE ERROR-COMPARING VALUE, THE CONSTRAINT VALUES C (IF ANY) AND THE OUTPUT AT THE INITIAL DATA. CALL ROUND2 IF (NPICK.EQ.0) GO TO 130 WRITE (NOUT,99980) RHO CALL POSITV(C, D, VALUE(1,1), VALUE(1,2), NUMBER) CONMIN = ONE IF (NUMBER.LE.0) GO TO 120 WRITE (NOUT,99979) DO 110 I=1,NUMBER WRITE (NOUT,99978) I, C(I) IF (C(I).LT.CONMIN) CONMIN = C(I) 110 CONTINUE GO TO 130 120 WRITE (NOUT,99977) 130 WRITE (NOUT,99976) DO 140 I=1,NFIND NDX1 = NDXOUT(I,1) NDX2 = NDXOUT(I,2) WRITE (NOUT,99975) I, VALUE(NDX1,1), VALUE(NDX2,2) 140 CONTINUE IF (NPICK.EQ.0) GO TO 190 IF (CONMIN.LE.ZERO) GO TO 190 READ (NIN,99994) STOPX WRITE (NOUT,99974) STOPX IF (STOPX.LE.ZERO) GO TO 190 IF (RHO.GE.STOPX) GO TO 170 C C MAXIMIZE. WRITE (NOUT,99973) DO 150 I=1,NVARY X(I) = D(I) 150 CONTINUE JVARY = NVARY CALL MAXIM(F2, X, JVARY) WRITE (NOUT,99972) DO 160 I=1,NVARY WRITE (NOUT,99988) I, D(I) 160 CONTINUE IF (RHO.LT.STOPX) GO TO 190 170 CALL POSITV(C, D, VALUE(1,1), VALUE(1,2), NUMBER) IF (NUMBER.LE.0) GO TO 190 WRITE (NOUT,99971) DO 180 I=1,NUMBER WRITE (NOUT,99978) I, C(I) 180 CONTINUE C C LIST EXCEPTIONS. 190 IF (NERR(1).GT.0) WRITE (NOUT,99970) NERR(1) IF (NERR(2).GT.0) WRITE (NOUT,99969) NERR(2) IF (NERR(3).GT.0) WRITE (NOUT,99968) NERR(3) IF (NERR(4).GT.0) WRITE (NOUT,99967) NERR(4) IF (NERR(5).GT.0) WRITE (NOUT,99966) NERR(5) 200 WRITE (NOUT,99964) STOP C C MESSAGES FOR DATA ERRORS. 210 WRITE (NOUT,99963) GO TO 290 220 WRITE (NOUT,99962) GO TO 290 230 WRITE (NOUT,99961) GO TO 290 240 WRITE (NOUT,99960) GO TO 290 250 WRITE (NOUT,99959) GO TO 290 260 WRITE (NOUT,99958) GO TO 290 270 WRITE (NOUT,99957) GO TO 290 280 WRITE (NOUT,99956) GO TO 290 290 WRITE (NOUT,99955) GO TO 200 99999 FORMAT (I3) 99998 FORMAT (1H1, 9X, 32HSTRAIGHT-LINE CODE FOR ALGORITHM, I2, 1H.// * 10X, 40HD(I) DENOTES THE I-TH ENTRY OF THE DATA.) 99997 FORMAT (I3, I2, I4) 99996 FORMAT (I2) 99995 FORMAT (//10X, 31HA(I) DENOTES THE I-TH CONSTANT.) 99994 FORMAT (G20.16) 99993 FORMAT (13X, 2HA(, I2, 3H) =, G16.8) 99992 FORMAT (//10X, 41HV(I) DENOTES THE I-TH INTERMEDIATE VALUE.) 99991 FORMAT (//10X, 3HTHE, I3, 12H OUTPUTS ARE) 99990 FORMAT (13X, 2HV(, I3, 1H)) 99989 FORMAT (1H1, 10X, 16HTHE INITIAL DATA) 99988 FORMAT (13X, 2HD(, I3, 3H) =, G16.8) 99987 FORMAT (5A1) 99986 FORMAT (///10X, 36HNO ERROR-COMPARING VALUE IS COMPUTED) 99985 FORMAT (///10X, 35HTHE CHOSEN ERROR-COMPARING VALUE IS) 99984 FORMAT (10X, 34HER FOR (ALGORITHM 2)/(ALGORITHM 1)) 99983 FORMAT (10X, 34HER FOR (ALGORITHM 1)/(ALGORITHM 2)) 99982 FORMAT (10X, 34HJW FOR (ALGORITHM 1)/(ALGORITHM 2)) 99981 FORMAT (10X, 34HJW FOR (ALGORITHM 2)/(ALGORITHM 1)) 99980 FORMAT (///10X, 46HAT THE INITIAL DATA THE ERROR-COMPARING VALUE , * 7HEQUALS /20X, G12.4) 99979 FORMAT (///10X, 35HTHE CONSTRAINTS AT THE INITIAL DATA) 99978 FORMAT (13X, 2HC(, I2, 3H) =, G16.8) 99977 FORMAT (///10X, 25HTHERE ARE NO CONSTRAINTS.) 99976 FORMAT (///10X, 30HTHE OUTPUT AT THE INITIAL DATA/15X, 8HALGORITH, * 3HM 1, 5X, 11HALGORITHM 2) 99975 FORMAT (I13, G16.8, G16.8) 99974 FORMAT (///10X, 22HTHE STOPPING VALUE IS , G11.4) 99973 FORMAT (/10X, 20HAPPLY THE MAXIMIZER.) 99972 FORMAT (///10X, 21HTHE FINAL SET OF DATA) 99971 FORMAT (///10X, 24HHERE THE CONSTRAINTS ARE) 99970 FORMAT (/I10, 28H ATTEMPTED DIVISIONS BY ZERO) 99969 FORMAT (/I10, 26H ATTEMPTED SQRT(V), V.LT.0) 99968 FORMAT (/I10, 16H GETER2 FAILURES) 99967 FORMAT (/I10, 16H OMEGA2 FAILURES) 99966 FORMAT (/I10, 16H DIAGON FAILURES) 99964 FORMAT (/40X, 35H ROUNDOFF ANALYZER VERSION 07/02/79) 99963 FORMAT (49H TWO ALGORITHMS MUST HAVE SAME NUMBER OF OUTPUTS.) 99962 FORMAT (48H TWO ALGORITHMS MUST HAVE SAME NUMBER OF INPUTS.) 99961 FORMAT (35H PROGRAM LENGTH MAY NOT EXCEED 300.) 99960 FORMAT (39H NUMBER OF CONSTANTS MAY NOT EXCEED 20.) 99959 FORMAT (33H INCORRECT CODE FOR AN OPERATION.) 99958 FORMAT (37H NUMBER OF OUTPUTS MAY NOT EXCEED 20.) 99957 FORMAT (25H IMPOSSIBLE OUTPUT INDEX.) 99956 FORMAT (36H NUMBER OF INPUTS MAY NOT EXCEED 30.) 99955 FORMAT (44H EXECUTION TERMINATED BECAUSE OF DATA ERROR.) END SUBROUTINE LISTOP(I, MLOP, MOPER, MROP) INTEGER PLUS, MINUS, STAR, SLASH, A, D, V, LEFT, OP, RIGHT DATA PLUS, MINUS, STAR, SLASH, A, D, V, NOUT /1H+,1H-,1H*,1H/,1HA, * 1HD,1HV,6/ C C GET THE LEFT OPERAND. IF (MLOP.LT.0) LEFT = A IF (MLOP.LT.0) LISTL = -MLOP IF ((MLOP.GT.0) .AND. (MLOP.LE.100)) LEFT = D IF ((MLOP.GT.0) .AND. (MLOP.LE.100)) LISTL = MLOP IF (MLOP.GT.100) LEFT = V IF (MLOP.GT.100) LISTL = MLOP - 100 IF (MOPER.GE.5) GO TO 20 C C GET THE OPERATOR. IF (MOPER.EQ.1) OP = PLUS IF (MOPER.EQ.2) OP = MINUS IF (MOPER.EQ.3) OP = STAR IF (MOPER.EQ.4) OP = SLASH C C GET THE RIGHT OPERAND. IF (MROP.LT.0) RIGHT = A IF (MROP.LT.0) LISTR = -MROP IF ((MROP.GT.0) .AND. (MROP.LE.100)) RIGHT = D IF ((MROP.GT.0) .AND. (MROP.LE.100)) LISTR = MROP IF (MROP.GT.100) RIGHT = V IF (MROP.GT.100) LISTR = MROP - 100 C C LIST THE OPERATION. WRITE (NOUT,99999) I, LEFT, LISTL, OP, RIGHT, LISTR 10 RETURN 20 IF (MOPER.EQ.5) WRITE (NOUT,99998) I, LEFT, LISTL IF (MOPER.EQ.6) WRITE (NOUT,99997) I, LEFT, LISTL GO TO 10 99999 FORMAT (13X, 2HV(, I3, 4H) = , A1, 1H(, I3, 2H) , A1, 1H , A1, * 1H(, I3, 1H)) 99998 FORMAT (13X, 2HV(, I3, 13H) = SQRT , A1, 1H(, I3, 1H)) 99997 FORMAT (13X, 2HV(, I3, 13H) = - , A1, 1H(, I3, 1H)) END DOUBLE PRECISION FUNCTION F2(X, IERR) C C COMPUTE THE PENALIZED ERROR-COMPARING VALUE AT THE CURRENT D. C THE UNPENALIZED VALUE IS LISTED AT INTERVALS OF 5*NVARY (SO LONG AS C THE CONSTRAINTS ARE SATISFIED). THE SEARCH IS TERMINATED AFTER C 50*NVARY EVALUATIONS. D IS PASSED TO F IN X. F SETS IERR TO 1 C TO STOP THE MAXIMIZATION PROCESS. C COMMON VALUE(300,2), DERIVS(300,20,2), D(30), CONS(20,2), RHO, * STOPX, NLOP(300,2), NOPER(300,2), NROP(300,2), NDXOUT(20,2), * NOP(2), NERR(5), NVARY, NFIND, NPICK DOUBLE PRECISION C(30), X(30) DOUBLE PRECISION D, ONE, CONS, RHO, ZERO, STOPX, VALUE, DERIVS DOUBLE PRECISION PENLTY DATA NCALLS /0/, NPRINT /0/ C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. DATA NOUT /6/, ONE /1.0D0/, ZERO /0.0D0/ C C COMPUTE THE UNPENALIZED ERROR-COMPARING VALUE. DO 10 I=1,NVARY D(I) = X(I) 10 CONTINUE CALL ROUND2 NCALLS = NCALLS + 1 C C THE CONSTRAINTS ARE THAT C(I) BE POSITIVE, 1.LE.I.LE.NUMBER. CALL POSITV(C, D, VALUE(1,1), VALUE(1,2), NUMBER) C C COMPUTE PENALTY = MIN (1, MIN C(I)). PENLTY = ONE IF (NUMBER.LE.0) GO TO 30 DO 20 I=1,NUMBER IF (C(I).LT.PENLTY) PENLTY = C(I) 20 CONTINUE 30 F2 = PENLTY*RHO IF ((RHO.GT.STOPX) .AND. (PENLTY.GT.ZERO)) GO TO 70 C C NORMAL RETURN (THE SEARCH FOR INSTABILITY MAY BE CALLED OFF). IERR = 0 IF (PENLTY.LE.ZERO) GO TO 50 LISTX = 5*NVARY IF ((NCALLS/LISTX)*LISTX.NE.NCALLS) GO TO 50 IF (NPRINT.EQ.1) GO TO 40 WRITE (NOUT,99999) NPRINT = 1 40 WRITE (NOUT,99998) NCALLS, RHO 50 IF (NCALLS.GE.50*NVARY) IERR = 1 60 RETURN C C RHO PUSHED ABOVE STOPX. C SETTING IERR TO 1 FORCES THE MAXIMIZER TO TERMINATE. 70 WRITE (NOUT,99997) NCALLS, RHO IERR = 1 GO TO 60 99999 FORMAT (/10X, 48HCOLUMN 1 GIVES THE NUMBER OF EVALUATIONS OF THE , * 22HERROR-COMPARING VALUE./10X, 30HCOLUMN 2 GIVES THE CURRENT ERR, * 19HOR-COMPARING VALUE.) 99998 FORMAT (I15, G15.4) 99997 FORMAT (///10X, 20HINSTABILITY LOCATED./10X, 5HAFTER, I5, * 45H EVALUATIONS THE ERROR-COMPARING VALUE EQUALS/20X, G11.4) END SUBROUTINE ROUND2 C THIS SUBROUTINE FINDS THE INTERMEDIATE COMPUTED VALUES PLUS THEIR C PARTIAL DERIVATIVES WITH RESPECT TO THEIR ARGUMENTS. A METHOD DUE TO C JOHN LARSON AND AHMED SAMEH (EFFICIENT CALCULATION OF THE EFFECTS OF C ROUNDING ERRORS, TOMS 4 (1978), PP. 228-236) IS C APPLIED TO COMPUTE DELTAX(I,J), THE PARTIAL DERIVATIVE OF THE J-TH C OUTPUT WRT THE I-TH INPUT, AND DERIVS(I,J), THE PARTIAL DERIVATIVE C OF THE J-TH OUTPUT WRT THE I-TH COMPUTED VALUE. IN STATEMENT 120 C DERIVS IS MODIFIED TO BE THE DERIVATIVE WRT THE I-TH ROUNDING ERROR. C COMMON VALUE(300,2), DERIVS(300,20,2), D(30), CONS(20,2), RHO, * STOPX, NLOP(300,2), NOPER(300,2), NROP(300,2), NDXOUT(20,2), * NOP(2), NERR(5), NVARY, NFIND, NPICK DIMENSION WGTLFT(300,2), WGTRGT(300,2) DOUBLE PRECISION D, DIJ, ONE, RHO, ARGL, ARGR, CONS, HALF, ZERO, * STOPX, VALUE, DERIVS, WGTLFT, WGTRGT DOUBLE PRECISION DSQRT DATA ONE /1.0D0/, HALF /0.5D0/, ZERO /0.0D0/ C DO 90 NALG=1,2 MOP = NOP(NALG) DO 80 I=1,MOP C COMPUTE THE I-TH VALUE AND ITS INPUT ARC WEIGHTS. ILOP = NLOP(I,NALG) MILOP = -ILOP IF (ILOP.LT.0) ARGL = CONS(MILOP,NALG) IF ((ILOP.GT.0) .AND. (ILOP.LE.100)) ARGL = D(ILOP) ILOPM = ILOP - 100 IF (ILOP.GT.100) ARGL = VALUE(ILOPM,NALG) IOPER = NOPER(I,NALG) IF (IOPER.GT.4) GO TO 10 IROP = NROP(I,NALG) MIROP = -IROP IF (IROP.LT.0) ARGR = CONS(MIROP,NALG) IF ((IROP.GT.0) .AND. (IROP.LE.100)) ARGR = D(IROP) IROPM = IROP - 100 IF (IROP.GT.100) ARGR = VALUE(IROPM,NALG) 10 GO TO (20, 30, 40, 50, 60, 70), IOPER C ADDITION 20 VALUE(I,NALG) = ARGL + ARGR WGTLFT(I,NALG) = ONE WGTRGT(I,NALG) = ONE GO TO 80 C SUBTRACTION 30 VALUE(I,NALG) = ARGL - ARGR WGTLFT(I,NALG) = ONE WGTRGT(I,NALG) = -ONE GO TO 80 C MULTIPLICATION 40 VALUE(I,NALG) = ARGL*ARGR WGTLFT(I,NALG) = ARGR WGTRGT(I,NALG) = ARGL GO TO 80 C DIVISION 50 IF (ARGR.EQ.ZERO) GO TO 170 VALUE(I,NALG) = ARGL/ARGR WGTLFT(I,NALG) = ONE/ARGR WGTRGT(I,NALG) = -VALUE(I,NALG)/ARGR GO TO 80 C SQUARE ROOT 60 IF (ARGL.LE.ZERO) GO TO 180 VALUE(I,NALG) = DSQRT(ARGL) WGTLFT(I,NALG) = HALF/VALUE(I,NALG) GO TO 80 C UNARY MINUS 70 VALUE(I,NALG) = -ARGL WGTLFT(I,NALG) = -ONE 80 CONTINUE 90 CONTINUE C C COMPUTE THE PARTIAL DERIVATIVES. DO 150 NALG=1,2 DO 140 J=1,NFIND JOUT = NDXOUT(J,NALG) DO 100 I=1,JOUT DERIVS(I,J,NALG) = ZERO 100 CONTINUE DERIVS(JOUT,J,NALG) = ONE JOUTP = JOUT + 1 DO 130 IBACK=1,JOUT I = JOUTP - IBACK C I = NDXOUT(J), NDXOUT(J)-1, ..., 1 DIJ = DERIVS(I,J,NALG) IF (DIJ.EQ.ZERO) GO TO 130 ILOPM = NLOP(I,NALG) - 100 IF (ILOPM.LE.0) GO TO 110 DERIVS(ILOPM,J,NALG) = DERIVS(ILOPM,J,NALG) + * WGTLFT(I,NALG)*DIJ 110 IOPER = NOPER(I,NALG) IF (IOPER.GT.4) GO TO 120 IROPM = NROP(I,NALG) - 100 IF (IROPM.LE.0) GO TO 120 DERIVS(IROPM,J,NALG) = DERIVS(IROPM,J,NALG) + * WGTRGT(I,NALG)*DIJ 120 DERIVS(I,J,NALG) = DIJ*VALUE(I,NALG) C UNARY MINUS OPERATIONS ARE CONSIDERED ERROR-FREE. IF (IOPER.EQ.6) DERIVS(I,J,NALG) = ZERO 130 CONTINUE 140 CONTINUE 150 CONTINUE IF ((NPICK.GT.0) .AND. (NFIND.GT.1)) CALL OMEGA2 IF ((NPICK.LT.0) .OR. (NFIND.EQ.1)) CALL GETER2 160 RETURN C C ATTEMPTED DIVISION BY ZERO. 170 NERR(1) = NERR(1) + 1 RHO = ZERO GO TO 160 C ATTEMPTED SQRT(V), V.LE.ZERO. 180 NERR(2) = NERR(2) + 1 RHO = ZERO GO TO 160 END SUBROUTINE GETER2 C C THIS SUBROUTINE COMPUTES RHO = TOP/BOTTOM, WHERE TOP AND BOTTOM C ARE THE FROBENIUS NORMS OF THE DERIVATIVES WRT ROUNDING ERRORS. C COMMON VALUE(300,2), DERIVS(300,20,2), D(30), CONS(20,2), RHO, * STOPX, NLOP(300,2), NOPER(300,2), NROP(300,2), NDXOUT(20,2), * NOP(2), NERR(5), NVARY, NFIND, NPICK DOUBLE PRECISION D, RHO, TOP, CONS, ZERO, STOPX, VALUE, BOTTOM, * DERIVS DOUBLE PRECISION DSQRT C C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C ALSO CHANGE 'DSQRT'. DATA ZERO /0.0D0/ C TOP = ZERO BOTTOM = ZERO DO 30 I=1,NFIND IOUT = NDXOUT(I,1) DO 10 J=1,IOUT TOP = TOP + DERIVS(J,I,1)**2 10 CONTINUE IOUT = NDXOUT(I,2) DO 20 J=1,IOUT BOTTOM = BOTTOM + DERIVS(J,I,2)**2 20 CONTINUE 30 CONTINUE INPICK = IABS(NPICK) IF ((INPICK.EQ.1) .AND. (BOTTOM.EQ.ZERO)) GO TO 50 IF (INPICK.EQ.1) RHO = DSQRT(TOP/BOTTOM) IF ((INPICK.EQ.2) .AND. (TOP.EQ.ZERO)) GO TO 50 IF (INPICK.EQ.2) RHO = DSQRT(BOTTOM/TOP) 40 RETURN 50 RHO = ZERO NERR(3) = NERR(3) + 1 GO TO 40 END SUBROUTINE OMEGA2 C WE WILL USE THE NOTATION C A = DERIVATIVE OF THE OUTPUT WITH RESPECT TO ROUNDING ERRORS C IN ONE OF THE TEST METHODS. C B = DERIVATIVE OF THE OUTPUT WITH RESPECT TO ROUNDING ERRORS C IN THE OTHER TEST METHOD. C THIS SUBROUTINE COMPUTES OMEGA(AK,BK), WHERE K DENOTES THE C APPROPRIATE 2-NORM UNIT BALL. COMMON VALUE(300,2), DERIVS(300,20,2), D(30), CONS(20,2), RHO, * STOPX, NLOP(300,2), NOPER(300,2), NROP(300,2), NDXOUT(20,2), * NOP(2), NERR(5), NVARY, NFIND, NPICK DOUBLE PRECISION VALUE,DERIVS,D,CONS,RHO,STOPX,DENOM,HUGESV * ,T,TEN,TINYSV,TRY,ZERO INTEGER NDCOL(20) DATA ZERO /0.0D0/, TEN /10.0D0/ C C FIRST REDUCE A AND B TO SQUARE MATRICES BY APPLYING ORTHOGONAL C TRANSFORMATIONS. DO 50 NALG = 1,2 DO 10 J = 1,NFIND NDCOL(J) = NDXOUT(J,NALG) 10 CONTINUE NROWS = NOP(NALG) IF (NROWS .LT. NFIND) GO TO 1001 IF (NROWS .GT. NFIND) CALL * SQUARE(DERIVS(1,1,NALG),NDCOL,NFIND,.TRUE.) IF (NROWS .GT. NFIND) GO TO 50 DO 30 J = 1,NFIND NDCOLJ = NDCOL(J) IF (NDCOLJ .GE. NFIND) GO TO 30 LIM = NDCOLJ + 1 DO 20 I = LIM,NFIND DERIVS(I,J,NALG) = ZERO 20 CONTINUE 30 CONTINUE 50 CONTINUE C C SECOND, DIAGONALIZE B. (ORTHOGONAL TRANSFORMATIONS IN THE C OUTPUT SPACE MUST ALSO BE APPLIED TO A.) THEN FORM (B INVERSE)*A, C UNLESS B IS SO ILL-CONDITIONED AS TO RENDER THE COMPUTATION C MEANINGLESS C NALG1 = NPICK NALG2 = 3 - NPICK CALL DIAGON(DERIVS(1,1,NALG2), DERIVS(1,1,NALG1), NFIND,.TRUE., * IERR) IF (IERR .NE. 0) GO TO 1002 IF (NFIND .EQ. 1) GO TO 108 HUGESV = DERIVS(1,1,NALG2) TINYSV = HUGESV DO 104 J = 2,NFIND TRY = DERIVS(J,J,NALG2) IF (TRY .LT. TINYSV) TINYSV = TRY IF (TRY .GT. HUGESV) HUGESV = TRY 104 CONTINUE T = TINYSV/TEN TRY = HUGESV + T IF (TRY .EQ. HUGESV) GO TO 1002 108 DO 120 J = 1,NFIND DENOM = DERIVS(J,J,NALG2) DO 110 I = 1,NFIND DERIVS(I,J,NALG1) = DERIVS(I,J,NALG1)/DENOM 110 CONTINUE 120 CONTINUE C C THIRD (AND LAST), FIND THE SINGULAR VALUES OF (B INVERSE)*A. C THE LARGEST IS OMEGA(AK,BK). C CALL DIAGON(DERIVS(1,1,NALG1),DERIVS(1,1,NALG2),NFIND,.FALSE., * IERR) IF (IERR .NE. 0) GO TO 1002 RHO = DERIVS(1,1,NALG1) IF (NFIND .EQ. 1) RETURN DO 130 I = 2,NFIND TRY = DERIVS(I,I,NALG1) IF (TRY .GT. RHO) RHO = TRY 130 CONTINUE RETURN C C THIS CODE IS REACHED IF EITHER ALGORITHM HAS FEWER ARITHMETIC C OPERATIONS THAN THE NUMBER OF OUTPUTS. 1001 NERR(4) = NERR(4) + 1 RHO = ZERO RETURN C C THIS CODE IS REACHED IF OMEGA CAN NOT BE COMPUTED ACCURATELY. 1002 NERR(5) = NERR(5) + 1 RHO = ZERO RETURN END SUBROUTINE DIAGON (B,A,NFIND,DOATOO,IERR) DOUBLE PRECISION B(300,19), A(300,19),BX,C,CS,EMM1,EL,F,G,ONE * ,P,R,S,SCALE,SHIFT,SL,SM,SMM1,SN,SUM,T,TEST,T1 * ,TWO,ZERO,ZTEST DOUBLE PRECISION DSQRT,DABS LOGICAL DOATOO DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C THIS SUBROUTINE USES ORTHOGONAL TRANSFORMATIONS TO REDUCE THE C SQUARE MATRIX B TO DIAGONAL FORM. IT IS INSPIRED BY, INDEED C MUCH OF IT IS COPIED FROM , SUBROUTINE SSVDC OF LINPACK. C IF DOATOO THEN ANY ORTHOGONAL TRANSFORMATIONS IN THE OUTPUT SPACE C MUST BE DONE TO A, TOO. OTHERWISE, A IS NOT REFERENCED IN ANY WAY. C C FIRST REDUCE B TO BIDIAGONAL FORM. C IF (NFIND .EQ. 1) GO TO 620 LIM = NFIND -1 DO 200 K = 1,LIM C PERFORM AN ORTHOGONAL TRANSFORMATION IN THE OUTPUT SPACE. KP1 = K + 1 SUM = ZERO DO 10 I = K,NFIND SUM = SUM + B(K,I)**2 10 CONTINUE IF (SUM .EQ. ZERO) GO TO 100 S = DSQRT(SUM) IF (B(K,K) .LT. ZERO) S = -S B(K,K) = B(K,K) + S P = S*B(K,K) DO 40 J = KP1,NFIND T = ZERO DO 20 I = K,NFIND T = T + B(K,I)*B(J,I) 20 CONTINUE T = T/P DO 30 I = K,NFIND B(J,I) = B(J,I) - T*B(K,I) 30 CONTINUE 40 CONTINUE IF (.NOT.DOATOO) GO TO 80 DO 70 J = 1,NFIND T = ZERO DO 50 I = K,NFIND T = T + B(K,I)*A(J,I) 50 CONTINUE T = T/P DO 60 I = K,NFIND A(J,I) = A(J,I) - T*B(K,I) 60 CONTINUE 70 CONTINUE 80 B(K,K) = -S C 100 IF (K .EQ. LIM) GO TO 200 C PERFORM AN ORTHOGONAL TRANSFORMATION IN THE ERROR SPACE. SUM = ZERO DO 110 I = KP1,NFIND SUM = SUM + B(I,K)**2 110 CONTINUE IF (SUM .EQ. ZERO) GO TO 200 S = DSQRT(SUM) IF (B(KP1,K) .LT. ZERO) S = -S B(KP1,K) = B(KP1,K) + S P = S*B(KP1,K) DO 140 J = KP1,NFIND T = ZERO DO 120 I = KP1,NFIND T = T + B(I,K)*B(I,J) 120 CONTINUE T = T/P DO 130 I = KP1,NFIND B(I,J) = B(I,J) - T*B(I,K) 130 CONTINUE 140 CONTINUE B(KP1,K) = -S 200 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MAXIT = 30 M = NFIND ITER = 0 360 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT IF (M .EQ. 0) GO TO 620 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, GO TO ERROR EXIT. C IF (ITER .GE. MAXIT) GO TO 1000 C C THIS SECTION OF THE PROGRAM INSPECTS FOR NEGLIGIBLE ELEMENTS OF B. C ON COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF B(M,M) AND B(L,L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF B(L,L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF B(L,L-1) IS NEGLIGIBLE, L.LT.M, AND B(L,L),..., C B(M,M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF B(M,M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 390 LL = 1,M L = M - LL C ...EXIT IF (L .EQ. 0) GO TO 400 TEST = DABS(B(L,L)) + DABS(B(L+1,L+1)) ZTEST = TEST + DABS(B(L+1,L)) IF (ZTEST .NE. TEST) GO TO 380 B(L+1,L) = ZERO C ......EXIT GO TO 400 380 CONTINUE 390 CONTINUE 400 CONTINUE IF (L .NE. M - 1) GO TO 410 KASE = 4 GO TO 480 410 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 430 LLS = LP1, MP1 LS = M - LLS + LP1 C .....EXIT IF (LS .EQ. L) GO TO 440 TEST = ZERO IF (LS .NE. M) TEST = TEST + DABS(B(LS+1,LS)) IF (LS .NE. L + 1) TEST = TEST + DABS(B(LS,LS-1)) ZTEST = TEST + DABS(B(LS,LS)) IF (ZTEST .NE. TEST) GO TO 420 B(LS,LS) = ZERO C ....EXIT GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (LS .NE. L) GO TO 450 KASE = 3 GO TO 470 450 CONTINUE IF (LS .NE. M) GO TO 460 KASE = 1 GO TO 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (490,520,540,570), KASE C C DEFLATE NEGLIGIBLE B(M,M). C 490 CONTINUE MM1 = M - 1 F = B(M,M-1) B(M,M-1) = ZERO DO 510 KK = L,MM1 K = MM1 - KK + L T1 = B(K,K) SCALE = DABS(F) + DABS(T1) IF (SCALE .NE. ZERO) GO TO 498 CS = ONE SN = ZERO R = ZERO GO TO 499 498 R = SCALE*DSQRT((F/SCALE)**2 + (T1/SCALE)**2) CS = T1/R SN = F/R 499 B(K,K) = R IF (K .EQ. L) GO TO 500 F = -SN*B(K,K-1) B(K,K-1) = CS*B(K,K-1) 500 CONTINUE 510 CONTINUE GO TO 610 C C SPLIT AT NEGLIGIBLE B(L,L). C 520 CONTINUE LM1 = L - 1 F = B(L,L-1) B(L,L-1) = ZERO DO 530 K = L,M T1 = B(K,K) SCALE = DABS(F) + DABS(T1) IF (SCALE .NE. ZERO) GO TO 523 CS = ONE SN = ZERO R = ZERO GO TO 524 523 R = SCALE*DSQRT((F/SCALE)**2 + (T1/SCALE)**2) CS = T1/R SN = F/R 524 B(K,K) = R IF (.NOT.DOATOO) GO TO 528 DO 525 IROW = 1,NFIND T = -SN*A(IROW,K) + CS*A(IROW,LM1) A(IROW,K) = CS*A(IROW,K) + SN*A(IROW,LM1) A(IROW,LM1) = T 525 CONTINUE 528 IF (K .EQ. M) GO TO 530 F = -SN*B(K+1,K) B(K+1,K) = CS*B(K+1,K) 530 CONTINUE GO TO 610 C C PERFORM ONE QR STEP. C 540 CONTINUE C C CALCULATE THE SHIFT. C SCALE = DABS(B(M,M)) + DABS(B(M-1,M-1)) + DABS(B(M,M-1)) * + DABS(B(L,L)) + DABS(B(L+1,L)) SM = B(M,M)/SCALE SMM1 = B(M-1,M-1)/SCALE EMM1 = B(M,M-1)/SCALE SL = B(L,L)/SCALE EL = B(L+1,L)/SCALE BX = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/TWO C = (SM*EMM1)**2 SHIFT = ZERO IF (BX .EQ. ZERO .AND. C .EQ. ZERO) GO TO 550 SHIFT = DSQRT(BX**2+C) IF (BX .LT. ZERO) SHIFT = -SHIFT SHIFT = C/(BX + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M -1 DO 560 K = L,MM1 SCALE = DABS(F) + DABS(G) IF (SCALE .NE. ZERO) GO TO 552 CS = ONE SN = ZERO R = ZERO GO TO 553 552 R = SCALE*DSQRT((F/SCALE)**2 + (G/SCALE)**2) CS = F/R SN = G/R 553 IF (K .NE. L) B(K,K-1) = R F = CS*B(K,K) + SN*B(K+1,K) B(K+1,K) = CS*B(K+1,K) - SN*B(K,K) G = SN*B(K+1,K+1) B(K+1,K+1) = CS*B(K+1,K+1) SCALE = DABS(F) + DABS(G) IF (SCALE .NE. ZERO) GO TO 556 CS = ONE SN = ZERO R = ZERO GO TO 557 556 R = SCALE*DSQRT((F/SCALE)**2 + (G/SCALE)**2) CS = F/R SN = G/R 557 B(K,K) = R F = CS*B(K+1,K) + SN*B(K+1,K+1) B(K+1,K+1) = -SN*B(K+1,K) + CS*B(K+1,K+1) IF (.NOT.DOATOO) GO TO 559 DO 558 IROW = 1,NFIND T = -SN*A(IROW,K) + CS*A(IROW,K+1) A(IROW,K) = CS*A(IROW,K) + SN*A(IROW,K+1) A(IROW,K+1) = T 558 CONTINUE 559 IF (K .EQ.MM1) GO TO 560 G = SN*B(K+2,K+1) B(K+2,K+1) = CS*B(K+2,K+1) 560 CONTINUE B(M,M-1) = F ITER = ITER + 1 GO TO 610 C C CONVERGENCE C 570 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE. C IF (B(L,L) .LT. ZERO) B(L,L) = -B(L,L) 600 CONTINUE ITER = 0 M = M - 1 610 CONTINUE GO TO 360 620 CONTINUE IERR = 0 RETURN 1000 IERR = 1 RETURN END SUBROUTINE SQUARE (A,NDCOL,NFIND,SWAP) C THIS PROCEDURE APPLIES HOUSEHOLDER TRANSFORMATIONS TO A PORTION C OF THE 'DERIVS' MATRIX, REDUCING IT TO AN NFIND-BY-NFIND MATRIX. C A IS THE MATRIX TO BE REDUCED. C NDCOL(I) IS THE END OF COLUMN I. C SWAP = .TRUE. IF THE COLUMNS NEED NOT BE IN NONDECREASING C ORDER OF LENGTH. DOUBLE PRECISION A(300,19),P,S,T,SUM,ZERO DOUBLE PRECISION DSQRT INTEGER NDCOL(20), ICOL(20) LOGICAL SWAP DATA ZERO /0.0D0/ DO 10 I = 1,NFIND 10 ICOL(I) = I IF (NFIND.EQ.1 .OR. .NOT.SWAP) GO TO 35 C BUBBLE SORT. ORDER COLUMNS BY INCREASING LENGTH. C THE K-TH SHORTEST COLUMN IS LOCATED IN A(*,ICOL(K)). NFM1 = NFIND - 1 DO 30 NSWEEP = 1,NFM1 LAST = NFIND - NSWEEP DO 20 I = 1,LAST ICI = ICOL(I) ICIP1 = ICOL(I+1) IF (NDCOL(ICIP1) .GE. NDCOL(ICI)) GO TO 20 ICOL(I) = ICIP1 ICOL(I+1) = ICI 20 CONTINUE 30 CONTINUE C 35 DO 90 KK = 1,NFIND K = ICOL(KK) LIM = NDCOL(K) SUM = ZERO DO 40 I = KK,LIM SUM = SUM + A(I,K)**2 40 CONTINUE S = DSQRT(SUM) IF (SUM .EQ. ZERO) GO TO 70 IF (A(KK,K) .LT. ZERO) S = -S A(KK,K) = A(KK,K) + S P = S*A(KK,K) IF (KK .EQ. NFIND) GO TO 90 KKP1 = KK + 1 DO 60 JJ = KKP1,NFIND J = ICOL(JJ) T = ZERO DO 50 I = KK,LIM T = T + A(I,K)*A(I,J) 50 CONTINUE T = T/P DO 60 I = KK,LIM A(I,J) = A(I,J) - T*A(I,K) 60 CONTINUE 70 DO 80 I = KKP1,NFIND A(I,K) = ZERO 80 CONTINUE 90 A(KK,K) = -S RETURN END SUBROUTINE GRAM(S, N, NDIM, IERR) C APPLIES THE MODIFIED GRAM-SCHMIDT METHOD TO THE FIRST N C COLUMNS OF S (AS N-VECTORS). DOUBLE PRECISION S(NDIM,NDIM) DOUBLE PRECISION SUM, ZERO DOUBLE PRECISION DSQRT C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C ALSO CHANGE 'DSQRT'. DATA NOUT /6/, ZERO /0.0D0/ C DO 60 J=1,N SUM = ZERO DO 10 I=1,N SUM = SUM + S(I,J)**2 10 CONTINUE IF (SUM.EQ.ZERO) GO TO 80 SUM = DSQRT(SUM) DO 20 I=1,N S(I,J) = S(I,J)/SUM 20 CONTINUE IF (J.EQ.N) GO TO 60 JP = J + 1 DO 50 K=JP,N SUM = ZERO DO 30 I=1,N SUM = SUM + S(I,J)*S(I,K) 30 CONTINUE DO 40 I=1,N S(I,K) = S(I,K) - SUM*S(I,J) 40 CONTINUE 50 CONTINUE 60 CONTINUE IERR = 0 70 RETURN C 80 WRITE (NOUT,99999) IERR = 1 GO TO 70 99999 FORMAT (47H RANK DEFICIENCY IN SUBROUTINE GRAM. TERMINATE.) END SUBROUTINE MAXIM(F, D, NVARY) C A VARIANT OF ROSENBROCK'S METHOD, PP. 21-22 OF 'NUMERICAL C METHODS FOR UNCONSTRAINED OPTIMIZATION', W. MURRAY,ED. C ACADEMIC PRESS, 1972. INTEGER NITER(2) DOUBLE PRECISION P(30,30), DEL(30), EPS(2), DOLD(30) DOUBLE PRECISION D(30), DSAVE(30), BIGDEL(30) DOUBLE PRECISION B, F, ONE, RHO, BETA, DELI, SIZE, ZERO, ALPHA, * DELTA DOUBLE PRECISION DNORM, CHANGE, RHOSAV, THEMIN, DABSBD DOUBLE PRECISION DABS C C P'S COLUMNS ARE THE SEARCH DIRECTIONS. C DOLD STORES THE POSITION OF D AFTER THE MOST RECENT ROTATION. C DSAVE IS THE SAVE AREA FOR D WHEN A STEP IS TRIED. C DEL(I) IS THE STEP LENGTH IN THE I-TH DIRECTION. C BIGDEL(I) IS THE ALGEBRAIC SUM OF ALL SUCCESSFUL STEPS IN THE I-TH C DIRECTION. C C THESE VALUES DEPEND UPON THE PRECISION AND THE INSTALLATION. C FOR SINGLE PRECISION OMIT 'D0' FROM THE FOLLOWING CONSTANTS. C ALSO CHANGE 'DABS'. DATA ALPHA /3.0D0/, BETA /-0.5D0/, CHANGE /20.0D0/, EPS(1) * /0.03D0/, EPS(2) /0.001D0/, ONE /1.0D0/, ZERO /0.0D0/, NITER(1) * /5/, NITER(2) /9/, NFLAG /1/, NOUT /6/ C C INITIALIZE THE SEARCH DIRECTIONS TO THE COORDINATE AXES. DO 20 I=1,NVARY DO 10 J=1,NVARY P(I,J) = ZERO 10 CONTINUE P(I,I) = ONE 20 CONTINUE RHO = F(D,IERR) IF (IERR.EQ.1) GO TO 150 C C NROT-1 IS THE CURRENT NUMBER OF ROTATIONS OF THE SEARCH DIRECTIONS. C THE SEARCH PROCEDURE IS REFINED IF RHO .GT. CHANGE. DO 140 NROT=1,10 IF (RHO.GT.CHANGE) NFLAG = 2 DNORM = ZERO DO 30 I=1,NVARY SIZE = DABS(D(I)) IF (SIZE.GT.DNORM) DNORM = SIZE DOLD(I) = D(I) 30 CONTINUE DELTA = EPS(NFLAG)*DNORM DO 40 I=1,NVARY BIGDEL(I) = ZERO DEL(I) = DELTA 40 CONTINUE NTIMES = NITER(NFLAG) DO 90 ITER=1,NTIMES DO 80 I=1,NVARY DELI = DEL(I) RHOSAV = RHO DO 50 K=1,NVARY DSAVE(K) = D(K) D(K) = D(K) + DELI*P(K,I) 50 CONTINUE RHO = F(D,IERR) IF (IERR.EQ.1) GO TO 150 IF (RHO.GT.RHOSAV) GO TO 70 C C SEARCH WAS UNSUCCESSFUL. DEL(I) = BETA*DELI DO 60 K=1,NVARY D(K) = DSAVE(K) 60 CONTINUE RHO = RHOSAV GO TO 80 C C SEARCH WAS SUCCESSFUL. 70 BIGDEL(I) = BIGDEL(I) + DELI DEL(I) = ALPHA*DELI 80 CONTINUE 90 CONTINUE IF (NROT.EQ.10) GO TO 150 IF (NVARY.EQ.1) GO TO 140 C C ROTATE THE SEARCH DIRECTIONS. C GUARANTEE SOME CHANGE IN EACH DIRECTION. IF INSUFFICIENT PROGRESS C IS MADE, THEN TERMINATE THE SEARCH. THEMIN = EPS(NFLAG)*DELTA MOVE = 0 DO 100 I=1,NVARY DABSBD = DABS(BIGDEL(I)) IF (DABSBD.GT.THEMIN) MOVE = 1 IF (DABSBD.LE.THEMIN) BIGDEL(I) = THEMIN 100 CONTINUE IF (MOVE.EQ.0) GO TO 160 C C SET THE J-TH COLUMN OF P TO THE SUM OF THE SUCCESSFUL STEPS IN THE C OLD DIRECTIONS J, J-1,..., NVARY. SINCE THE OLD DIRECTIONS ARE C ORTHOGONAL AND SINCE THE BIGDELS ARE NONZERO, THE NEW COLUMNS ARE C LINEARLY INDEPENDENT. B = BIGDEL(NVARY) DO 110 I=1,NVARY P(I,NVARY) = B*P(I,NVARY) 110 CONTINUE NM1 = NVARY - 1 DO 130 JBACK=1,NM1 J = NVARY - JBACK B = BIGDEL(J) DO 120 I=1,NVARY P(I,J) = B*P(I,J) + P(I,J+1) 120 CONTINUE 130 CONTINUE C C ORTHOGONALIZE. THE J-TH COLUMN OF P IS THE MOST PROFITABLE C SEARCH DIRECTION ORTHOGONAL TO COLUMNS 1, 2,..., J-1. CALL GRAM(P, NVARY, 30, IERR) IF (IERR.EQ.1) GO TO 160 140 CONTINUE 150 RETURN C 160 WRITE (NOUT,99999) GO TO 150 99999 FORMAT (/10X, 35HINSUFFICIENT PROGRESS. SEARCH ENDS.) END ==-------- CS 1 TRIANGULAR MATRIX INVERSION ------------------------- TEST (N=4) C COMPUTE S = (T INVERSE), WHERE T IS A NONSINGULAR, UPPER C TRIANGULAR MATRIX. DIMENSION (S(N,N), T(N,N)) C C INPUT T. FOR J = 1 TO N BY 1 FOR I = J TO 1 BY -1 INPUT (T(I,J)) END (I) END (J) C C COMPUTE S. FOR K = 1 TO N BY 1 S(K,K) = 1.0/T(K,K) FOR I = K-1 TO 1 BY -1 S(I,K) = -SUMMATION(T(I,J)*S(J,K), J = I+1 TO K)/T(I,I) END (I) END (K) C C OUTPUT S. FOR J = 1 TO N BY 1 FOR I = J TO 1 BY -1 OUTPUT (S(I,J)) END (I) END (J) *STOP ==-------- CS 2 THE NORMAL EQUATIONS -------------------------------- C USE THE NORMAL EQUATIONS TO SOLVE THE LINEAR LEAST SQUARES PROBLEM. TEST (M = 4, N = 3) DIMENSION (A(M,N), T(N,N), L(N,N), B(M), S(N), X(N), Y(N)) INPUT (A,B) C C FORM THE NORMAL EQUATIONS. FOR I = 1 TO N BY 1 FOR J = 1 TO I BY 1 T(I,J) = SUMMATION(A(K,I)*A(K,J),K=1 TO M) END (J) S(I) = SUMMATION(A(K,I)*B(K), K = 1 TO M) END (I) C C =================================================================== COMPOSITION C =================================================================== C C USE THE CHOLESKY METHOD. FACTOR T AS L*(L TRANSPOSE). FOR I = 1 TO N BY 1 FOR J = 1 TO I-1 BY 1 TEMP = T(I,J) - SUMMATION(L(I,K)*L(J,K), K = 1 TO J-1) L(I,J) = TEMP/L(J,J) END (J) TEMP = T(I,I) - SUMMATION(L(I,K)*L(I,K),K = 1 TO I-1) L(I,I) = SQRT (TEMP) END (I) C C FORWARD SUBSTITUTION. SOLVE L*Y = B. FOR I = 1 TO N BY 1 Y(I) = (S(I) - SUMMATION(L(I,J)*Y(J), J = 1 TO I-1))/L(I,I) END (I) C C BACK SUBSTITUTION. SOLVE (L TRANSPOSE)*X = Y. FOR I = N TO 1 BY -1 X(I) = (Y(I) - SUMMATION(L(J,I)*X(J), J = I+1 TO N))/L(I,I) END (I) OUTPUT (X) *STOP ==-------- CS 3 THE HAT MATRIX, METHOD N ---------------------------- C COMPUTE THE DIAGONAL ENTRIES OF A-HAT FROM THE NORMAL EQUATIONS. TEST (M=4,N=3) DIMENSION (A(M,N), R(N,N), Z(N)) INPUT (A) C C FORM THE NORMAL EQUATIONS. FOR I = 1 TO N BY 1 FOR J = I TO N BY 1 R(I,J) = SUMMATION (A(K,I)*A(K,J), K = 1 TO M) END (J) END (I) C C PERFORM THE CHOLESKY (SQUARE ROOT) FACTORIZATION. FOR I = 1 TO N BY 1 R(I,I) = SQRT(R(I,I) - SUMMATION(R(K,I)*R(K,I),K=1 TO I-1)) FOR J = I+1 TO N BY 1 R(I,J) = R(I,J) - SUMMATION(R(K,I)*R(K,J),K=1 TO I-1) R(I,J) = R(I,J)/R(I,I) END (J) END (I) C C COMPUTE THE DIAGONAL ENTRIES OF A-HAT. FOR I = 1 TO M BY 1 TOTAL = 0.0 FOR J = 1 TO N BY 1 Z(J) = A(I,J) - SUMMATION(R(L,J)*Z(L),L = 1 TO J-1) Z(J) = Z(J)/R(J,J) TOTAL = TOTAL + Z(J)*Z(J) END (J) OUTPUT (TOTAL) END (I) *STOP ==-------- CS 3 THE HAT MATRIX, METHOD G ---------------------------- C COMPUTE THE DIAGONAL ENTRIES OF A-HAT BY GIVENS METHOD. TEST (M=4,N=3) DIMENSION (A(M,N), R(M,N), D(M), Z(N)) INPUT (A) C C FIRST, TRANSFER A TO R AND REDUCE IT TO UPPER TRIANGULAR FORM. FOR I = 1 TO M BY 1 D(I) = 1.0 FOR K = 1 TO N BY 1 R(I,K) = A(I,K) END (K) FOR J = 1 TO N BY 1 IF J .LT. I THEN C REDUCE A(I,J) USING A(J,J) F = R(I,J)/R(J,J) E = (D(J)/D(I))*F C = 1.0 + E*F D(J) = C*D(J) D(I) = C*D(I) FOR K = J TO N BY 1 SAVE = R(J,K) R(J,K) = R(J,K) + E*R(I,K) R(I,K) = R(I,K) - F*SAVE END (K) END END (J) END (I) C C SECOND, COMPUTE THE DIAGONAL ENTRIES OF A-HAT. FOR I = 1 TO M BY 1 C SOLVE (R TRANSPOSE)*Z = (I-TH ROW OF A) TRANSPOSE, C AND OUTPUT Z TRANSPOSE Z. TOTAL = 0.0 FOR J = 1 TO N BY 1 Z(J) = A(I,J) - SUMMATION(R(L,J)*Z(L),L = 1 TO J-1) Z(J) = Z(J)/R(J,J) TOTAL = TOTAL + D(J)*Z(J)*Z(J) END (J) OUTPUT (TOTAL) END (I) *STOP ==-------- CS 4 THE CHOLESKY METHOD, LLT ---------------------------- C USE THE CHOLESKY L*(L TRANSPOSE) FACTORIZATION OF THE SYMMETRIC, C POSITIVE DEFINITE MATRIX A TO SOLVE THE LINEAR SYSTEM A*X = B, C WHERE L IS LOWER TRIANLULAR. TEST (N=4) DIMENSION (A(N,N), L(N,N), B(N), X(N), Y(N)) FOR J = 1 TO N BY 1 FOR I = J TO N BY 1 INPUT (A(I,J)) END (I) END (J) INPUT (B) C C FACTOR A AS L*(L TRANSPOSE). FOR I = 1 TO N BY 1 FOR J = 1 TO I-1 BY 1 TEMP = A(I,J) - SUMMATION(L(I,K)*L(J,K), K = 1 TO J-1) L(I,J) = TEMP/L(J,J) END (J) TEMP = A(I,I) - SUMMATION(L(I,K)*L(I,K),K = 1 TO I-1) L(I,I) = SQRT (TEMP) END (I) C C FORWARD SUBSTITUTION. SOLVE L*Y = B. FOR I = 1 TO N BY 1 Y(I) = (B(I) - SUMMATION(L(I,J)*Y(J), J = 1 TO I-1))/L(I,I) END (I) C C BACK SUBSTITUTION. SOLVE (L TRANSPOSE)*X = Y. FOR I = N TO 1 BY -1 X(I) = (Y(I) - SUMMATION(L(J,I)*X(J), J = I+1 TO N))/L(I,I) END (I) OUTPUT (X) *STOP ==-------- CS 4 THE CHOLESKY METHOD, LDLT --------------------------- C USE THE CHOLESKY L*D*(L TRANSPOSE) FACTORIZATION OF THE SYMMETRIC, C POSITIVE DEFINITE MATRIX A TO SOLVE THE LINEAR SYSTEM A*X = B, C WHERE L IS UNIT LOWER TRIANGULAR AND D IS DIAGONAL. TEST (N=4) DIMENSION (A(N,N), L(N,N), D(N), B(N), X(N), Y(N)) FOR J = 1 TO N BY 1 FOR I = J TO N BY 1 INPUT (A(I,J)) END (I) END (J) INPUT (B) C C FACTOR A AS L*D*(L TRANSPOSE). FOR I = 1 TO N BY 1 FOR J = 1 TO I-1 BY 1 A(I,J) = A(I,J) - SUMMATION(A(I,K)*L(J,K), K = 1 TO J-1) L(I,J) = A(I,J)/D(J) END (J) D(I) = A(I,I) - SUMMATION(A(I,K)*L(I,K),K = 1 TO I-1) END (I) C C FORWARD SUBSTITUTION. SOLVE L*Y = B. FOR I = 1 TO N BY 1 Y(I) = B(I) - SUMMATION(L(I,J)*Y(J), J = 1 TO I-1) END (I) C C BACK SUBSTITUTION. SOLVE D*(L TRANSPOSE)*X = Y. FOR I = N TO 1 BY -1 X(I) = Y(I)/D(I) - SUMMATION(L(J,I)*X(J), J = I+1 TO N) END (I) OUTPUT (X) *STOP ==------- CS 5 GAUSSIAN ELIMINATION --------------------------------- C GAUSSIAN ELIMINATION. TEST (N=4) DIMENSION (A(N,N), B(N), X(N)) INPUT (A,B) C C ELIMINATION. FOR K = 1 TO N-1 BY 1 FOR I = K+1 TO N BY 1 AMULT = A(I,K)/A(K,K) FOR J = K+1 TO N BY 1 A(I,J) = A(I,J) - AMULT*A(K,J) END (J) B(I) = B(I) - AMULT*B(K) END (I) END (K) C C BACK SUBSTITUTION. FOR I = N TO 1 BY -1 X(I) = (B(I) - SUMMATION (A(I,J)*X(J),J=I+1 TO N))/A(I,I) END (I) OUTPUT (X) *STOP ==-------- CS 6 GAUSSIAN ELIMINATION WITH ITERATIVE IMPROVEMENT ----- C GAUSSIAN ELIMINATION WITH ITERATIVE IMPROVEMENT. TEST (N = 4) DIMENSION (A(N,N), LU(N,N), B(N), R(N), X(N), Y(N), Z(N)) INPUT (A,B) C C COPY A TO LU. FOR I = 1 TO N BY 1 FOR J = 1 TO N BY 1 LU(I,J) = A(I,J) END (J) END(I) C FACTOR A AS L*U. FOR K = 1 TO N-1 BY 1 FOR I = K+1 TO N BY 1 LU(I,K) = LU(I,K)/LU(K,K) FOR J = K+1 TO N BY 1 LU(I,J) = LU(I,J) - LU(I,K)*LU(K,J) END (J) END (I) END (K) C SOLVE L*Y = B. FOR I = 1 TO N BY 1 Y(I) = B(I) - SUMMATION(LU(I,J)*Y(J), J = 1 TO I-1) END (I) C SOLVE U*X = Y. FOR I = N TO 1 BY -1 T = Y(I) - SUMMATION(LU(I,J)*X(J), J = I+1 TO N) X(I) = T/LU(I,I) END(I) C COMPUTE THE RESIDUAL R = B - A*X. FOR I = 1 TO N BY 1 R(I) = B(I) - SUMMATION(A(I,J)*X(J), J = 1 TO N) END (I) C SOLVE L*Y = R. FOR I = 1 TO N BY 1 Y(I) = R(I) - SUMMATION(LU(I,J)*Y(J), J = 1 TO I-1) END (I) C SOLVE U*Z = Y. FOR I = N TO 1 BY -1 T = Y(I) - SUMMATION(LU(I,J)*Z(J), J = I+1 TO N) Z(I) = T/LU(I,I) END (I) C SET X = X + Z. FOR I = 1 TO N BY 1 X(I) = X(I) + Z(I) END (I) C OUTPUT(X) *STOP ==-------- CS7 GAUSS-JORDAN ELIMINATION ----------------------------- TEST (N=4) C GAUSS-JORDAN ELIMINATION. DIMENSION (A(N,N), B(N), X(N), AMULT(N,N)) INPUT (A,B) C C ELIMINATE. FOR K = 1 TO N BY 1 FOR I = 1 TO N BY 1 IF I.NE.K THEN AMULT(I,K) = A(I,K)/A(K,K) FOR J = K+1 TO N BY 1 A(I,J) = A(I,J) - AMULT(I,K)*A(K,J) END (J) B(I) = B(I) - AMULT(I,K)*B(K) END END (I) END (K) C C SOLVE THE DIAGONAL SYSTEM. FOR I = 1 TO N BY 1 X(I) = B(I)/A(I,I) END (I) OUTPUT (X) *STOP ==-------- CS 8 HOUSEHOLDER TRANSFORMATIONS FOR LEAST-SQUARES PROBLEMS C SOLUTION OF THE LINEAR LEAST SQUARES PROBLEM BY HOUSEHOLDER C TRANSFORMATIONS. TEST (M=4,N=3) DIMENSION (A(M,N), B(M), X(N), DIAG(N)) INPUT (A,B) C FOR K = 1 TO N BY 1 C COMPUTE THE K-TH HOUSEHOLDER TRANSFORMATION. SUM = SUMMATION (A(I,K)*A(I,K), I = K TO M) S = SQRT(SUM) C WE COULD ALSO USE S = -SQRT(SUM) DIAG (K) = -S A(K,K) = A(K,K) + S P = S*A(K,K) FOR J = K+1 TO N BY 1 C TRANSFORM THE REMAINING COLUMNS AND B. T = SUMMATION (A(I,K)*A(I,J), I = K TO M)/P FOR I = K TO M BY 1 A(I,J) = A(I,J) - T*A(I,K) END (I) END (J) T = SUMMATION (A(I,K)*B(I), I = K TO M)/P FOR I = K TO M BY 1 B(I) = B(I) - T*A(I,K) END (I) END (K) C C BACK SUBSTITUTION. FOR I = N TO 1 BY -1 X(I) = (B(I) - SUMMATION (A(I,J)*X(J),J=I+1 TO N))/DIAG(I) END (I) OUTPUT (X) *STOP ==-------- CS 9 RATIONAL QR METHODS, ORTEGA-KAISER ------------------ C THE ORTEGA-KAISER RATIONAL QR METHOD. TEST (N=5, NMINUS=4) DIMENSION (A(N), BSQ(NMINUS)) INPUT (A, BSQ) C H = A(1) SSQ = 0.0 FOR I = 1 TO N-1 BY 1 PSQ = H*H/(1.0 - SSQ) RSQ = PSQ + BSQ(I) IF I .NE. 1 THEN BSQ(I-1) = RSQ*SSQ END SSQ = BSQ(I)/RSQ U = SSQ*(H + A(I+1)) A(I) = H + U H = A(I+1) - U END (I) PSQ = H*H/(1.0 - SSQ) BSQ(N-1) = PSQ*SSQ A(N) = H C OUTPUT (A, BSQ) *STOP ==-------- CS 9 RATIONAL QR METHODS, REINSCH ------------------------ C THE REINSCH RATIONAL QR METHOD. TEST (N=5, NMINUS=4) DIMENSION (A(N), BSQ(NMINUS)) INPUT (A, BSQ) C G = A(1) H = A(1) SSQ = 0.0 FOR I = 1 TO N-1 BY 1 PSQ = G*H RSQ = PSQ + BSQ(I) IF I .NE. 1 THEN BSQ(I-1) = RSQ*SSQ END SSQ = BSQ(I)/RSQ U = SSQ*(H + A(I+1)) A(I) = H + U G = A(I+1) - BSQ(I)/G H = G*PSQ/RSQ END (I) PSQ = G*H BSQ(N-1) = PSQ*SSQ A(N) = H C OUTPUT (A, BSQ) *STOP ==-------- CS 10 DOWNDATING THE QR FACTORIZATION -------------------- C THE FAST GIVENS METHOD TO 'DOWNDATE' THE Q*D*R FACTORIZATION OF A C MATRIX A. HERE THE METHOD IS USED IN THE CONTEXT OF SOLVING THE C LINEAR LEAST SQUARES PROBLEM. TEST (M=5,MPLUS=6,N=3) DIMENSION ( A(MPLUS,N), B(MPLUS), D(MPLUS), X(N) ) FOR J = 1 TO N BY 1 FOR I = 1 TO M BY 1 INPUT ( A(I,J) ) END (I) END (J) FOR I = 1 TO M BY 1 INPUT ( B(I) ) END (I) FOR I = 1 TO M BY 1 D(I) = 1.0 END (I) C COPY THE LAST ROW AND GIVE IT WEIGHT -1. FOR J = 1 TO N BY 1 A(MPLUS,J) = A(M,J) END (J) B(MPLUS) = B(M) D(MPLUS) = -1.0 C C REDUCE A AND B. FOR I = 1 TO MPLUS BY 1 FOR J = 1 TO N BY 1 IF J .LT. I THEN C REDUCE A(I,J) TO ZERO USING A(J,J) F = A(I,J)/A(J,J) E = (D(J)/D(I))*F C = 1.0 + E*F D(J) = C*D(J) D(I) = C*D(I) FOR K = J TO N BY 1 SAVE = A(J,K) A(J,K) = A(J,K) + E*A(I,K) A(I,K) = A(I,K) - F*SAVE END (K) SAVE = B(J) B(J) = B(J) + E*B(I) B(I) = B(I) - F*SAVE END END (J) C =================================================================== IF I.EQ.M THEN COMPOSITION END C =================================================================== END (I) C C BACK SUBSTITUTION FOR I = N TO 1 BY -1 X(I) = (B(I) - SUMMATION(A(I,J)*X(J), J = I+1 TO N))/A(I,I) END (I) OUTPUT (X) *STOP ==-------- CS 11 THE CHARACTERISTIC POLYNOMIAL ---------------------- C DANILEVSKII'S METHOD FOR COMPUTING THE COEFFICIENTS OF THE C CHARACTERISTIC POLYNOMIAL OF A MATRIX. SEE PAGE 253 OF C 'COMPUTATIONAL METHODS OF LINEAR ALGEBRA' BY FADDEEV AND C FADDEEVA, W.H. FREEMAN AND COMPANY, SAN FRANCISCO, 1963. TEST (N=4) DIMENSION (A(N,N),B(N,N)) INPUT (A) FOR K = 1 TO N-1 BY 1 FOR J = 1 TO N BY 1 B(K+1,J) = A(K+1,J)/A(K+1,K) END (J) FOR I = 1 TO N BY 1 IF I .NE. K+1 THEN FOR J = 1 TO N BY 1 B(I,J) = A(I,J) - A(I,K)*B(K+1,J) END (J) END END (I) FOR I = 1 TO N BY 1 A(I,K+1) = SUMMATION(B(I,J)*A(J,K), J = 1 TO N) END (I) FOR J = 1 TO N BY 1 IF J .NE. K+1 THEN FOR I = 1 TO N BY 1 A(I,J) = B(I,J) END (I) END END (J) END (K) C =================================================================== COMPOSITION C =================================================================== FOR I = 1 TO N BY 1 OUTPUT (A(I,N)) END (I) *STOP ==-------- CS 12 REPRESENTATIONS OF SYMMETRIC MATRICES -------------- ==-------- XPRMNT, SQUARE AND SQUARE ROOT DOUBLE PRECISION FUNCTION XPRMNT(DERIV,VALND,NDXOUT,NVARY, * NODES,NFIND) DOUBLE PRECISION DERIV(300,20), VALND(300) DOUBLE PRECISION DNORM, DUMMY, FNORM, SMALL, T, ZERO DOUBLE PRECISION DABS INTEGER NDXOUT(20), NDCOL(20) C C THIS FUNCTION CAN BE SUPPLIED BY THE USER TO COMPUTE REVERSE C CONDITION NUMBERS RC(L) = NORM(F)/(NORM(D)*SMALL) WHERE SMALL C IS THE SMALLEST OF THE NFIND SINGULAR VALUES OF F PRIME. C C ON INPUT.. C DERIV(J,I) IS THE PARTIAL DERIVATIVE OF THE I-TH OUTPUT C VALUE WITH RESPECT TO THE J-TH ENTRY OF THE DATA (IF C J .LE. NVARY) OR WITH RESPECT TO THE ROUNDING ERROR AT C NODE J (IF J .GT. NVARY). THE ORDER OF THE SUBSCRIPTS C IS REVERSED (COMPARED WITH, E.G., SECTION 3.5.4) HERE C AND THROUGHOUT THE SOFTWARE TO DECREASE TIME REQUIREMENTS C ON COMPUTERS WITH PAGED MEMORIES. C C VALND(I) IS THE NUMERICAL VALUE OF THE I-TH NODE. C C NDXOUT IS THE ARRAY OF INDICES OF OUTPUT NODES. THUS C VALND(NDXOUT(I)) IS THE I-TH OUTPUT VALUE. C C NVARY IS THE NUMBER OF DATA ENTRIES. C C NODES IS THE NUMBER OF NODES, I.E., THE SUM OF NVARY AND C THE NUMBER OF ARITHMETIC OPERATIONS IN THE TEST PROGRAM. C C NFIND IS THE NUMBER OF OUTPUTS. C DATA ZERO /0.0D0/, NOUT /6/ C C C COMPUTE NORM(F) C FNORM = ZERO DO 10 I = 1,NFIND IOUT = NDXOUT(I) T = DABS(VALND(IOUT)) IF (T.GT.FNORM) FNORM = T 10 CONTINUE C C COMPUTE NORM(D) C DNORM = ZERO DO 20 I = 1,NVARY T = DABS(VALND(I)) IF (T.GT.DNORM) DNORM = T 20 CONTINUE C C COMPUTE THE SINGULAR VALUES. F PRIME IS FIRST TRIANGULARIZED USING C HOUSEHOLDER TRANSFORMATIONS, THEN DIAGONALIZED USING A STANDARD C SINGULAR VALUE PROCEDURE. APPROPRIATE SUBROUTINES 'SQUARE' AND C 'DIAGON' ARE INCLUDED IN THIS SOFTWARE. C DO 30 I = 1, NFIND NDCOL(I) = NVARY 30 CONTINUE CALL SQUARE(DERIV, NDCOL, NFIND, .FALSE.) CALL DIAGON(DERIV, DUMMY, NFIND, .FALSE., IERR) IF (IERR .NE. 0) GO TO 60 SMALL = DERIV(1,1) IF (NFIND .EQ. 1) GO TO 50 DO 40 I = 2,NFIND T = DERIV(I,I) IF (T .LT. SMALL) SMALL = T 40 CONTINUE 50 IF (SMALL .LE. ZERO) GO TO 60 XPRMNT = FNORM/(DNORM*SMALL) RETURN 60 WRITE (NOUT,70) 70 FORMAT (18H FAILURE IN XPRMNT) XPRMNT = ZERO RETURN END === SQUARE C FORM THE LOWER TRIANGLE OF L*(L TRANSPOSE), WHERE L IS LOWER C TRIANGULAR. TEST (N=4) DIMENSION (A(N,N), L(N,N)) FOR I = 1 TO N BY 1 FOR J = 1 TO I BY 1 INPUT (L(I,J)) END (J) END (I) C FOR I = 1 TO N BY 1 FOR J = 1 TO I BY 1 A(I,J) = SUMMATION (L(I,K)*L(J,K), K = 1 TO J) OUTPUT (A(I,J)) END (J) END (I) C *STOP === SQUARE ROOT C FACTOR THE SYMMETRIC, POSITIVE DEFINITE MATRIX A AS L*(L TRANSPOSE), C WHERE L IS LOWER TRIANGULAR. ONLY THE LOWER TRIANGLE OF A IS USED. TEST (N=4) DIMENSION (A(N,N), L(N,N)) FOR I = 1 TO N BY 1 FOR J = 1 TO I-1 BY 1 INPUT (A(I,J)) TEMP = A(I,J) - SUMMATION(L(I,K)*L(J,K), K = 1 TO J-1) L(I,J) = TEMP/L(J,J) OUTPUT(L(I,J)) END (J) INPUT (A(I,I)) TEMP = A(I,I) - SUMMATION(L(I,K)*L(I,K),K = 1 TO I-1) L(I,I) = SQRT (TEMP) OUTPUT (L(I,I)) END (I) C *STOP ==-------- CS 13 VARIANTS OF THE GRAM-SCHMIDT METHOD, ONE VERSION --- C GS, A STANDARD FORMULATION OF THE GRAM-SCHMIDT METHOD. TEST (M=4, N=3) DIMENSION (A(M,N), Q(M,N), PROJ(M)) INPUT (A) C THE COLUMNS OF Q ARE ORTHOGONAL. FOR K = 1 TO N BY 1 IF K.GT.1 THEN C SUBTRACT THE PROJECTION OF THE K-TH VECTOR ON THE C SUBSPACE SPANNED BY THE PREVIOUS K-1 VECTORS. FOR I = 1 TO M BY 1 PROJ(I) = 0.0 END (I) FOR J = 1 TO K-1 BY 1 PRODUCT = SUMMATION (A(I,K)*Q(I,J), I = 1 TO M) FOR I = 1 TO M BY 1 PROJ(I) = PROJ(I) + PRODUCT*Q(I,J) END (I) END (J) FOR I = 1 TO M BY 1 A(I,K) = A(I,K) - PROJ(I) END (I) END C C NORMALIZE. SIZE = SQRT (SUMMATION(A(I,K)*A(I,K), I = 1 TO M)) FOR I = 1 TO M BY 1 Q(I,K) = A(I,K)/SIZE END (I) END (K) OUTPUT (Q) *STOP ==-------- CS 13 VARIANTS OF THE GRAM-SCHMIDT METHOD, ANOTHER VERSION C GS*, A GRAM-SCHMIDT VARIANT. TEST (M=4,N=3) DIMENSION (A(M,N), Q(M,N)) INPUT (A) FOR I = 1 TO M BY 1 FOR J = 1 TO N BY 1 Q(I,J) = A(I,J) END (J) END (I) C FOR K = 1 TO N BY 1 C FIRST NORMALIZE COLUMN K. SIZE = SQRT (SUMMATION(Q(I,K)*Q(I,K), I = 1 TO M)) FOR I = 1 TO M BY 1 Q(I,K) = Q(I,K)/SIZE END (I) IF K.LT.N THEN C SUBTRACT FROM EACH REMAINING COLUMN ITS PROJECTION C ON THE CURRENT COLUMN. FOR J = K+1 TO N BY 1 PRODUCT = SUMMATION (Q(I,K)*A(I,J), I = 1 TO M) FOR I = 1 TO M BY 1 Q(I,J) = Q(I,J) - PRODUCT*Q(I,K) END (I) END (J) END END (K) OUTPUT (Q) *STOP ==-------- CS 13 VARIANTS OF THE GRAM-SCHMIDT METHOD, MGS ----------- C MGS, THE MODIFIED GRAM-SCHMIDT METHOD. TEST (M=4,N=3) DIMENSION (A(M,N), Q(M,N)) INPUT (A) FOR I = 1 TO M BY 1 FOR J = 1 TO N BY 1 Q(I,J) = A(I,J) END (J) END (I) C FOR K = 1 TO N BY 1 C FIRST NORMALIZE COLUMN K. SIZE = SQRT (SUMMATION(Q(I,K)*Q(I,K), I = 1 TO M)) FOR I = 1 TO M BY 1 Q(I,K) = Q(I,K)/SIZE END (I) IF K.LT.N THEN C SUBTRACT FROM EACH REMAINING COLUMN ITS PROJECTION C ON THE CURRENT COLUMN. FOR J = K+1 TO N BY 1 PRODUCT = SUMMATION (Q(I,K)*Q(I,J), I = 1 TO M) FOR I = 1 TO M BY 1 Q(I,J) = Q(I,J) - PRODUCT*Q(I,K) END (I) END (J) END END (K) OUTPUT (Q) *STOP ==-------- CS 14 CHOLESKY FACTORS AFTER RANK-ONE MODIFICATIONS, LONG C THIS IS THE LONGER VARIANT OF TWO PROGRAMS GIVEN BY C GILL, MURRAY AND SAUNDERS IN 'METHODS FOR COMPUTING C AND MODIFYING THE LDV FACTORS OF A MATRIX', MATHEMATICS C OF COMPUTATION 29 (1975), 1051-1077 (ESPECIALLY PP. C 1060-1062) TO UPDATE THE CHOLESKY FACTORIZATION AFTER C A RANK-ONE CORRECTION. TEST (M=5) DIMENSION (D(M), L(M,M), V(M)) C THE L*D*(L TRANSPOSE) FACTORIZATION OF A MATRIX IS GIVEN. C ENTRIES OF D ARE ASSUMED POSITIVE. NEW FACTORS ARE FOUND C AFTER A MATRIX V*(V TRANSPOSE) IS ADDED. INPUT (D) FOR I = 2 TO M BY 1 FOR J = 1 TO I-1 BY 1 INPUT (L(I,J)) END (J) END (I) INPUT (V) T = 1.0 FOR J = 1 TO M BY 1 P = V(J) SAVET = T T = T + P*P/D(J) DT = D(J)*T D(J) = DT/SAVET B = P/DT TRATIO = SAVET/T FOR K = J+1 TO M BY 1 SAVEL = L(K,J) L(K,J) = TRATIO*L(K,J) + B*V(K) V(K) = V(K) - P*SAVEL END (K) END (J) OUTPUT (D) FOR I = 2 TO M BY 1 FOR J = 1 TO I-1 BY 1 OUTPUT (L(I,J)) END (J) END (I) *STOP ==-------- CS 14 CHOLESKY FACTORS AFTER RANK-ONE MODIFICATIONS, SHORT C THIS IS THE SHORTER VARIANT OF TWO PROGRAMS GIVEN BY C GILL, MURRAY AND SAUNDERS IN 'METHODS FOR COMPUTING C AND MODIFYING THE LDV FACTORS OF A MATRIX', MATHEMATICS C OF COMPUTATION 29 (1975), 1051-1077 (ESPECIALLY PP. C 1060-1062) TO UPDATE THE CHOLESKY FACTORIZATION AFTER C A RANK-ONE CORRECTION. TEST (M=5) DIMENSION (D(M), L(M,M), V(M)) C THE L*D*(L TRANSPOSE) FACTORIZATION OF A MATRIX IS GIVEN. C ENTRIES OF D ARE ASSUMED POSITIVE. NEW FACTORS ARE FOUND C AFTER A MATRIX V*(V TRANSPOSE) IS ADDED. INPUT (D) FOR I = 2 TO M BY 1 FOR J = 1 TO I-1 BY 1 INPUT (L(I,J)) END (J) END (I) INPUT (V) T = 1.0 FOR J = 1 TO M BY 1 P = V(J) SAVET = T T = T + P*P/D(J) DT = D(J)*T D(J) = DT/SAVET B = P/DT TRATIO = SAVET/T FOR K = J+1 TO M BY 1 V(K) = V(K) - P*L(K,J) L(K,J) = L(K,J) + B*V(K) END (K) END (J) OUTPUT (D) FOR I = 2 TO M BY 1 FOR J = 1 TO I-1 BY 1 OUTPUT (L(I,J)) END (J) END (I) *STOP C.......... THE LAST LINE OF ALGORITHM 532 .