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
