                 TESTING THE PORT UTILITIES
          P. A. FOX, A. D. HALL, AND N. L. SCHRYER
                       FEBRUARY 1978
THE TAPE ON WHICH YOU FOUND THIS DOCUMENT HAS THREE FILES:
    FILE 1 - THIS OPERATIONS GUIDE
    FILE 2 - FORTRAN SOURCE FOR THE PORT UTILITY PROGRAMS
    FILE 3 - TEST PROGRAMS
THE NAMES OF THE PORT UTILITY SUBPROGRAMS, WHOSE  SOURCE  IS
PROVIDED  ON  THE  SECOND FILE, ARE LISTED BELOW IN AN ORDER
CONSISTENT   WITH   THE   REQUIREMENTS   OF    A    ONE-PASS
LOADER:  SUBPROGRAMS INVOKED BY OTHER SUBPROGRAMS COME AFTER
THEIR INVOKERS ON THE LIST.
                        ENTSRC
                        RETSRC
                        ISTKQU
                        ISTKMD
                        ISTKRL
                        ISTKGT
                        ISTKIN
                        ISTKST
                        I0TK00
                        R1MACH
                        D1MACH
                        NERROR
                        ERROFF
                        SETERR
                        EPRINT
                        E9RINT
                        I1MACH
                        I8SAVE
                        S88FMT
                        FDUMP
        SUBPROGRAMS CONSTITUTING THE PORT UTILITIES
FEBRUARY 1978              - 1 -        PORT UTILITIES TESTS
IN THIS OPERATIONS GUIDE WE DESCRIBE  THE TESTS TO  BE  USED
IN  CHECKING  THAT THE PORT UTILITIES, THAT IS, THE MACHINE-
CONSTANTS FUNCTIONS, THE AUTOMATIC ERROR HANDLING  ROUTINES,
AND  THE  STACK  ALLOCATION ROUTINES, ARE ALL OPERATING COR-
RECTLY ON A COMPUTER AFTER THEY HAVE BEEN INSTALLED.
THE THIRD FILE ON THIS TAPE CONTAINS THE FOLLOWING TESTS:
    A TEST OF THE PORT LINGUISTIC HYPOTHESES
    A TEST OF THE INSTALLATION OF THE MACHINE CONSTANTS
    THREE TESTS OF THE AUTOMATIC ERROR HANDLING
    TWO TESTS OF THE STACK ALLOCATOR
EACH TEST IS A SELF-CONTAINED PROGRAM CONSISTING OF  A  MAIN
PROGRAM AND PERHAPS ONE OR MORE SUBPROGRAMS.
BEFORE RUNNING THE TESTS, THE THREE PORT FUNCTIONS,  R1MACH,
D1MACH,  AND  I1MACH, WHICH RETURN REAL, FLOATING-POINT, AND
INTEGER CONSTANTS, RESPECTIVELY, MUST BE SET  FOR  THE  COM-
PUTER  ON WHICH THE TESTS ARE TO BE RUN.  IN PARTICULAR, THE
OUTPUT FROM  THE  TESTS  IS  WRITTEN  ON  THE  LOGICAL  UNIT
SPECIFIED BY I1MACH(2).
WITHIN THESE THREE  FUNCTIONS,  APPROPRIATE  CONSTANTS  HAVE
BEEN  SPECIFIED FOR MANY COMPUTER CLASSES, AND CONSTANTS FOR
YET OTHER MACHINES  CAN  EASILY  BE  ADDED.   THE  NUMERICAL
VALUES,  IN  THE FUNCTIONS, ARE GIVEN IN FORTRAN DATA STATE-
MENTS MADE INTO COMMENTS BY A C IN COLUMN 1.  TO  ADAPT  THE
FUNCTIONS TO A GIVEN COMPUTER, THE CORRESPONDING DATA STATE-
MENTS MUST BE MADE ACTIVE BY MAKING EACH INITIAL  C  INTO  A
BLANK.
AFTER THE THREE MACHINE-CONSTANTS FUNCTIONS HAVE  BEEN  PAR-
TICULARIZED  TO  THE HOST COMPUTER, THEY AND THE REST OF THE
SUBPROGRAMS CONSTITUTING THE PORT UTILITIES  (LISTED  ABOVE)
SHOULD  BE  COMPILED  ONTO  AN OBJECT LIBRARY FOR USE BY THE
TEST PROGRAMS.
FEBRUARY 1978              - 2 -        PORT UTILITIES TESTS
           TESTING THE PORT LINGUISTIC HYPOTHESES
THIS TEST CONSISTS OF ONE MAIN PROGRAM AND SOME SUBPROGRAMS.
THESE  PROGRAMS SHOULD BE RUN TO TEST THE FOLLOWING PREMISES
MADE IN  PORT  ON  THE  COMPILING  AND  RUNNING  OF  FORTRAN
PROGRAMS:
   1. A VARIABLE (LOCAL TO A SUBPROGRAM) THAT IS INITIALIZED
      BY  A  DATA STATEMENT AND THEN CHANGED WITHIN THE SUB-
C     PROGRAM, RETAINS ITS MOST RECENTLY ASSIGNED VALUE FROM
      ONE INVOCATION TO THE NEXT.
   2. THERE IS NO SUBSCRIPT RANGE CHECKING FOR DUMMY  ARRAYS
      OR  ARRAYS  IN  COMMON.   THUS  AN  ARRAY  WHICH  IS A
      PARAMETER IN A CALL TO A SUBPROGRAM, OR WHICH IS IN  A
      NAMED COMMON REGION, MAY BE INDEXED BEYOND ITS LOCALLY
      DECLARED LENGTH.
   3. IT IS LEGAL FOR A NAMED COMMON REGION TO  BE  DECLARED
      OF  DIFFERENT  LENGTHS  IN  VARIOUS  SUBPROGRAMS.  THE
      LENGTH ASSIGNED BY THE OPERATING SYSTEM TO SUCH A COM-
      MON  REGION  MUST  BE  THE LENGTH DECLARED IN THE MAIN
C     PROGRAM.
IF THIS TEST RUNS CORRECTLY, ONLY THE FOLLOWING LINE WILL BE
PRINTED OUT:
        TEST OF PORT LINGUISTIC HYPOTHESES COMPLETE.
IF THE TEST FINDS ERRORS, APPROPRIATE  DIAGNOSTICS  WILL  BE
PRINTED.
FEBRUARY 1978              - 3 -        PORT UTILITIES TESTS
           TESTING THE MACHINE CONSTANT FUNCTIONS
THIS TEST, CONSISTING OF A MAIN PROGRAM WITH SOME ASSOCIATED
SUBPROGRAMS,  CHECKS  THAT THE THREE PORT FUNCTIONS, R1MACH,
D1MACH, AND  I1MACH,  WHICH  ARE  USED  TO  OBTAIN  MACHINE-
DEPENDENT CONSTANTS, HAVE BEEN CORRECTLY ADAPTED TO THE COM-
PUTER USING THE PROCEDURE DESCRIBED ON PAGE 2.  A CHECK  FOR
THE  CONSISTENCY  OF  THE CONSTANTS IS MADE BY COMPARING THE
REAL AND DOUBLE-PRECISION  CONSTANTS  GIVEN  BY  R1MACH  AND
D1MACH  WITH  THE CORRESPONDING VALUES COMPUTED FROM THE IN-
TEGER SPECIFICATIONS GIVEN IN I1MACH.
THE OUTPUT FROM THIS TEST RUN ON  AN  IBM  370  COMPUTER  IS
GIVEN ON THE NEXT PAGE FOR REFERENCE.
THE DISAGREEMENT SHOWN AT THE END FOR THE VALUE OF D1MACH(5)
SAYS THAT THE VALUE OF THE LOG (TO THE BASE TEN) OF THE BASE
OF THE MACHINE AS PROVIDED BY D1MACH DOES NOT AGREE WITH THE
VALUE  CALCULATED  USING  THE  LOG ROUTINE ON THE LOCAL COM-
PUTER'S FORTRAN LIBRARY.  THIS USUALLY  OCCURS  BECAUSE  THE
LOG  ROUTINE  DOES  NOT CALCULATE THE VALUES TO THE ACCURACY
(LAST BIT) PROVIDED IN D1MACH.
FEBRUARY 1978              - 4 -        PORT UTILITIES TESTS
 FORMAT CONVERSION FOR INTEGERS IS - I12
 INTEGER CONSTANTS FOLLOW
 THE STANDARD INPUT UNIT                                        5
 THE STANDARD OUTPUT UNIT                                       6
 THE STANDARD PUNCH UNIT                                        7
 THE STANDARD ERROR MESSAGE UNIT                                6
 THE NUMBER OF BITS PER WORD                                   32
 THE NUMBER OF CHARACTERS PER WORD                              4
 A, THE BASE OF AN S-DIGIT INTEGER                              2
 S, THE NUMBER OF BASE-A DIGITS                                31
 A**S - 1, THE LARGEST MAGNITUDE                       2147483647
 B, THE BASE OF A T-DIGIT FLOATING-POINT NUMBER                16
 T, THE NUMBER OF BASE-B DIGITS IN SINGLE-PRECISION             6
 EMIN, THE SMALLEST SINGLE-PRECISION EXPONENT                 -64
 EMAX, THE LARGEST SINGLE-PRECISION EXPONENT                   63
 T, THE NUMBER OF BASE-B DIGITS IN DOUBLE-PRECISION            14
 EMIN, THE SMALLEST DOUBLE-PRECISION EXPONENT                 -64
 EMAX, THE LARGEST DOUBLE-PRECISION EXPONENT                   63
 FORMAT CONVERSION FOR SINGLE-PRECISION IS - E16.08
 SINGLE-PRECISION CONSTANTS FOLLOW
 THE SMALLEST POSITIVE MAGNITUDE    0.53976053E-78
 THE LARGEST MAGNITUDE              0.72370051E+76
 THE SMALLEST RELATIVE SPACING      0.59604645E-07
 THE LARGEST RELATIVE SPACING       0.95367432E-06
 LOG10 OF THE BASE                  0.12041197E+01
 FORMAT CONVERSION FOR DOUBLE-PRECISION IS - D25.17
 DOUBLE-PRECISION CONSTANTS FOLLOW
 THE SMALLEST POSITIVE MAGNITUDE    0.53976053469340279D-78
 THE LARGEST MAGNITUDE              0.72370055773322621D+76
 THE SMALLEST RELATIVE SPACING      0.13877787807814457D-16
 THE LARGEST RELATIVE SPACING       0.22204460492503131D-15
 LOG10 OF THE BASE                  0.12041199826559248D+01
 D1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE
 D1MACH(5) =                        0.120411998265592479D+01
 CALCULATED VALUE =                 0.120411998265592457D+01
 DIFFERENCE =                       0.222044604925031308D-15
           MACHINE-CONSTANT TEST:  IBM 370 OUTPUT
FEBRUARY 1978              - 5 -        PORT UTILITIES TESTS
            TESTING THE AUTOMATIC ERROR HANDLING
THERE ARE THREE MAIN PROGRAMS FOR  TESTING  ERROR  HANDLING:
THE FOLLOWING PARAGRAPHS DESCRIBE THE ACTIONS THAT ARE TAKEN
BY THESE PROGRAMS AND THE OUTPUT THAT SHOULD BE PRODUCED.
    1. THE FIRST MAIN PROGRAM TESTS RECOVERABLE ERRORS.
       IT CHECKS THAT THE RECOVERY STATE IS CORRECTLY TURNED
       ON AND OFF BY THE PAIR OF PORT SUBPROGRAMS ENTSRC AND
       RETSRC,  AND  THAT  THE   ERROR-SETTING   SUBPROGRAM,
       SETERR,  THE  ERROR-PRINTING  SUBPROGRAM, EPRINT, AND
       THE SUBPROGRAM TO TURN OFF THE ERROR  STATE,  ERROFF,
       ALL WORK CORRECTLY.
       THE TEST STARTS OUT BY ENTERING  THE  RECOVERY  MODE,
       SETTING AN ERROR AND PRINTING THE ERROR USING EPRINT.
       THE OUTPUT SHOULD BE
        ERROR   1 IN FIRST ERROR TEST - RECOVERABLE ERROR OK
       THE ERROR STATE IS THEN TURNED OFF,  USING  THE  SUB-
C      PROGRAM  ERROFF,  AND A CHECK IS MADE TO BE SURE THAT
       IT IS OFF AND THAT NO ERROR MESSAGE  IS  OUTSTANDING.
       (THE SECOND EPRINT SHOULD FIND NO MESSAGE AND HAVE NO
       OUTPUT.)
       FINALLY A NEW RECOVERABLE ERROR IS SET WITH THE  MES-
       SAGE
        ERROR   2 IN SAME TEST - LEAVING RECOVERY MODE
       AND THE RECOVERY MODE IS SET TO NONRECOVERY USING THE
       SUBPROGRAM  RETSRC,  BUT SINCE IT IS ILLEGAL TO LEAVE
       THE RECOVERY STATE WHEN AN UNRECOVERED ERROR IS  OUT-
       STANDING,  THE  ABOVE  MESSAGE IS PRINTED OUT AND THE
       RUN TERMINATED.
FEBRUARY 1978              - 6 -        PORT UTILITIES TESTS
      TESTING THE AUTOMATIC ERROR HANDLING, CONTINUED
    2. THE SECOND MAIN PROGRAM  FOR  TESTING  ERROR-HANDLING
       TESTS FATAL ERRORS.
       A CALL IS MADE TO THE SUBPROGRAM, SETERR, SIGNALING A
       FATAL ERROR BY SETTING THE LAST ARGUMENT IN THE CALL,
       IOPT, TO 2.  THIS SHOULD CAUSE THE FOLLOWING  MESSAGE
       TO  BE  PRINTED,  THE  DUMP  SUBPROGRAM, FDUMP, TO BE
       CALLED AND THE RUN TERMINATED.
        ERROR   1 IN SECOND ERROR TEST - FATAL ERROR CHECKED
       THE FDUMP ROUTINE SENT OUT WITH THE PORT UTILITIES IS
       A  SIMPLE,  DUMMY, RETURN-END SUBPROGRAM.  INDIVIDUAL
       SITES SHOULD PROVIDE A LOCAL VERSION.
    3. THE THIRD MAIN PROGRAM  FOR  TESTING  ERROR  HANDLING
       CHECKS  THAT THE OCCURRENCE OF TWO RECOVERABLE ERRORS
       IN A ROW CAUSES A FATAL ERROR.
       THIS SITUATION CAN ONLY ARISE WHEN THE USER HAS  GONE
       INTO  THE  RECOVERY MODE, BECAUSE OTHERWISE THE FIRST
       ERROR IS CONSIDERED FATAL.  IN THE RECOVERY MODE, THE
       USER  IS EXPECTED TO RECOVER FROM A RECOVERABLE ERROR
       AND TURN IT OFF BEFORE RESUMING EXECUTION.
       THE TEST PROGRAM SETS THE FIRST RECOVERABLE ERROR  BY
       CALLING  SETERR,  AND  THEN  CALLS  IT  AGAIN  TO SET
       ANOTHER.  ON THE SECOND CALL SETERR SHOULD  SIGNAL  A
       FATAL  ERROR,  BY  PRINTING  THE FOLLOWING ERROR MES-
       SAGES, PROVIDING A DUMP AND TERMINATING THE RUN.
 ERROR   3 IN SETERR - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.
        THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.
        ERROR   1 IN MAIN - FIRST RECOVERABLE ERROR
        ERROR   2 IN MAIN - SECOND RECOVERABLE ERROR
FEBRUARY 1978              - 7 -        PORT UTILITIES TESTS
                    TESTING THE STACK ALLOCATOR
       THERE ARE TWO  TESTS  TO  BE  USED  FOR  TESTING  THE
       STORAGE ALLOCATION PACKAGE.  EACH OF THESE TESTS CON-
       SISTS OF A MAIN PROGAM  AND  ASSOCIATED  SUBPROGRAMS.
       THE FIRST TEST IS USED TO TEST THE STANDARD CASE WHEN
       THE STACK IS AUTOMATICALLY SET TO ITS DEFAULT LENGTH;
       THE  SECOND  TEST  IS  USED  TO  TEST THE ALTERNATIVE
       SITUATION WHERE THE USER HAS INITIALLY SET THE  STACK
       TO A DIFFERENT (NON-DEFAULT) LENGTH.
    1. THE FIRST ALLOCATOR TEST USES THE PORT DEFAULT  STACK
       LENGTH  OF  500 DOUBLE-PRECISION LOCATIONS.  THE TEST
       PROCEDURE CONSISTS OF A NUMBER OF ALLOCATIONS AND AS-
       SIGNMENTS  OF  VALUES  ON  THE STACK, FOLLOWED BY DE-
       ALLOCATIONS  AND  CHECKING  FOR  CONSISTENCY.   REAL,
       DOUBLE-PRECISION, COMPLEX, INTEGER AND LOGICAL VALUES
       ARE PUT ON THE STACK  IN  ALTERNATING  PATTERNS,  AND
       THEN  RELEASED.   ALL THE STACK-HANDLING ROUTINES ARE
       CALLED INTO PLAY TO BE SURE THE MECHANISM IS  WORKING
       AS IT SHOULD.
       BEFORE THE TEST IS RUN THE FOLLOWING LINE IS  PRINTED
       BY THE TEST PROGRAM:
 AN ERROR BELOW INDICATES TROUBLE WITH THE STORAGE ALLOCATOR,
 WHEN USING THE STACK WITH DEFAULT LENGTH.
       THEN, IF NO ERRORS HAVE BEEN FOUND DURING  THE  FIRST
       PART OF THIS TEST, THE FOLLOWING MESSAGE APPEARS:
        FIRST STORAGE ALLOCATION TEST COMPLETE.
       FINALLY,  THE TEST PROGRAM FORCES  AN  ERROR  BY  RE-
       QUESTING  MORE  SPACE  THAN IS LEFT ON THE STACK, AND
       THE FOLLOWING IS PRINTED, A CALL TO  FDUMP  MADE  AND
       THE RUN TERMINATED.
       NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE.
        ERROR   4 IN ISTKGT - STACK TOO SHORT.
                 ENLARGE IT AND CALL ISTKIN IN MAIN PROGRAM.
FEBRUARY 1978              - 8 -        PORT UTILITIES TESTS
           TESTING THE STACK ALLOCATOR, CONTINUED
    2. THE SECOND STACK ALLOCATOR TEST IS EXACTLY  THE  SAME
       AS   THE   FIRST  EXCEPT  THAT  THE  STACK  IS  FIRST
       INITIALIZED, IN THE MAIN TEST PROGRAM, TO A LENGTH OF
       5000 DOUBLE-PRECISION LOCATIONS.
       BEFORE THE TEST IS  RUN,  THE  FOLLOWING  MESSAGE  IS
       PRINTED:
        AN ERROR BELOW INDICATES TROUBLE WITH THE ALLOCATOR,
        WHEN USING A STACK INITIALIZED TO NON-DEFAULT LENGTH.
       THEN, AGAIN, AFTER THE FIRST PART OF THE TEST IS RUN,
       PROVIDED  NO  ERRORS  HAVE  BEEN FOUND, THE FOLLOWING
       MESSAGE APPEARS:
        SECOND STORAGE ALLOCATOR TEST COMPLETE.
       FINALLY, THE TEST PROGRAM  FORCES  AN  ERROR  BY  RE-
       QUESTING  MORE  SPACE  THAN IS LEFT ON THE STACK, AND
       THE FOLLOWING IS PRINTED, A CALL TO  FDUMP  MADE  AND
       THE RUN TERMINATED.
       NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE.
        ERROR   4 IN ISTKGT - STACK TOO SHORT.
                 ENLARGE IT AND CALL ISTKIN IN MAIN PROGRAM.
FEBRUARY 1978              - 9 -        PORT UTILITIES TESTS
      SUBROUTINE ENTSRC(IROLD,IRNEW)
C
C  THIS ROUTINE RETURNS IROLD = LRECOV AND SETS LRECOV = IRNEW.
C
C  IF THERE IS AN ACTIVE ERROR STATE, THE MESSAGE IS PRINTED
C  AND EXECUTION STOPS.
C
C  IRNEW = 0 LEAVES LRECOV UNCHANGED, WHILE
C  IRNEW = 1 GIVES RECOVERY AND
C  IRNEW = 2 TURNS RECOVERY OFF.
C
C  ERROR STATES -
C
C    1 - ILLEGAL VALUE OF IRNEW.
C    2 - CALLED WHILE IN AN ERROR STATE.
C
      IF (IRNEW.LT.0 .OR. IRNEW.GT.2)
     1   CALL SETERR(31HENTSRC - ILLEGAL VALUE OF IRNEW,31,1,2)
C
      IROLD=I8SAVE(2,IRNEW,IRNEW.NE.0)
C
C  IF HAVE AN ERROR STATE, STOP EXECUTION.
C
      IF (I8SAVE(1,0,.FALSE.) .NE. 0) CALL SETERR
     1   (39HENTSRC - CALLED WHILE IN AN ERROR STATE,39,2,2)
C
      RETURN
C
      END
      SUBROUTINE RETSRC(IROLD)                                          RECB0000
C
C  THIS ROUTINE SETS LRECOV = IROLD.
C
C  IF THE CURRENT ERROR BECOMES UNRECOVERABLE,
C  THE MESSAGE IS PRINTED AND EXECUTION STOPS.
C
C  ERROR STATES -
C
C    1 - ILLEGAL VALUE OF IROLD.
C
      IF (IROLD.LT.1 .OR. IROLD.GT.2)
     1  CALL SETERR(31HRETSRC - ILLEGAL VALUE OF IROLD,31,1,2)
C
      ITEMP=I8SAVE(2,IROLD,.TRUE.)
C
C  IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP.
C
      IF (IROLD.EQ.1 .OR. I8SAVE(1,0,.FALSE.).EQ.0) RETURN
C
        CALL EPRINT
        STOP
C
      END
      INTEGER FUNCTION ISTKQU(ITYPE)                                    STKA0000
C
C  RETURNS THE NUMBER OF ITEMS OF TYPE ITYPE THAT REMAIN
C  TO BE ALLOCATED IN ONE REQUEST.
C
C  ERROR STATES -
C
C    1 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
C    2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6
C
      COMMON /CSTAK/DSTAK
C
      DOUBLE PRECISION DSTAK(500)
      INTEGER ISTAK(1000)
      INTEGER ISIZE(5)
C
      LOGICAL INIT
C
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
      EQUIVALENCE (ISTAK(6),ISIZE(1))
C
      DATA INIT/.TRUE./
C
      IF (INIT) CALL I0TK00(INIT,500,4)
C
      IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
     1   (47HISTKQU - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN,
     2    47,1,2)
C
      IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
     1   (33HISTKQU - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2)
C
      ISTKQU = MAX0( ((LMAX-2)*ISIZE(2))/ISIZE(ITYPE)
     1             - (LNOW*ISIZE(2)-1)/ISIZE(ITYPE)
     2             - 1, 0 )
C
      RETURN
C
      END
      INTEGER FUNCTION ISTKMD(NITEMS)                                   STKB0000
C
C  CHANGES THE LENGTH OF THE FRAME AT THE TOP OF THE STACK
C  TO NITEMS.
C
C  ERROR STATES -
C
C    1 - LNOW OVERWRITTEN
C    2 - ISTAK(LNOWO-1) OVERWRITTEN
C
      COMMON /CSTAK/DSTAK
C
      DOUBLE PRECISION DSTAK(500)
      INTEGER ISTAK(1000)
C
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(2),LNOW)
C
      LNOWO = LNOW
      CALL ISTKRL(1)
C
      ITYPE = ISTAK(LNOWO-1)
C
      IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
     1   (35HISTKMD - ISTAK(LNOWO-1) OVERWRITTEN,35,1,2)
C
      ISTKMD = ISTKGT(NITEMS,ITYPE)
C
      RETURN
C
      END
      SUBROUTINE ISTKRL(NUMBER)                                         STKC0000
C
C  DE-ALLOCATES THE LAST (NUMBER) ALLOCATIONS MADE IN THE STACK
C  BY ISTKGT.
C
C  ERROR STATES -
C
C    1 - NUMBER .LT. 0
C    2 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
C    3 - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION
C    4 - THE POINTER AT ISTAK(LNOW) OVERWRITTEN
C
      COMMON /CSTAK/DSTAK
C
      DOUBLE PRECISION DSTAK(500)
      INTEGER ISTAK(1000)
      LOGICAL INIT
C
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),LOUT)
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
C
      DATA INIT/.TRUE./
C
      IF (INIT) CALL I0TK00(INIT,500,4)
C
      IF (NUMBER.LT.0) CALL SETERR(20HISTKRL - NUMBER.LT.0,20,1,2)
C
      IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
     1   (47HISTKRL - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN,
     2    47,2,2)
C
      IN = NUMBER
 10      IF (IN.EQ.0) RETURN
C
         IF (LNOW.LE.LBOOK) CALL SETERR
     1   (55HISTKRL - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION,
     2    55,3,2)
C
C     CHECK TO MAKE SURE THE BACK POINTERS ARE MONOTONE.
C
         IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) CALL SETERR
     1   (47HISTKRL - THE POINTER AT ISTAK(LNOW) OVERWRITTEN,
     2    47,4,2)
C
         LOUT = LOUT-1
         LNOW = ISTAK(LNOW)
         IN = IN-1
         GO TO 10
C
      END
      INTEGER FUNCTION ISTKGT(NITEMS,ITYPE)                             STKE0000
C
C  ALLOCATES SPACE OUT OF THE INTEGER ARRAY ISTAK (IN COMMON
C  BLOCK CSTAK) FOR AN ARRAY OF LENGTH NITEMS AND OF TYPE
C  DETERMINED BY ITYPE AS FOLLOWS
C
C    1 - LOGICAL
C    2 - INTEGER
C    3 - REAL
C    4 - DOUBLE PRECISION
C    5 - COMPLEX
C
C  ON RETURN, THE ARRAY WILL OCCUPY
C
C    STAK(ISTKGT), STAK(ISTKGT+1), ..., STAK(ISTKGT-NITEMS+1)
C
C  WHERE STAK IS AN ARRAY OF TYPE ITYPE EQUIVALENCED TO ISTAK.
C
C  (FOR THOSE WANTING TO MAKE MACHINE DEPENDENT MODIFICATIONS
C  TO SUPPORT OTHER TYPES, CODES 6,7,8,9,10,11 AND 12 HAVE
C  BEEN RESERVED FOR 1/4 LOGICAL, 1/2 LOGICAL, 1/4 INTEGER,
C  1/2 INTEGER, QUAD PRECISION, DOUBLE COMPLEX AND QUAD
C  COMPLEX, RESPECTIVELY.)
C
C  THE ALLOCATOR RESERVES THE FIRST TEN INTEGER WORDS OF THE STACK
C  FOR ITS OWN INTERNAL BOOK-KEEPING. THESE ARE INITIALIZED BY
C  THE INITIALIZING SUBPROGRAM I0TK00 UPON THE FIRST CALL
C  TO A SUBPROGRAM IN THE ALLOCATION PACKAGE.
C
C  THE USE OF THE FIRST FIVE WORDS IS DESCRIBED BELOW.
C
C    ISTAK( 1) - LOUT,  THE NUMBER OF CURRENT ALLOCATIONS.
C    ISTAK( 2) - LNOW,  THE CURRENT ACTIVE LENGTH OF THE STACK.
C    ISTAK( 3) - LUSED, THE MAXIMUM VALUE OF ISTAK(2) ACHIEVED.
C    ISTAK( 4) - LMAX,  THE MAXIMUM LENGTH THE STACK.
C    ISTAK( 5) - LBOOK, THE NUMBER OF WORDS USED FOR BOOKEEPING.
C
C  THE NEXT FIVE WORDS CONTAIN INTEGERS DESCRIBING THE AMOUNT
C  OF STORAGE ALLOCATED BY THE FORTRAN SYSTEM TO THE VARIOUS
C  DATA TYPES.  THE UNIT OF MEASUREMENT IS ARBITRARY AND MAY
C  BE WORDS, BYTES OR BITS OR WHATEVER IS CONVENIENT.  THE
C  VALUES CURRENTLY ASSUMED CORRESPOND TO AN ANS FORTRAN
C  ENVIRONMENT.  FOR SOME MINI-COMPUTER SYSTEMS THE VALUES MAY
C  HAVE TO BE CHANGED (SEE I0TK00).
C
C    ISTAK( 6) - THE NUMBER OF UNITS ALLOCATED TO LOGICAL
C    ISTAK( 7) - THE NUMBER OF UNITS ALLOCATED TO INTEGER
C    ISTAK( 8) - THE NUMBER OF UNITS ALLOCATED TO REAL
C    ISTAK( 9) - THE NUMBER OF UNITS ALLOCATED TO DOUBLE PRECISION
C    ISTAK(10) - THE NUMBER OF UNITS ALLOCATED TO COMPLEX
C
C  ERROR STATES -
C
C    1 - NITEMS .LT. 0
C    2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6
C    3 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
C    4 - STACK OVERFLOW
C
      COMMON /CSTAK/DSTAK
C
      DOUBLE PRECISION DSTAK(500)
      INTEGER ISTAK(1000)
      INTEGER ISIZE(5)
C
      LOGICAL INIT
C
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),LOUT)
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
      EQUIVALENCE (ISTAK(6),ISIZE(1))
C
      DATA INIT/.TRUE./
C
      IF (INIT) CALL I0TK00(INIT,500,4)
C
      IF (NITEMS.LT.0) CALL SETERR(20HISTKGT - NITEMS.LT.0,20,1,2)
C
      IF (ITYPE.LE.0 .OR. ITYPE.GE.6) CALL SETERR
     1   (33HISTKGT - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2)
C
      IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
     1   (47HISTKGT - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN,
     2    47,3,2)
C
      ISTKGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2
      I = ( (ISTKGT-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3
C
C  STACK OVERFLOW IS AN UNRECOVERABLE ERROR.
C
      IF (I.GT.LMAX) CALL SETERR(69HISTKGT - STACK TOO SHORT. ENLARGE IT
     1 AND CALL ISTKIN IN MAIN PROGRAM.,69,4,2)
C
C  ISTAK(I-1) CONTAINS THE TYPE FOR THIS ALLOCATION.
C  ISTAK(I  ) CONTAINS A POINTER TO THE END OF THE PREVIOUS
C             ALLOCATION.
C
      ISTAK(I-1) = ITYPE
      ISTAK(I  ) = LNOW
      LOUT = LOUT+1
      LNOW = I
      LUSED = MAX0(LUSED,LNOW)
C
      RETURN
C
      END
      SUBROUTINE ISTKIN(NITEMS,ITYPE)                                   STKF0000
C
C  INITIALIZES THE STACK ALLOCATOR, SETTING THE LENGTH OF THE STACK.
C
C  ERROR STATES -
C
C    1 - NITEMS .LE. 0
C    2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6
C
      LOGICAL INIT
C
      DATA INIT/.TRUE./
C
      IF (NITEMS.LE.0) CALL SETERR(20HISTKIN - NITEMS.LE.0,20,1,2)
C
      IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
     1   (33HISTKIN - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2)
C
      IF (INIT) CALL I0TK00(INIT,NITEMS,ITYPE)
C
      RETURN
C
      END
      INTEGER FUNCTION ISTKST(NFACT)                                    STKS0000
C
C  RETURNS CONTROL INFORMATION AS FOLLOWS
C
C  NFACT    ITEM RETURNED
C
C    1         LOUT,  THE NUMBER OF CURRENT ALLOCATIONS
C    2         LNOW,  THE CURRENT ACTIVE LENGTH
C    3         LUSED, THE MAXIMUM USED
C    4         LMAX,  THE MAXIMUM ALLOWED
C
      COMMON /CSTAK/DSTAK
C
      DOUBLE PRECISION DSTAK(500)
      INTEGER ISTAK(1000)
      INTEGER ISTATS(4)
      LOGICAL INIT
C
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),ISTATS(1))
C
      DATA INIT/.TRUE./
C
      IF (INIT) CALL I0TK00(INIT,500,4)
C
      IF (NFACT.LE.0.OR.NFACT.GE.5) CALL SETERR
     1   (33HISTKST - NFACT.LE.0.OR.NFACT.GE.5,33,1,2)
C
      ISTKST = ISTATS(NFACT)
C
      RETURN
C
      END
      SUBROUTINE I0TK00(LARG,NITEMS,ITYPE)                              STKG0000
C
C  INITIALIZES THE STACK TO NITEMS OF TYPE ITYPE
C
      COMMON /CSTAK/DSTAK
C
      DOUBLE PRECISION DSTAK(500)
      INTEGER ISTAK(1000)
      LOGICAL LARG,INIT
      INTEGER ISIZE(5)
C
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),LOUT)
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
      EQUIVALENCE (ISTAK(6),ISIZE(1))
C
      DATA INIT/.FALSE./
C
      LARG = .FALSE.
      IF (INIT) RETURN
C
C  HERE TO INITIALIZE
C
      INIT = .TRUE.
C
C  SET DATA SIZES APPROPRIATE FOR A STANDARD CONFORMING
C  FORTRAN SYSTEM USING THE FORTRAN "STORAGE UNIT" AS THE
C  MEASURE OF SIZE.
C
C  LOGICAL
      ISIZE(1) = 1
C  INTEGER
      ISIZE(2) = 1
C  REAL
      ISIZE(3) = 1
C  DOUBLE PRECISION
      ISIZE(4) = 2
C  COMPLEX
      ISIZE(5) = 2
C
      LBOOK = 10
      LNOW  = LBOOK
      LUSED = LBOOK
      LMAX  = MAX0( (NITEMS*ISIZE(ITYPE))/ISIZE(2), 12 )
      LOUT  = 0
C
      RETURN
C
      END
      REAL FUNCTION R1MACH(I)                                           MCHR0000
C
C  SINGLE-PRECISION MACHINE CONSTANTS
C
C  R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C
C  R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C
C  R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C
C  R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C
C  R1MACH(5) = LOG10(B)
C
C  TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT,
C  THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY
C  REMOVING THE C FROM COLUMN 1.
C
C  WHERE POSSIBLE, OCTAL OR HEXADECIMAL CONSTANTS HAVE BEEN USED
C  TO SPECIFY THE CONSTANTS EXACTLY WHICH HAS IN SOME CASES
C  REQUIRED THE USE OF EQUIVALENT INTEGER ARRAYS.
C
      INTEGER SMALL(2)
      INTEGER LARGE(2)
      INTEGER RIGHT(2)
      INTEGER DIVER(2)
      INTEGER LOG10(2)
C
      REAL RMACH(5)
C
      EQUIVALENCE (RMACH(1),SMALL(1))
      EQUIVALENCE (RMACH(2),LARGE(1))
      EQUIVALENCE (RMACH(3),RIGHT(1))
      EQUIVALENCE (RMACH(4),DIVER(1))
      EQUIVALENCE (RMACH(5),LOG10(1))
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA RMACH(1) / Z400800000 /
C     DATA RMACH(2) / Z5FFFFFFFF /
C     DATA RMACH(3) / Z4E9800000 /
C     DATA RMACH(4) / Z4EA800000 /
C     DATA RMACH(5) / Z500E730E8 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS.
C
C     DATA RMACH(1) / O1771000000000000 /
C     DATA RMACH(2) / O0777777777777777 /
C     DATA RMACH(3) / O1311000000000000 /
C     DATA RMACH(4) / O1301000000000000 /
C     DATA RMACH(5) / O1157163034761675 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C     DATA RMACH(1) / 00014000000000000000B /
C     DATA RMACH(2) / 37767777777777777777B /
C     DATA RMACH(3) / 16404000000000000000B /
C     DATA RMACH(4) / 16414000000000000000B /
C     DATA RMACH(5) / 17164642023241175720B /
C
C     MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA RMACH(1) / 200004000000000000000B /
C     DATA RMACH(2) / 577777777777777777777B /
C     DATA RMACH(3) / 377214000000000000000B /
C     DATA RMACH(4) / 377224000000000000000B /
C     DATA RMACH(5) / 377774642023241175720B /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
C     STATIC RMACH(5)
C
C     DATA SMALL/20K,0/,LARGE/77777K,177777K/
C     DATA RIGHT/35420K,0/,DIVER/36020K,0/
C     DATA LOG10/40423K,42023K/
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C
C     DATA SMALL(1),SMALL(2) / '20000000, '00000201 /
C     DATA LARGE(1),LARGE(2) / '37777777, '00000177 /
C     DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 /
C     DATA DIVER(1),DIVER(2) / '20000000, '00000353 /
C     DATA LOG10(1),LOG10(2) / '23210115, '00000377 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C     DATA RMACH(1) / O402400000000 /
C     DATA RMACH(2) / O376777777777 /
C     DATA RMACH(3) / O714400000000 /
C     DATA RMACH(4) / O716400000000 /
C     DATA RMACH(5) / O776464202324 /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86.
C
C     DATA RMACH(1) / Z00100000 /
C     DATA RMACH(2) / Z7FFFFFFF /
C     DATA RMACH(3) / Z3B100000 /
C     DATA RMACH(4) / Z3C100000 /
C     DATA RMACH(5) / Z41134413 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR).
C
C     DATA RMACH(1) / "000400000000 /
C     DATA RMACH(2) / "377777777777 /
C     DATA RMACH(3) / "146400000000 /
C     DATA RMACH(4) / "147400000000 /
C     DATA RMACH(5) / "177464202324 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1) /    8388608 /
C     DATA LARGE(1) / 2147483647 /
C     DATA RIGHT(1) /  880803840 /
C     DATA DIVER(1) /  889192448 /
C     DATA LOG10(1) / 1067065499 /
C
C     DATA RMACH(1) / O00040000000 /
C     DATA RMACH(2) / O17777777777 /
C     DATA RMACH(3) / O06440000000 /
C     DATA RMACH(4) / O06500000000 /
C     DATA RMACH(5) / O07746420233 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     16-BIT INTEGERS  (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /   128,     0 /
C     DATA LARGE(1),LARGE(2) / 32767,    -1 /
C     DATA RIGHT(1),RIGHT(2) / 13440,     0 /
C     DATA DIVER(1),DIVER(2) / 13568,     0 /
C     DATA LOG10(1),LOG10(2) / 16282,  8347 /
C
C     DATA SMALL(1),SMALL(2) / O000200, O000000 /
C     DATA LARGE(1),LARGE(2) / O077777, O177777 /
C     DATA RIGHT(1),RIGHT(2) / O032200, O000000 /
C     DATA DIVER(1),DIVER(2) / O032400, O000000 /
C     DATA LOG10(1),LOG10(2) / O037632, O020233 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA RMACH(1) / O000400000000 /
C     DATA RMACH(2) / O377777777777 /
C     DATA RMACH(3) / O146400000000 /
C     DATA RMACH(4) / O147400000000 /
C     DATA RMACH(5) / O177464202324 /
C
      IF (I .LT. 1  .OR.  I .GT. 5)
     1   CALL SETERR(24HR1MACH - I OUT OF BOUNDS,24,1,2)
C
      R1MACH = RMACH(I)
      RETURN
C
      END
      DOUBLE PRECISION FUNCTION D1MACH(I)                               MCHD0000
C
C  DOUBLE-PRECISION MACHINE CONSTANTS
C
C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C
C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C
C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C
C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C
C  D1MACH( 5) = LOG10(B)
C
C  TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT,
C  THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY
C  REMOVING THE C FROM COLUMN 1.
C
C  WHERE POSSIBLE, OCTAL OR HEXADECIMAL CONSTANTS HAVE BEEN USED
C  TO SPECIFY THE CONSTANTS EXACTLY WHICH HAS IN SOME CASES
C  REQUIRED THE USE OF EQUIVALENT INTEGER ARRAYS.
C
      INTEGER SMALL(4)
      INTEGER LARGE(4)
      INTEGER RIGHT(4)
      INTEGER DIVER(4)
      INTEGER LOG10(4)
C
      DOUBLE PRECISION DMACH(5)
C
      EQUIVALENCE (DMACH(1),SMALL(1))
      EQUIVALENCE (DMACH(2),LARGE(1))
      EQUIVALENCE (DMACH(3),RIGHT(1))
      EQUIVALENCE (DMACH(4),DIVER(1))
      EQUIVALENCE (DMACH(5),LOG10(1))
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA SMALL(1) / ZC00800000 /
C     DATA SMALL(2) / Z000000000 /
C
C     DATA LARGE(1) / ZDFFFFFFFF /
C     DATA LARGE(2) / ZFFFFFFFFF /
C
C     DATA RIGHT(1) / ZCC5800000 /
C     DATA RIGHT(2) / Z000000000 /
C
C     DATA DIVER(1) / ZCC6800000 /
C     DATA DIVER(2) / Z000000000 /
C
C     DATA LOG10(1) / ZD00E730E7 /
C     DATA LOG10(2) / ZC77800DC0 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C     DATA SMALL(1) / O1771000000000000 /
C     DATA SMALL(2) / O0000000000000000 /
C
C     DATA LARGE(1) / O0777777777777777 /
C     DATA LARGE(2) / O0007777777777777 /
C
C     DATA RIGHT(1) / O1461000000000000 /
C     DATA RIGHT(2) / O0000000000000000 /
C
C     DATA DIVER(1) / O1451000000000000 /
C     DATA DIVER(2) / O0000000000000000 /
C
C     DATA LOG10(1) / O1157163034761674 /
C     DATA LOG10(2) / O0006677466732724 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C     DATA SMALL(1) / O1771000000000000 /
C     DATA SMALL(2) / O7770000000000000 /
C
C     DATA LARGE(1) / O0777777777777777 /
C     DATA LARGE(2) / O7777777777777777 /
C
C     DATA RIGHT(1) / O1461000000000000 /
C     DATA RIGHT(2) / O0000000000000000 /
C
C     DATA DIVER(1) / O1451000000000000 /
C     DATA DIVER(2) / O0000000000000000 /
C
C     DATA LOG10(1) / O1157163034761674 /
C     DATA LOG10(2) / O0006677466732724 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C     DATA SMALL(1) / 00604000000000000000B /
C     DATA SMALL(2) / 00000000000000000000B /
C
C     DATA LARGE(1) / 37767777777777777777B /
C     DATA LARGE(2) / 37167777777777777777B /
C
C     DATA RIGHT(1) / 15604000000000000000B /
C     DATA RIGHT(2) / 15000000000000000000B /
C
C     DATA DIVER(1) / 15614000000000000000B /
C     DATA DIVER(2) / 15010000000000000000B /
C
C     DATA LOG10(1) / 17164642023241175717B /
C     DATA LOG10(2) / 16367571421742254654B /
C
C     MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA SMALL(1) / 200004000000000000000B /
C     DATA SMALL(2) / 00000000000000000000B /
C
C     DATA LARGE(1) / 577777777777777777777B /
C     DATA LARGE(2) / 000007777777777777777B /
C
C     DATA RIGHT(1) / 377214000000000000000B /
C     DATA RIGHT(2) / 000000000000000000000B /
C
C     DATA DIVER(1) / 377224000000000000000B /
C     DATA DIVER(2) / 000000000000000000000B /
C
C     DATA LOG10(1) / 377774642023241175717B /
C     DATA LOG10(2) / 000007571421742254654B /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
C     STATIC DMACH(5)
C
C     DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/
C     DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/
C     DATA LOG10/40423K,42023K,50237K,74776K/
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C
C     DATA SMALL(1),SMALL(2) / '20000000, '00000201 /
C     DATA LARGE(1),LARGE(2) / '37777777, '37777577 /
C     DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 /
C     DATA DIVER(1),DIVER(2) / '20000000, '00000334 /
C     DATA LOG10(1),LOG10(2) / '23210115, '10237777 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C     DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C     DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C     DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C     DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C     DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86.
C
C     DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 /
C     DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF /
C     DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 /
C     DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 /
C     DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C     DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 /
C     DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 /
C     DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 /
C     DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 /
C     DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C     DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 /
C     DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 /
C     DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 /
C     DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 /
C     DATA LOG10(1),LOG10(2) / "177464202324, "476747767461 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /    8388608,           0 /
C     DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
C     DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
C     DATA DIVER(1),DIVER(2) /  620756992,           0 /
C     DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /
C
C     DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 /
C     DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 /
C     DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 /
C     DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 /
C     DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /    128,      0 /
C     DATA SMALL(3),SMALL(4) /      0,      0 /
C
C     DATA LARGE(1),LARGE(2) /  32767,     -1 /
C     DATA LARGE(3),LARGE(4) /     -1,     -1 /
C
C     DATA RIGHT(1),RIGHT(2) /   9344,      0 /
C     DATA RIGHT(3),RIGHT(4) /      0,      0 /
C
C     DATA DIVER(1),DIVER(2) /   9472,      0 /
C     DATA DIVER(3),DIVER(4) /      0,      0 /
C
C     DATA LOG10(1),LOG10(2) /  16282,   8346 /
C     DATA LOG10(3),LOG10(4) / -31493, -12296 /
C
C     DATA SMALL(1),SMALL(2) / O000200, O000000 /
C     DATA SMALL(3),SMALL(4) / O000000, O000000 /
C
C     DATA LARGE(1),LARGE(2) / O077777, O177777 /
C     DATA LARGE(3),LARGE(4) / O177777, O177777 /
C
C     DATA RIGHT(1),RIGHT(2) / O022200, O000000 /
C     DATA RIGHT(3),RIGHT(4) / O000000, O000000 /
C
C     DATA DIVER(1),DIVER(2) / O022400, O000000 /
C     DATA DIVER(3),DIVER(4) / O000000, O000000 /
C
C     DATA LOG10(1),LOG10(2) / O037632, O020232 /
C     DATA LOG10(3),LOG10(4) / O102373, O147770 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C     DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C     DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C     DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C     DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /
C
C
      IF (I .LT. 1  .OR.  I .GT. 5)
     1   CALL SETERR(24HD1MACH - I OUT OF BOUNDS,24,1,2)
C
      D1MACH = DMACH(I)
      RETURN
C
      END
      INTEGER FUNCTION NERROR(NERR)                                     ERRN0000
C
C  RETURNS NERROR = NERR = THE VALUE OF THE ERROR FLAG LERROR.
C
      NERROR=I8SAVE(1,0,.FALSE.)
      NERR=NERROR
      RETURN
C
      END
      SUBROUTINE ERROFF                                                 ERRF0000
C
C  TURNS OFF THE ERROR STATE OFF BY SETTING LERROR=0.
C
      I=I8SAVE(1,0,.TRUE.)
      RETURN
C
      END
      SUBROUTINE SETERR(MESSG,NMESSG,NERR,IOPT)                         ERRS0000
C
C  SETERR SETS LERROR = NERR, OPTIONALLY PRINTS THE MESSAGE AND DUMPS
C  ACCORDING TO THE FOLLOWING RULES...
C
C    IF IOPT = 1 AND RECOVERING      - JUST REMEMBER THE ERROR.
C    IF IOPT = 1 AND NOT RECOVERING  - PRINT AND STOP.
C    IF IOPT = 2                     - PRINT, DUMP AND STOP.
C
C  INPUT
C
C    MESSG  - THE ERROR MESSAGE.
C    NMESSG - THE LENGTH OF THE MESSAGE, IN CHARACTERS.
C    NERR   - THE ERROR NUMBER. MUST HAVE NERR NON-ZERO.
C    IOPT   - THE OPTION. MUST HAVE IOPT=1 OR 2.
C
C  ERROR STATES -
C
C    1 - MESSAGE LENGTH NOT POSITIVE.
C    2 - CANNOT HAVE NERR=0.
C    3 - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.
C    4 - BAD VALUE FOR IOPT.
C
C  ONLY THE FIRST 72 CHARACTERS OF THE MESSAGE ARE PRINTED.
C
C  THE ERROR HANDLER CALLS A SUBROUTINE NAMED FDUMP TO PRODUCE A
C  SYMBOLIC DUMP. TO COMPLETE THE PACKAGE, A DUMMY VERSION OF FDUMP
C  IS SUPPLIED, BUT IT SHOULD BE REPLACED BY A LOCALLY WRITTEN VERSION
C  WHICH AT LEAST GIVES A TRACE-BACK.
C
      INTEGER MESSG(1)
C
C  THE UNIT FOR ERROR MESSAGES.
C
      IWUNIT=I1MACH(4)
C
      IF (NMESSG.GE.1) GO TO 10
C
C  A MESSAGE OF NON-POSITIVE LENGTH IS FATAL.
C
        WRITE(IWUNIT,9000)
 9000   FORMAT(52H1ERROR    1 IN SETERR - MESSAGE LENGTH NOT POSITIVE.)
        GO TO 60
C
C  NW IS THE NUMBER OF WORDS THE MESSAGE OCCUPIES.
C
 10   NW=(MIN0(NMESSG,72)-1)/I1MACH(6)+1
C
      IF (NERR.NE.0) GO TO 20
C
C  CANNOT TURN THE ERROR STATE OFF USING SETERR.
C
        WRITE(IWUNIT,9001)
 9001   FORMAT(42H1ERROR    2 IN SETERR - CANNOT HAVE NERR=0//
     1         34H THE CURRENT ERROR MESSAGE FOLLOWS///)
        CALL E9RINT(MESSG,NW,NERR,.TRUE.)
        ITEMP=I8SAVE(1,1,.TRUE.)
        GO TO 50
C
C  SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR.
C
 20   IF (I8SAVE(1,NERR,.TRUE.).EQ.0) GO TO 30
C
        WRITE(IWUNIT,9002)
 9002   FORMAT(23H1ERROR    3 IN SETERR -,
     1         48H AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.//
     2         48H THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.///)
        CALL EPRINT
        CALL E9RINT(MESSG,NW,NERR,.TRUE.)
        GO TO 50
C
C  SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY.
C
 30   CALL E9RINT(MESSG,NW,NERR,.TRUE.)
C
      IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40
C
C  MUST HAVE IOPT = 1 OR 2.
C
        WRITE(IWUNIT,9003)
 9003   FORMAT(42H1ERROR    4 IN SETERR - BAD VALUE FOR IOPT//
     1         34H THE CURRENT ERROR MESSAGE FOLLOWS///)
        GO TO 50
C
C  TEST FOR RECOVERY.
C
 40   IF (IOPT.EQ.2) GO TO 50
C
      IF (I8SAVE(2,0,.FALSE.).EQ.1) RETURN
C
      CALL EPRINT
      STOP
C
 50   CALL EPRINT
 60   CALL FDUMP
      STOP
C
      END
      SUBROUTINE EPRINT                                                 ERRP0000
C
C  THIS SUBROUTINE PRINTS THE LAST ERROR MESSAGE, IF ANY.
C
      INTEGER MESSG(1)
C
      CALL E9RINT(MESSG,1,1,.FALSE.)
      RETURN
C
      END
      SUBROUTINE E9RINT(MESSG,NW,NERR,SAVE)                             ERRR0000
C
C  THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE,
C  IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. .
C
      INTEGER MESSG(NW)
      LOGICAL SAVE
C
C  MESSGP STORES AT LEAST THE FIRST 72 CHARACTERS OF THE PREVIOUS
C  MESSAGE. ITS LENGTH IS MACHINE DEPENDENT AND MUST BE AT LEAST
C
C       1 + 71/(THE NUMBER OF CHARACTERS STORED PER INTEGER WORD).
C
      INTEGER MESSGP(36),FMT(14),CCPLUS
C
C  START WITH NO PREVIOUS MESSAGE.
C
      DATA MESSGP(1)/1H1/, NWP/0/, NERRP/0/
C
C  SET UP THE FORMAT FOR PRINTING THE ERROR MESSAGE.
C  THE FORMAT IS SIMPLY (A1,14X,72AXX) WHERE XX=I1MACH(6) IS THE
C  NUMBER OF CHARACTERS STORED PER INTEGER WORD.
C
      DATA CCPLUS  / 1H+ /
C
      DATA FMT( 1) / 1H( /
      DATA FMT( 2) / 1HA /
      DATA FMT( 3) / 1H1 /
      DATA FMT( 4) / 1H, /
      DATA FMT( 5) / 1H1 /
      DATA FMT( 6) / 1H4 /
      DATA FMT( 7) / 1HX /
      DATA FMT( 8) / 1H, /
      DATA FMT( 9) / 1H7 /
      DATA FMT(10) / 1H2 /
      DATA FMT(11) / 1HA /
      DATA FMT(12) / 1HX /
      DATA FMT(13) / 1HX /
      DATA FMT(14) / 1H) /
C
      IF (.NOT.SAVE) GO TO 20
C
C  SAVE THE MESSAGE.
C
        NWP=NW
        NERRP=NERR
        DO 10 I=1,NW
 10     MESSGP(I)=MESSG(I)
C
        GO TO 30
C
 20   IF (I8SAVE(1,0,.FALSE.).EQ.0) GO TO 30
C
C  PRINT THE MESSAGE.
C
        IWUNIT=I1MACH(4)
        WRITE(IWUNIT,9000) NERRP
 9000   FORMAT(7H ERROR ,I4,4H IN )
C
        CALL S88FMT(2,I1MACH(6),FMT(12))
        WRITE(IWUNIT,FMT) CCPLUS,(MESSGP(I),I=1,NWP)
C
 30   RETURN
C
      END
      INTEGER FUNCTION I1MACH(I)                                        MCHI0000
C
C  I/O UNIT NUMBERS.
C
C    I1MACH( 1) = THE STANDARD INPUT UNIT.
C
C    I1MACH( 2) = THE STANDARD OUTPUT UNIT.
C
C    I1MACH( 3) = THE STANDARD PUNCH UNIT.
C
C    I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.
C
C  WORDS.
C
C    I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
C
C    I1MACH( 6) = THE NUMBER OF CHARACTERS PER INTEGER STORAGE UNIT.
C
C  INTEGERS.
C
C    ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM
C
C               SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
C
C               WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1.
C
C    I1MACH( 7) = A, THE BASE.
C
C    I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS.
C
C    I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE.
C
C  FLOATING-POINT NUMBERS.
C
C    ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT,
C    BASE-B FORM
C
C               SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C
C               WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T,
C               0 .LT. X(1), AND EMIN .LE. E .LE. EMAX.
C
C    I1MACH(10) = B, THE BASE.
C
C  SINGLE-PRECISION
C
C    I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS.
C
C    I1MACH(12) = EMIN, THE SMALLEST EXPONENT E.
C
C    I1MACH(13) = EMAX, THE LARGEST EXPONENT E.
C
C  DOUBLE-PRECISION
C
C    I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS.
C
C    I1MACH(15) = EMIN, THE SMALLEST EXPONENT E.
C
C    I1MACH(16) = EMAX, THE LARGEST EXPONENT E.
C
C  TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT,
C  THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY
C  REMOVING THE C FROM COLUMN 1.  ALSO, THE VALUES OF
C  I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY
C  WITH THE LOCAL OPERATING SYSTEM.
C
      INTEGER IMACH(16),OUTPUT
C
      EQUIVALENCE (IMACH(4),OUTPUT)
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA IMACH( 1) /    7 /
C     DATA IMACH( 2) /    2 /
C     DATA IMACH( 3) /    2 /
C     DATA IMACH( 4) /    2 /
C     DATA IMACH( 5) /   36 /
C     DATA IMACH( 6) /    4 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   33 /
C     DATA IMACH( 9) / Z1FFFFFFFF /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   24 /
C     DATA IMACH(12) / -256 /
C     DATA IMACH(13) /  255 /
C     DATA IMACH(14) /   60 /
C     DATA IMACH(15) / -256 /
C     DATA IMACH(16) /  255 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C     DATA IMACH( 1) /   5 /
C     DATA IMACH( 2) /   6 /
C     DATA IMACH( 3) /   7 /
C     DATA IMACH( 4) /   6 /
C     DATA IMACH( 5) /  48 /
C     DATA IMACH( 6) /   6 /
C     DATA IMACH( 7) /   2 /
C     DATA IMACH( 8) /  39 /
C     DATA IMACH( 9) / O0007777777777777 /
C     DATA IMACH(10) /   8 /
C     DATA IMACH(11) /  13 /
C     DATA IMACH(12) / -50 /
C     DATA IMACH(13) /  76 /
C     DATA IMACH(14) /  26 /
C     DATA IMACH(15) / -50 /
C     DATA IMACH(16) /  76 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C     DATA IMACH( 1) /   5 /
C     DATA IMACH( 2) /   6 /
C     DATA IMACH( 3) /   7 /
C     DATA IMACH( 4) /   6 /
C     DATA IMACH( 5) /  48 /
C     DATA IMACH( 6) /   6 /
C     DATA IMACH( 7) /   2 /
C     DATA IMACH( 8) /  39 /
C     DATA IMACH( 9) / O0007777777777777 /
C     DATA IMACH(10) /   8 /
C     DATA IMACH(11) /  13 /
C     DATA IMACH(12) / -50 /
C     DATA IMACH(13) /  76 /
C     DATA IMACH(14) /  26 /
C     DATA IMACH(15) / -32754 /
C     DATA IMACH(16) /  32780 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /    7 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   60 /
C     DATA IMACH( 6) /   10 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   48 /
C     DATA IMACH( 9) / 00007777777777777777B /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   48 /
C     DATA IMACH(12) / -974 /
C     DATA IMACH(13) / 1070 /
C     DATA IMACH(14) /   96 /
C     DATA IMACH(15) / -927 /
C     DATA IMACH(16) / 1070 /
C
C     MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA IMACH( 1) /   100 /
C     DATA IMACH( 2) /   101 /
C     DATA IMACH( 3) /   102 /
C     DATA IMACH( 4) /   101 /
C     DATA IMACH( 5) /    64 /
C     DATA IMACH( 6) /     8 /
C     DATA IMACH( 7) /     2 /
C     DATA IMACH( 8) /    63 /
C     DATA IMACH( 9) /  777777777777777777777B /
C     DATA IMACH(10) /     2 /
C     DATA IMACH(11) /    48 /
C     DATA IMACH(12) / -8192 /
C     DATA IMACH(13) /  8191 /
C     DATA IMACH(14) /    96 /
C     DATA IMACH(15) / -8192 /
C     DATA IMACH(16) /  8191 /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     DATA IMACH( 1) /   11 /
C     DATA IMACH( 2) /   12 /
C     DATA IMACH( 3) /    8 /
C     DATA IMACH( 4) /   10 /
C     DATA IMACH( 5) /   16 /
C     DATA IMACH( 6) /    2 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   15 /
C     DATA IMACH( 9) /32767 /
C     DATA IMACH(10) /   16 /
C     DATA IMACH(11) /    6 /
C     DATA IMACH(12) /  -64 /
C     DATA IMACH(13) /   63 /
C     DATA IMACH(14) /   14 /
C     DATA IMACH(15) /  -64 /
C     DATA IMACH(16) /   63 /
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C
C     DATA IMACH( 1) /       5 /
C     DATA IMACH( 2) /       6 /
C     DATA IMACH( 3) /       0 /
C     DATA IMACH( 4) /       6 /
C     DATA IMACH( 5) /      24 /
C     DATA IMACH( 6) /       3 /
C     DATA IMACH( 7) /       2 /
C     DATA IMACH( 8) /      23 /
C     DATA IMACH( 9) / 8388607 /
C     DATA IMACH(10) /       2 /
C     DATA IMACH(11) /      23 /
C     DATA IMACH(12) /    -127 /
C     DATA IMACH(13) /     127 /
C     DATA IMACH(14) /      38 /
C     DATA IMACH(15) /    -127 /
C     DATA IMACH(16) /     127 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /   43 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   36 /
C     DATA IMACH( 6) /    6 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   35 /
C     DATA IMACH( 9) / O377777777777 /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   27 /
C     DATA IMACH(12) / -127 /
C     DATA IMACH(13) /  127 /
C     DATA IMACH(14) /   63 /
C     DATA IMACH(15) / -127 /
C     DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86.
C
C     DATA IMACH( 1) /   5 /
C     DATA IMACH( 2) /   6 /
C     DATA IMACH( 3) /   7 /
C     DATA IMACH( 4) /   6 /
C     DATA IMACH( 5) /  32 /
C     DATA IMACH( 6) /   4 /
C     DATA IMACH( 7) /   2 /
C     DATA IMACH( 8) /  31 /
C     DATA IMACH( 9) / Z7FFFFFFF /
C     DATA IMACH(10) /  16 /
C     DATA IMACH(11) /   6 /
C     DATA IMACH(12) / -64 /
C     DATA IMACH(13) /  63 /
C     DATA IMACH(14) /  14 /
C     DATA IMACH(15) / -64 /
C     DATA IMACH(16) /  63 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /    5 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   36 /
C     DATA IMACH( 6) /    5 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   35 /
C     DATA IMACH( 9) / "377777777777 /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   27 /
C     DATA IMACH(12) / -128 /
C     DATA IMACH(13) /  127 /
C     DATA IMACH(14) /   54 /
C     DATA IMACH(15) / -101 /
C     DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /    5 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   36 /
C     DATA IMACH( 6) /    5 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   35 /
C     DATA IMACH( 9) / "377777777777 /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   27 /
C     DATA IMACH(12) / -128 /
C     DATA IMACH(13) /  127 /
C     DATA IMACH(14) /   62 /
C     DATA IMACH(15) / -128 /
C     DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     32-BIT INTEGER ARITHMETIC.
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /    5 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   32 /
C     DATA IMACH( 6) /    4 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   31 /
C     DATA IMACH( 9) / 2147483647 /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   24 /
C     DATA IMACH(12) / -127 /
C     DATA IMACH(13) /  127 /
C     DATA IMACH(14) /   56 /
C     DATA IMACH(15) / -127 /
C     DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     16-BIT INTEGER ARITHMETIC.
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /    5 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   16 /
C     DATA IMACH( 6) /    2 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   15 /
C     DATA IMACH( 9) / 32767 /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   24 /
C     DATA IMACH(12) / -127 /
C     DATA IMACH(13) /  127 /
C     DATA IMACH(14) /   56 /
C     DATA IMACH(15) / -127 /
C     DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7
C     WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM.
C     IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1.
C
C     DATA IMACH( 1) /    5 /
C     DATA IMACH( 2) /    6 /
C     DATA IMACH( 3) /    7 /
C     DATA IMACH( 4) /    6 /
C     DATA IMACH( 5) /   36 /
C     DATA IMACH( 6) /    6 /
C     DATA IMACH( 7) /    2 /
C     DATA IMACH( 8) /   35 /
C     DATA IMACH( 9) / O377777777777 /
C     DATA IMACH(10) /    2 /
C     DATA IMACH(11) /   27 /
C     DATA IMACH(12) / -128 /
C     DATA IMACH(13) /  127 /
C     DATA IMACH(14) /   60 /
C     DATA IMACH(15) /-1024 /
C     DATA IMACH(16) / 1023 /
C
      IF (I .LT. 1  .OR.  I .GT. 16) GO TO 10
C
      I1MACH=IMACH(I)
      RETURN
C
 10   WRITE(OUTPUT,9000)
 9000 FORMAT(39H1ERROR    1 IN I1MACH - I OUT OF BOUNDS)
C
      CALL FDUMP
C
      STOP
C
      END
      INTEGER FUNCTION I8SAVE(ISW,IVALUE,SET)                           ERRV0000
C
C  IF (ISW = 1) I8SAVE RETURNS THE CURRENT ERROR NUMBER AND
C               SETS IT TO IVALUE IF SET = .TRUE. .
C
C  IF (ISW = 2) I8SAVE RETURNS THE CURRENT RECOVERY SWITCH AND
C               SETS IT TO IVALUE IF SET = .TRUE. .
C
      LOGICAL SET
C
      INTEGER IPARAM(2)
      EQUIVALENCE (IPARAM(1),LERROR) , (IPARAM(2),LRECOV)
C
C  START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF.
C
      DATA LERROR/0/ , LRECOV/2/
C
      I8SAVE=IPARAM(ISW)
      IF (SET) IPARAM(ISW)=IVALUE
C
      RETURN
C
      END
      SUBROUTINE S88FMT( N, W, IFMT )                                   ERRM0000
C
C  S88FMT  REPLACES IFMT(1), ... , IFMT(N) WITH
C  THE CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT
C  DIGITS OF W.
C
      INTEGER N,W,IFMT(N)
C
      INTEGER NT,WT,DIGITS(10)
C
      DATA DIGITS( 1) / 1H0 /
      DATA DIGITS( 2) / 1H1 /
      DATA DIGITS( 3) / 1H2 /
      DATA DIGITS( 4) / 1H3 /
      DATA DIGITS( 5) / 1H4 /
      DATA DIGITS( 6) / 1H5 /
      DATA DIGITS( 7) / 1H6 /
      DATA DIGITS( 8) / 1H7 /
      DATA DIGITS( 9) / 1H8 /
      DATA DIGITS(10) / 1H9 /
C
      NT = N
      WT = W
C
 10   IF (NT .LE. 0) RETURN
        IDIGIT = MOD( WT, 10 )
        IFMT(NT) = DIGITS(IDIGIT+1)
        WT = WT/10
        NT = NT - 1
        GO TO 10
C
      END
      SUBROUTINE FDUMP                                                  FDMP0000
C  THIS IS A DUMMY ROUTINE TO BE SENT OUT ON
C  THE PORT SEDIT TAPE
C
      RETURN
      END
C  MAIN PROGRAM                                                         THYP0010
C **********************************************                        THYP0020
C                                                                       THYP0030
C  TEST OF PORT LINGUISTIC HYPOTHESES                                   THYP0040
C                                                                       THYP0050
C **********************************************                        THYP0060
C                                                                       THYP0070
      COMMON /OK/ CREM, DREM, RREM, IREM, LREM, CIDX, DIDX, RIDX, IIDX  THYP0080
     1   , LIDX                                                         THYP0090
      LOGICAL CREM, DREM, RREM, IREM, LREM, CIDX                        THYP0100
      LOGICAL DIDX, RIDX, IIDX, LIDX                                    THYP0110
      COMMON /LNAME/ L                                                  THYP0120
      LOGICAL L(1000)                                                   THYP0130
      COMMON /INAME/ I                                                  THYP0140
      INTEGER I(1000)                                                   THYP0150
      COMMON /RNAME/ R                                                  THYP0160
      REAL R(1000)                                                      THYP0170
      COMMON /DNAME/ D                                                  THYP0180
      DOUBLE PRECISION D(1000)                                          THYP0190
      COMMON /CNAME/ C                                                  THYP0200
      COMPLEX C(1000)                                                   THYP0210
      INTEGER P, I1MACH                                                 THYP0220
      REAL FLOAT                                                        THYP0230
      LOGICAL LOGVAR                                                    THYP0240
      COMPLEX CMPLX                                                     THYP0250
      INTEGER TEMP                                                      THYP0260
C TO TEST THE PORT LINGUISTIC HYPOTHESES.                               THYP0270
C .REM MEANS REMEMBERED AND .IDX MEANS INDEXING OK IN THE FOLLOWING.    THYP0280
      CREM = .TRUE.                                                     THYP0290
      DREM = .TRUE.                                                     THYP0300
      RREM = .TRUE.                                                     THYP0310
      IREM = .TRUE.                                                     THYP0320
      LREM = .TRUE.                                                     THYP0330
      CIDX = .TRUE.                                                     THYP0340
      DIDX = .TRUE.                                                     THYP0350
      RIDX = .TRUE.                                                     THYP0360
      IIDX = .TRUE.                                                     THYP0370
      LIDX = .TRUE.                                                     THYP0380
      LOGVAR = .TRUE.                                                   THYP0390
C MAKE SOME DATA.                                                       THYP0400
      DO  1 P = 1, 1000                                                 THYP0410
         C(P) = CMPLX(-FLOAT(P), FLOAT(P))                              THYP0420
         D(P) = P                                                       THYP0430
         R(P) = -P                                                      THYP0440
         I(P) = P                                                       THYP0450
         L(P) = LOGVAR                                                  THYP0460
         LOGVAR = .NOT. LOGVAR                                          THYP0470
   1     CONTINUE                                                       THYP0480
C CHECK IT IN ARGUMENT AND COMMON LISTS.                                THYP0490
      DO  2 P = 1, 999                                                  THYP0500
         CALL CHECK(C, D, R, I, L, P)                                   THYP0510
   2     CONTINUE                                                       THYP0520
      IF (CREM) GOTO 4                                                  THYP0530
         TEMP = I1MACH(2)                                               THYP0540
         WRITE (TEMP,  3)                                               THYP0550
   3     FORMAT (49H COMPLEX VALUES NOT REMEMBERED BY DATA STATEMENT.)  THYP0560
   4  IF (DREM) GOTO 6                                                  THYP0570
         TEMP = I1MACH(2)                                               THYP0580
         WRITE (TEMP,  5)                                               THYP0590
   5     FORMAT (                                                       THYP0600
     1     58H DOUBLE PRECISION VALUES NOT REMEMBERED BY DATA STATEMENT.THYP0610
     2      )                                                           THYP0620
   6  IF (RREM) GOTO 8                                                  THYP0630
         TEMP = I1MACH(2)                                               THYP0640
         WRITE (TEMP,  7)                                               THYP0650
   7     FORMAT (46H REAL VALUES NOT REMEMBERED BY DATA STATEMENT.)     THYP0660
   8  IF (IREM) GOTO 10                                                 THYP0670
         TEMP = I1MACH(2)                                               THYP0680
         WRITE (TEMP,  9)                                               THYP0690
   9     FORMAT (49H INTEGER VALUES NOT REMEMBERED BY DATA STATEMENT.)  THYP0700
  10  IF (LREM) GOTO 12                                                 THYP0710
         TEMP = I1MACH(2)                                               THYP0720
         WRITE (TEMP,  11)                                              THYP0730
  11     FORMAT (49H LOGICAL VALUES NOT REMEMBERED BY DATA STATEMENT.)  THYP0740
  12  IF (CIDX) GOTO 14                                                 THYP0750
         TEMP = I1MACH(2)                                               THYP0760
         WRITE (TEMP,  13)                                              THYP0770
  13     FORMAT (45H COMPLEX INDICES LARGER THAN ONE NOT ALLOWED.)      THYP0780
  14  IF (DIDX) GOTO 16                                                 THYP0790
         TEMP = I1MACH(2)                                               THYP0800
         WRITE (TEMP,  15)                                              THYP0810
  15     FORMAT (                                                       THYP0820
     1      54H DOUBLE PRECISION INDICES LARGER THAN ONE NOT ALLOWED.)  THYP0830
  16  IF (RIDX) GOTO 18                                                 THYP0840
         TEMP = I1MACH(2)                                               THYP0850
         WRITE (TEMP,  17)                                              THYP0860
  17     FORMAT (42H REAL INDICES LARGER THAN ONE NOT ALLOWED.)         THYP0870
  18  IF (IIDX) GOTO 20                                                 THYP0880
         TEMP = I1MACH(2)                                               THYP0890
         WRITE (TEMP,  19)                                              THYP0900
  19     FORMAT (45H INTEGER INDICES LARGER THAN ONE NOT ALLOWED.)      THYP0910
  20  IF (LIDX) GOTO 22                                                 THYP0920
         TEMP = I1MACH(2)                                               THYP0930
         WRITE (TEMP,  21)                                              THYP0940
  21     FORMAT (45H LOGICAL INDICES LARGER THAN ONE NOT ALLOWED.)      THYP0950
  22  TEMP = I1MACH(2)                                                  THYP0960
      WRITE (TEMP,  23)                                                 THYP0970
  23  FORMAT (45H TEST OF PORT LINGUISTIC HYPOTHESES COMPLETE.)         THYP0980
      STOP                                                              THYP0990
      END                                                               THYP1000
      SUBROUTINE CHECK(C, D, R, I, L, P)                                THYP1010
      INTEGER I(1), P
      REAL R(1)
      LOGICAL L(1)
      COMPLEX C(1)
      DOUBLE PRECISION D(1)
      COMMON /OK/ CREM, DREM, RREM, IREM, LREM, CIDX, DIDX, RIDX, IIDX
     1   , LIDX
      LOGICAL CREM, DREM, RREM, IREM, LREM, CIDX
      LOGICAL DIDX, RIDX, IIDX, LIDX
      COMMON /LNAME/ CL
      LOGICAL CL(1)
      COMMON /INAME/ CI
      INTEGER CI(1)
      COMMON /RNAME/ CR
      REAL CR(1)
      COMMON /DNAME/ CD
      DOUBLE PRECISION CD(1)
      COMMON /CNAME/ CC
      COMPLEX CC(1)
      INTEGER LI, Q, I1MACH
      REAL LR, AIMAG, REAL
      LOGICAL LL
      COMPLEX LC
      DOUBLE PRECISION LD
      INTEGER TEMP
      DATA LC/(-1.,  1.)/
      DATA LD/1.0D0/
      DATA LR/-1.0E0/
      DATA LI/1/
      DATA LL/.TRUE./
C LOCAL VARIABLES.
C START LOCAL VARIABLES AS COMMON
C VARIABLES BEGIN.
      IF (P .NE. 1) GOTO 11
         IF (REAL(LC) .EQ. REAL(C(P)) .AND. AIMAG(LC) .EQ. AIMAG(C(P))
     1      ) GOTO 2
            TEMP = I1MACH(2)
C CHECK DATA VALUES OF LOCAL VARIABLES.
            WRITE (TEMP,  1)
   1        FORMAT (34H DATA STATEMENT FAILS FOR COMPLEX.)
   2     IF (LD .EQ. D(P)) GOTO 4
            TEMP = I1MACH(2)
            WRITE (TEMP,  3)
   3        FORMAT (43H DATA STATEMENT FAILS FOR DOUBLE PRECISION.)
   4     IF (LR .EQ. R(P)) GOTO 6
            TEMP = I1MACH(2)
            WRITE (TEMP,  5)
   5        FORMAT (31H DATA STATEMENT FAILS FOR REAL.)
   6     IF (LI .EQ. I(P)) GOTO 8
            TEMP = I1MACH(2)
            WRITE (TEMP,  7)
   7        FORMAT (34H DATA STATEMENT FAILS FOR INTEGER.)
   8     IF ((LL .OR. (.NOT. L(P))) .AND. ((.NOT. LL) .OR. L(P))) GOTO
     1      10
            TEMP = I1MACH(2)
            WRITE (TEMP,  9)
   9        FORMAT (34H DATA STATEMENT FAILS FOR LOGICAL.)
  10     CONTINUE
         GOTO  12
  11     IF (REAL(LC) .NE. REAL(C(P)) .OR. AIMAG(LC) .NE. AIMAG(C(P)))
     1       CREM = .FALSE.
C CHECK THE REMEMBERED LOCAL VALUES.
         IF (LD .NE. D(P)) DREM = .FALSE.
         IF (LR .NE. R(P)) RREM = .FALSE.
         IF (LI .NE. I(P)) IREM = .FALSE.
         IF ((.NOT. LL) .AND. L(P) .OR. LL .AND. (.NOT. L(P))) LREM =
     1      .FALSE.
C MAKE A LOCAL COPY OF THE NEXT VALUES TO BE SEEN BY CHECK.
  12  LC = C(P+1)
      LD = D(P+1)
      LR = R(P+1)
      LI = I(P+1)
      LL = L(P+1)
      IF (P .NE. 1) GOTO 13
         IF (REAL(LC) .EQ. (-1.) .AND. AIMAG(LC) .EQ. 1.) CIDX =
     1      .FALSE.
C CHECK THAT LOCAL VARIABLES WERE REALLY UPDATED.
         IF (LD .EQ. 1D0) DIDX = .FALSE.
         IF (LR .EQ. (-1.)) RIDX = .FALSE.
         IF (LI .EQ. 1) IIDX = .FALSE.
         IF (LL) LIDX = .FALSE.
C CHECK THAT THE LOCAL VARIABLES WERE UPDATED.
  13  IF (REAL(LC) .EQ. REAL(C(P)) .AND. AIMAG(LC) .EQ. AIMAG(C(P)))
     1   CIDX = .FALSE.
      IF (LD .EQ. D(P)) DIDX = .FALSE.
      IF (LR .EQ. R(P)) RIDX = .FALSE.
      IF (LI .EQ. I(P)) IIDX = .FALSE.
      IF (LL .AND. L(P) .OR. (.NOT. LL) .AND. (.NOT. L(P))) LIDX =
     1   .FALSE.
      DO  14 Q = P, 999
         IF (REAL(C(Q+1)) .NE. REAL(CC(Q+1)) .OR. AIMAG(C(Q+1)) .NE.
     1      AIMAG(CC(Q+1))) CIDX = .FALSE.
         IF (D(Q+1) .NE. CD(Q+1)) DIDX = .FALSE.
         IF (R(Q+1) .NE. CR(Q+1)) RIDX = .FALSE.
         IF (I(Q+1) .NE. CI(Q+1)) IIDX = .FALSE.
         IF ((.NOT. L(Q+1)) .AND. CL(Q+1) .OR. L(Q+1) .AND. (.NOT. CL(Q+
     1      1))) LIDX = .FALSE.
  14     CONTINUE
      RETURN
      END
C  MAIN PROGRAM                                                         MACH0010
C **********************************************                        MACH0020
C                                                                       MACH0030
C  TEST OF PORT MACHINE CONSTANTS (FOR CONSISTENCY)                     MACH0040
C                                                                       MACH0050
C **********************************************                        MACH0060
C                                                                       MACH0070
      CALL S1MACH                                                       MACH0080
      STOP                                                              MACH0090
      END                                                               MACH0100
      SUBROUTINE S1MACH                                                 MACH0110
C
C  S1MACH TESTS THE CONSISTENCY OF THE MACHINE CONSTANTS IN
C  I1MACH, R1MACH AND D1MACH.
C
      INTEGER IMACH(16),I1MACH
      INTEGER STDOUT
      INTEGER DIGINT, DIGSP, DIGDP
      REAL RMACH(5),R1MACH
      REAL S2MACH, XR
      REAL SBASE, SBASEM
      DOUBLE PRECISION DMACH(5),D1MACH
      DOUBLE PRECISION S3MACH, XD
      DOUBLE PRECISION DBASE, DBASEM
C
      INTEGER IFMT(12)
      INTEGER EFMT(15)
      INTEGER DFMT(15)
      INTEGER CCPLUS
      INTEGER DWIDTH, WWIDTH, EWIDTH
      INTEGER DEMAX, DEMIN
C
      EQUIVALENCE ( STDOUT, IMACH(2) )
      EQUIVALENCE ( DIGINT, IMACH(8) )
      EQUIVALENCE ( DIGSP,  IMACH(11) )
      EQUIVALENCE ( DIGDP,  IMACH(14) )
C
      DATA CCPLUS   / 1H+ /
C
      DATA IFMT(1 ) / 1H( /
      DATA IFMT(2 ) / 1HA /
      DATA IFMT(3 ) / 1H1 /
      DATA IFMT(4 ) / 1H, /
      DATA IFMT(5 ) / 1H5 /
      DATA IFMT(6 ) / 1H1 /
      DATA IFMT(7 ) / 1HX /
      DATA IFMT(8 ) / 1H, /
      DATA IFMT(9 ) / 1HI /
      DATA IFMT(10) / 1H  /
      DATA IFMT(11) / 1H  /
      DATA IFMT(12) / 1H) /
C
      DATA EFMT( 1) / 1H( /,    DFMT( 1) / 1H( /
      DATA EFMT( 2) / 1HA /,    DFMT( 2) / 1HA /
      DATA EFMT( 3) / 1H1 /,    DFMT( 3) / 1H1 /
      DATA EFMT( 4) / 1H, /,    DFMT( 4) / 1H, /
      DATA EFMT( 5) / 1H3 /,    DFMT( 5) / 1H3 /
      DATA EFMT( 6) / 1H2 /,    DFMT( 6) / 1H2 /
      DATA EFMT( 7) / 1HX /,    DFMT( 7) / 1HX /
      DATA EFMT( 8) / 1H, /,    DFMT( 8) / 1H, /
      DATA EFMT( 9) / 1HE /,    DFMT( 9) / 1HD /
      DATA EFMT(10) / 1H  /,    DFMT(10) / 1H  /
      DATA EFMT(11) / 1H  /,    DFMT(11) / 1H  /
      DATA EFMT(12) / 1H. /,    DFMT(12) / 1H. /
      DATA EFMT(13) / 1H  /,    DFMT(13) / 1H  /
      DATA EFMT(14) / 1H  /,    DFMT(14) / 1H  /
      DATA EFMT(15) / 1H) /,    DFMT(15) / 1H) /
C
C  FETCH ALL CONSTANTS INTO LOCAL ARRAYS
C
      DO 10 I = 1,16
        IMACH(I) = I1MACH(I)
 10     CONTINUE
C
      DO 20 I = 1,5
        RMACH(I) = R1MACH(I)
        DMACH(I) = D1MACH(I)
 20     CONTINUE
C
C  COMPUTE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING
C  OUT THE LARGEST INTEGER ALLOWING FOR ONE SPACE AND A SIGN
C  AND PLUG THE FIELD WIDTH IN THE FORMAT.
C
      WWIDTH = ICEIL( ALOG10(FLOAT(IMACH(7)))*FLOAT(IMACH(8)) ) + 2
      CALL S88FMT( 2, WWIDTH, IFMT(10) )
C
      WRITE( STDOUT, 900 ) ( IFMT(I), I = 9, 11 )
 900  FORMAT(//37H FORMAT CONVERSION FOR INTEGERS IS - ,3A1
     1       / 25H INTEGER CONSTANTS FOLLOW///)
C
C  NOW WRITE OUT THE INTEGER CONSTANTS
C
      WRITE( STDOUT, 1001 )
 1001 FORMAT(24H THE STANDARD INPUT UNIT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(1)
C
      WRITE( STDOUT, 1002 )
 1002 FORMAT(25H THE STANDARD OUTPUT UNIT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(2)
C
      WRITE( STDOUT, 1003 )
 1003 FORMAT(24H THE STANDARD PUNCH UNIT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(3)
C
      WRITE( STDOUT, 1004 )
 1004 FORMAT(32H THE STANDARD ERROR MESSAGE UNIT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(4)
C
      WRITE( STDOUT, 1005 )
 1005 FORMAT(28H THE NUMBER OF BITS PER WORD)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(5)
C
      WRITE( STDOUT, 1006 )
 1006 FORMAT(34H THE NUMBER OF CHARACTERS PER WORD)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(6)
C
      WRITE( STDOUT, 1007 )
 1007 FORMAT(34H A, THE BASE OF AN S-DIGIT INTEGER)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7)
C
      WRITE( STDOUT, 1008 )
 1008 FORMAT(31H S, THE NUMBER OF BASE-A DIGITS)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8)
C
      WRITE( STDOUT, 1009 )
 1009 FORMAT(32H A**S - 1, THE LARGEST MAGNITUDE)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9)
C
      WRITE( STDOUT, 1010 )
 1010 FORMAT(47H B, THE BASE OF A T-DIGIT FLOATING-POINT NUMBER)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(10)
C
      WRITE( STDOUT, 1011 )
 1011 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN SINGLE-PRECISION)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11)
C
      WRITE( STDOUT, 1012 )
 1012 FORMAT(45H EMIN, THE SMALLEST SINGLE-PRECISION EXPONENT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12)
C
      WRITE( STDOUT, 1013 )
 1013 FORMAT(44H EMAX, THE LARGEST SINGLE-PRECISION EXPONENT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13)
C
      WRITE( STDOUT, 1014 )
 1014 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN DOUBLE-PRECISION)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14)
C
      WRITE( STDOUT, 1015 )
 1015 FORMAT(45H EMIN, THE SMALLEST DOUBLE-PRECISION EXPONENT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15)
C
      WRITE( STDOUT, 1016 )
 1016 FORMAT(44H EMAX, THE LARGEST DOUBLE-PRECISION EXPONENT)
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16)
C
C  COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING
C  OUT A SINGLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND
C  A SIGN AND PLUG THE FIELDS IN THE FORMAT.
C
      DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(11)) )
      CALL S88FMT( 2, DWIDTH, EFMT(13) )
C
      DEMIN =  IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(12)-1) ) + 1
      DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(13)) )
      EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1
      WWIDTH = DWIDTH + EWIDTH + 6
      CALL S88FMT( 2, WWIDTH, EFMT(10) )
C
      WRITE( STDOUT, 1900 ) ( EFMT(I), I = 9, 14 )
 1900 FORMAT(//45H FORMAT CONVERSION FOR SINGLE-PRECISION IS - ,6A1
     1       / 34H SINGLE-PRECISION CONSTANTS FOLLOW///)
C
C  NOW WRITE OUT THE SINGLE-PRECISION CONSTANTS
C
      WRITE( STDOUT, 2001 )
 2001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE)
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1)
C
      WRITE( STDOUT, 2002 )
 2002 FORMAT(22H THE LARGEST MAGNITUDE)
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2)
C
      WRITE( STDOUT, 2003 )
 2003 FORMAT(30H THE SMALLEST RELATIVE SPACING)
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3)
C
      WRITE( STDOUT, 2004 )
 2004 FORMAT(29H THE LARGEST RELATIVE SPACING)
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4)
C
      WRITE( STDOUT, 2005 )
 2005 FORMAT(18H LOG10 OF THE BASE)
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5)
C
      CALL S88FMT( 2, WWIDTH+1, EFMT(10) )
      CALL S88FMT( 2, DWIDTH+1, EFMT(13) )
C
C  COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING
C  OUT A DOUBLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND
C  A SIGN AND PLUG THE FIELDS IN THE FORMAT.
C
      DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(14)) )
      CALL S88FMT( 2, DWIDTH, DFMT(13) )
C
      DEMIN =  IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(15)-1) ) + 1
      DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(16)) )
      EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1
      WWIDTH = DWIDTH + EWIDTH + 6
      CALL S88FMT( 2, WWIDTH, DFMT(10) )
C
      WRITE( STDOUT, 2900 ) ( DFMT(I), I = 9, 14 )
 2900 FORMAT(//45H FORMAT CONVERSION FOR DOUBLE-PRECISION IS - ,6A1
     1       / 34H DOUBLE-PRECISION CONSTANTS FOLLOW///)
C
C  NOW WRITE OUT THE DOUBLE-PRECISION CONSTANTS
C
      WRITE( STDOUT, 3001 )
 3001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE)
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1)
C
      WRITE( STDOUT, 3002 )
 3002 FORMAT(22H THE LARGEST MAGNITUDE)
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2)
C
      WRITE( STDOUT, 3003 )
 3003 FORMAT(30H THE SMALLEST RELATIVE SPACING)
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3)
C
      WRITE( STDOUT, 3004 )
 3004 FORMAT(29H THE LARGEST RELATIVE SPACING)
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4)
C
      WRITE( STDOUT, 3005 )
 3005 FORMAT(18H LOG10 OF THE BASE)
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5)
C
      CALL S88FMT( 2, WWIDTH+1, DFMT(10) )
      CALL S88FMT( 2, DWIDTH+1, DFMT(13) )
C
C  NOW CHECK CONSISTENCY OF INTEGER CONSTANTS
C
      CALL S88FMT( 2, 14, IFMT(5) )
C
      IF( IMACH(11) .LE. IMACH(14) ) GOTO 4009
      WRITE( STDOUT, 4001 )
 4001 FORMAT(30H0I1MACH(11) EXCEEDS I1MACH(14) )
      WRITE( STDOUT, 4002 )
 4002 FORMAT(13H I1MACH(11) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11)
      WRITE( STDOUT, 4003 )
 4003 FORMAT(13H I1MACH(14) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14)
 4009 CONTINUE
C
      IF( IMACH(13) .LE. IMACH(16) ) GOTO 4019
      WRITE( STDOUT, 4011 )
 4011 FORMAT(40H0WARNING - I1MACH(13) EXCEEDS I1MACH(16) )
      WRITE( STDOUT, 4012 )
 4012 FORMAT(13H I1MACH(13) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13)
      WRITE( STDOUT, 4013 )
 4013 FORMAT(13H I1MACH(16) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16)
 4019 CONTINUE
C
      IF( IMACH(16)-IMACH(15) .GE. IMACH(13)-IMACH(12) ) GOTO 4029
      WRITE( STDOUT, 4021 )
 4021 FORMAT(34H0WARNING - I1MACH(13) - I1MACH(12) )
      WRITE( STDOUT, 4022 )
 4022 FORMAT(32H EXCEEDS I1MACH(16) - I1MACH(15) )
      WRITE( STDOUT, 4023 )
 4023 FORMAT(13H I1MACH(12) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12)
      WRITE( STDOUT, 4024 )
 4024 FORMAT(13H I1MACH(13) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13)
      WRITE( STDOUT, 4025 )
 4025 FORMAT(13H I1MACH(15) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15)
      WRITE( STDOUT, 4026 )
 4026 FORMAT(13H I1MACH(16) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16)
 4029 CONTINUE
C
      N = 0
      IBASEM = IMACH(7) - 1
      DO 4030 I = 1, DIGINT
        N = N*IMACH(7) + IBASEM
 4030   CONTINUE
C
      IF( IMACH(9) .EQ. N) GOTO 4039
      WRITE( STDOUT, 4031 )
 4031 FORMAT(39H1IMACH(9) IS NOT IMACH(7)**IMACH(8) - 1 )
      WRITE( STDOUT, 4032 )
 4032 FORMAT(12H I1MACH(7) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7)
      WRITE( STDOUT, 4034 )
 4034 FORMAT(12H I1MACH(8) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8)
      WRITE( STDOUT, 4035 )
 4035 FORMAT(12H I1MACH(9) = )
      WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9)
 4039 CONTINUE
C
C NOW CHECK CONSISTENCY OF SINGLE-PRECISION CONSTANTS
C
      CALL S88FMT( 2, 19, EFMT(5) )
C
      XR = S2MACH( 1.0, IMACH(10), IMACH(12)-1 )
      IF( XR .EQ. RMACH(1) ) GOTO 5009
      WRITE( STDOUT, 5001 )
 5001 FORMAT(47H0R1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 5002 )
 5002 FORMAT(12H R1MACH(1) = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1)
      WRITE( STDOUT, 5003 )
 5003 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
      WRITE( STDOUT, 5004 )
 5004 FORMAT(14H DIFFERENCE = )
      XR = RMACH(1) - XR
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 5009 CONTINUE
C
      XR = 0.0
      SBASE  = FLOAT( IMACH(10) )
      SBASEM = FLOAT( IMACH(10)-1 )
      DO 5010 I = 1, DIGSP
        XR = (XR + SBASEM)/SBASE
 5010   CONTINUE
C
      XR = S2MACH( XR, IMACH(10), IMACH(13) )
      IF( XR .EQ. RMACH(2) ) GOTO 5019
      WRITE( STDOUT, 5011 )
 5011 FORMAT(47H0R1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 5012 )
 5012 FORMAT(12H R1MACH(2) = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2)
      WRITE( STDOUT, 5013 )
 5013 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
      WRITE( STDOUT, 5014 )
 5014 FORMAT(14H DIFFERENCE = )
      XR = RMACH(2) - XR
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 5019 CONTINUE
C
      XR = S2MACH( 1.0, IMACH(10), -IMACH(11) )
      IF( XR .EQ. RMACH(3) ) GOTO 5029
      WRITE( STDOUT, 5021 )
 5021 FORMAT(47H0R1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 5022 )
 5022 FORMAT(12H R1MACH(3) = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3)
      WRITE( STDOUT, 5023 )
 5023 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
      WRITE( STDOUT, 5024 )
 5024 FORMAT(14H DIFFERENCE = )
      XR = RMACH(3) - XR
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 5029 CONTINUE
C
      XR = S2MACH( 1.0, IMACH(10), 1-IMACH(11) )
      IF( XR .EQ. RMACH(4) ) GOTO 5039
      WRITE( STDOUT, 5031 )
 5031 FORMAT(47H0R1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 5032 )
 5032 FORMAT(12H R1MACH(4) = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4)
      WRITE( STDOUT, 5033 )
 5033 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
      WRITE( STDOUT, 5034 )
 5034 FORMAT(14H DIFFERENCE = )
      XR = RMACH(4) - XR
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 5039 CONTINUE
C
      XR = ALOG10( FLOAT(IMACH(10)) )
      IF( XR .EQ. RMACH(5) ) GOTO 5049
      WRITE( STDOUT, 5041 )
 5041 FORMAT(47H0R1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 5042 )
 5042 FORMAT(12H R1MACH(5) = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5)
      WRITE( STDOUT, 5043 )
 5043 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
      WRITE( STDOUT, 5044 )
 5044 FORMAT(14H DIFFERENCE = )
      XR = RMACH(5) - XR
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 5049 CONTINUE
C
C NOW CHECK CONSISTENCY OF DOUBLE-PRECISION CONSTANTS
C
      CALL S88FMT( 2, 19, DFMT(5) )
C
      XD = S3MACH( 1.0D0, IMACH(10), IMACH(15)-1 )
      IF( XD .EQ. DMACH(1) ) GOTO 6009
      WRITE( STDOUT, 6001 )
 6001 FORMAT(47H0D1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 6002 )
 6002 FORMAT(12H D1MACH(1) = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1)
      WRITE( STDOUT, 6003 )
 6003 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
      WRITE( STDOUT, 6004 )
 6004 FORMAT(14H DIFFERENCE = )
      XD = DMACH(1) - XD
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 6009 CONTINUE
C
      XD = 0.0D0
      DBASE  = DBLE ( FLOAT( IMACH(10) ) )
      DBASEM = DBLE ( FLOAT( IMACH(10)-1 ) )
      DO 6010 I = 1, DIGDP
        XD = (XD + DBASEM)/DBASE
 6010   CONTINUE
C
      XD = S3MACH( XD, IMACH(10), IMACH(16) )
      IF( XD .EQ. DMACH(2) ) GOTO 6019
      WRITE( STDOUT, 6011 )
 6011 FORMAT(47H0D1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 6012 )
 6012 FORMAT(12H D1MACH(2) = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2)
      WRITE( STDOUT, 6013 )
 6013 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
      WRITE( STDOUT, 6014 )
 6014 FORMAT(14H DIFFERENCE = )
      XD = DMACH(2) - XD
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 6019 CONTINUE
C
      XD = S3MACH( 1.0D0, IMACH(10), -IMACH(14) )
      IF( XD .EQ. DMACH(3) ) GOTO 6029
      WRITE( STDOUT, 6021 )
 6021 FORMAT(47H0D1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 6022 )
 6022 FORMAT(12H D1MACH(3) = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3)
      WRITE( STDOUT, 6023 )
 6023 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
      WRITE( STDOUT, 6024 )
 6024 FORMAT(14H DIFFERENCE = )
      XD = DMACH(3) - XD
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 6029 CONTINUE
C
      XD = S3MACH( 1.0D0, IMACH(10), 1-IMACH(14) )
      IF( XD .EQ. DMACH(4) ) GOTO 6039
      WRITE( STDOUT, 6031 )
 6031 FORMAT(47H0D1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 6032 )
 6032 FORMAT(12H D1MACH(4) = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4)
      WRITE( STDOUT, 6033 )
 6033 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
      WRITE( STDOUT, 6034 )
 6034 FORMAT(14H DIFFERENCE = )
      XD = DMACH(4) - XD
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 6039 CONTINUE
C
      XD = DLOG10( DBLE(FLOAT(IMACH(10))) )
      IF( XD .EQ. DMACH(5) ) GOTO 6049
      WRITE( STDOUT, 6041 )
 6041 FORMAT(47H0D1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE)
      WRITE( STDOUT, 6042 )
 6042 FORMAT(12H D1MACH(5) = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5)
      WRITE( STDOUT, 6043 )
 6043 FORMAT(19H CALCULATED VALUE = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
      WRITE( STDOUT, 6044 )
 6044 FORMAT(14H DIFFERENCE = )
      XD = DMACH(5) - XD
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 6049 CONTINUE
C
C NOW SEE IF SINGLE-PRECISION IS CLOSED UNDER NEGATION
C
      XR = -RMACH(1)
      XR = -XR
      IF( XR .EQ. RMACH(1) ) GOTO 7009
      WRITE( STDOUT, 7001 )
 7001 FORMAT(29H0-(-R1MACH(1)) .NE. R1MACH(1))
      WRITE( STDOUT, 7002 )
 7002 FORMAT(16H    R1MACH(1)  = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1)
      WRITE( STDOUT, 7003 )
 7003 FORMAT(16H -(-R1MACH(1)) = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 7009 CONTINUE
C
      XR = -RMACH(2)
      XR = -XR
      IF( XR .EQ. RMACH(2) ) GOTO 7019
      WRITE( STDOUT, 7011 )
 7011 FORMAT(29H0-(-R1MACH(2)) .NE. R1MACH(2))
      WRITE( STDOUT, 7012 )
 7012 FORMAT(16H    R1MACH(2)  = )
      WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2)
      WRITE( STDOUT, 7013 )
 7013 FORMAT(16H -(-R1MACH(2)) = )
      WRITE( STDOUT, EFMT ) CCPLUS, XR
 7019 CONTINUE
C
C NOW SEE IF DOUBLE-PRECISION IS CLOSED UNDER NEGATION
C
      XD = -DMACH(1)
      XD = -XD
      IF( XD .EQ. DMACH(1) ) GOTO 8009
      WRITE( STDOUT, 8001 )
 8001 FORMAT(29H0-(-D1MACH(1)) .NE. D1MACH(1))
      WRITE( STDOUT, 8002 )
 8002 FORMAT(16H    D1MACH(1)  = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1)
      WRITE( STDOUT, 8003 )
 8003 FORMAT(16H -(-D1MACH(1)) = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 8009 CONTINUE
C
      XD = -DMACH(2)
      XD = -XD
      IF( XD .EQ. DMACH(2) ) GOTO 8019
      WRITE( STDOUT, 8011 )
 8011 FORMAT(29H0-(-D1MACH(2)) .NE. D1MACH(2))
      WRITE( STDOUT, 8012 )
 8012 FORMAT(16H    D1MACH(2)  = )
      WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2)
      WRITE( STDOUT, 8013 )
 8013 FORMAT(16H -(-D1MACH(2)) = )
      WRITE( STDOUT, DFMT ) CCPLUS, XD
 8019 CONTINUE
C
      RETURN
C
      END
      REAL FUNCTION S2MACH( XR, BASE, EXP )                             MACH5470
C
C S2MACH = XR * BASE**EXP
C
      INTEGER BASE, EXP
      REAL TBASE, XR
C
      TBASE = FLOAT(BASE)
      S2MACH = XR
C
      N = EXP
      IF( N .GE. 0 ) GO TO 20
C
      N = -N
      TBASE = 1.0/TBASE
C
 20   IF( MOD(N,2) .NE. 0 ) S2MACH = S2MACH*TBASE
      N = N/2
      IF( N .EQ. 0 ) GO TO 30
      TBASE = TBASE * TBASE
      GO TO 20
C
 30   RETURN
C
      END
      DOUBLE PRECISION FUNCTION S3MACH( XD, BASE, EXP )                 MACH5720
C
C S3MACH = XD * BASE**EXP
C
      INTEGER BASE, EXP
      DOUBLE PRECISION TBASE, XD
C
      TBASE = FLOAT(BASE)
      S3MACH = XD
C
      N = EXP
      IF( N .GE. 0 ) GO TO 20
C
      N = -N
      TBASE = 1.0D0/TBASE
C
 20   IF( MOD(N,2) .NE. 0 ) S3MACH = S3MACH*TBASE
      N = N/2
      IF( N .EQ. 0 ) GO TO 30
      TBASE = TBASE * TBASE
      GO TO 20
C
 30   RETURN
C
      END
      INTEGER FUNCTION ICEIL(X)                                         MACH5970
C
C  ICEIL RETURNS CEIL(X)
C
      ICEIL = INT(X)
      IF (X .LE. 0.0) RETURN
      IF (FLOAT(ICEIL) .NE. X) ICEIL = ICEIL + 1
C
      RETURN
      END
      INTEGER FUNCTION IFLR(X)                                          MACH6070
C
C  IFLR RETURNS FLR(X)
C
      IFLR = INT(X)
      IF (X .GE. 0.0) RETURN
      IF (FLOAT(IFLR) .NE. X) IFLR = IFLR - 1
C
      RETURN
      END
C  MAIN PROGRAM                                                         ERR10010
C **********************************************                        ERR10020
C                                                                       ERR10030
C TO TEST THE ERROR HANDLING PACKAGE.                                   ERR10040
C TEST NUMBER 1: TURNING RECOVERY ON AND OFF.                           ERR10050
C                                                                       ERR10060
C **********************************************                        ERR10070
      INTEGER OLDREC, NERR, NERROR, I1MACH                              ERR10080
      INTEGER TEMP                                                      ERR10090
C ENTER RECOVERY MODE.                                                  ERR10100
      CALL ENTSRC(OLDREC, 1)                                            ERR10110
C SET AN ERROR.                                                         ERR10120
      CALL SETERR(39HFIRST ERROR TEST - RECOVERABLE ERROR OK, 39, 1, 1) ERR10130
C PRINT THE ERROR.                                                      ERR10140
      CALL EPRINT                                                       ERR10150
      IF (NERROR(NERR) .EQ. 1) GOTO 2                                   ERR10160
         TEMP = I1MACH(2)                                               ERR10170
         WRITE (TEMP,  1)                                               ERR10180
   1     FORMAT (14H NERROR FAILS.)                                     ERR10190
C TURN THE ERROR STATE OFF.                                             ERR10200
   2  CALL ERROFF                                                       ERR10210
      IF (NERROR(NERR) .EQ. 0) GOTO 4                                   ERR10220
         TEMP = I1MACH(2)                                               ERR10230
         WRITE (TEMP,  3)                                               ERR10240
   3     FORMAT (42H ERROFF FAILS TO TURN THE ERROR STATE OFF.)         ERR10250
C SEE IF THE ERROR PRINTS.                                              ERR10260
   4  CALL EPRINT                                                       ERR10270
      CALL SETERR(                                                      ERR10280
     1   34HSAME TEST -  LEAVING RECOVERY MODE,                         ERR10290
     2   34, 2, 1)                                                      ERR10300
C RESTORE OLD RECOVERY LEVEL, THE DEFAULT.                              ERR10310
      CALL RETSRC(OLDREC)                                               ERR10320
      TEMP = I1MACH(2)                                                  ERR10330
      WRITE (TEMP,  5)                                                  ERR10340
   5  FORMAT (42H RECOVERY MODE REMAINS ON WHEN TURNED OFF.)            ERR10350
      STOP                                                              ERR10360
      END                                                               ERR10370
C  MAIN PROGRAM                                                         ERR20010
C **********************************************                        ERR20020
C                                                                       ERR20030
C TO TEST THE ERROR HANDLING PACKAGE.                                   ERR20040
C TEST NUMBER 2: FATAL ERRORS.                                          ERR20050
C                                                                       ERR20060
C **********************************************                        ERR20070
      INTEGER I1MACH                                                    ERR20080
      INTEGER TEMP                                                      ERR20090
C SET AN ERROR.                                                         ERR20100
      CALL SETERR(                                                      ERR20110
     1   39HSECOND ERROR TEST - FATAL ERROR CHECKED, 39, 1, 2)          ERR20120
      TEMP = I1MACH(2)                                                  ERR20130
      WRITE (TEMP,  1)                                                  ERR20140
   1  FORMAT (39H A FATAL ERROR FAILS TO HALT EXECUTION.)               ERR20150
      STOP                                                              ERR20160
      END                                                               ERR20170
C  MAIN PROGRAM                                                         ERR30010
C **********************************************                        ERR30020
C                                                                       ERR30030
C TO TEST THE ERROR HANDLING PACKAGE.                                   ERR30040
C TEST NUMBER 3: TWO RECOVERABLE ERRORS IN A ROW.                       ERR30050
C                                                                       ERR30060
C **********************************************                        ERR30070
      INTEGER OLDREC, I1MACH                                            ERR30080
      INTEGER TEMP                                                      ERR30090
C ENTER RECOVERY MODE.                                                  ERR30100
      CALL ENTSRC(OLDREC, 1)                                            ERR30110
      CALL SETERR(30HMAIN - FIRST RECOVERABLE ERROR, 30, 1, 1)          ERR30120
      CALL SETERR(31HMAIN - SECOND RECOVERABLE ERROR, 31, 2, 1)         ERR30130
      TEMP = I1MACH(2)                                                  ERR30140
      WRITE (TEMP,  1)                                                  ERR30150
   1  FORMAT (                                                          ERR30160
     1   56H TWO RECOVERABLE ERRORS IN A ROW FAIL TO HALT EXECUTION.)   ERR30170
      STOP                                                              ERR30180
      END                                                               ERR30190
C  MAIN PROGRAM                                                         STK10010
C **********************************************                        STK10020
C                                                                       STK10030
C FIRST STORAGE ALLOCATOR TEST.                                         STK10040
C TESTS THE STORAGE ALLOCATOR WITH DEFAULT INITIALIZATION LENGTH.       STK10050
C                                                                       STK10060
C **********************************************                        STK10070
C NUMBER OF OUTSTANDING ALLOCATIONS.                                    STK10080
      COMMON /CSTAK/ DS                                                 STK10090
      DOUBLE PRECISION DS(500)                                          STK10100
      INTEGER IS(1000), ISTKMD, ISTKGT, ISTKQU, ISTKST, I               STK10110
      INTEGER J, K, NALOCS, I1MACH                                      STK10120
      REAL RS(1000), R1MACH                                             STK10130
      LOGICAL LS(1000)                                                  STK10140
      COMPLEX CS(500), CMPLX                                            STK10150
      DOUBLE PRECISION D1MACH                                           STK10160
      INTEGER TEMP                                                      STK10170
      EQUIVALENCE (DS(1), CS(1), RS(1), IS(1), LS(1))                   STK10180
      NALOCS = 0                                                        STK10190
      TEMP = I1MACH(2)                                                  STK10200
      WRITE (TEMP,  1)                                                  STK10210
   1  FORMAT (                                                          STK10220
     1  61H AN ERROR BELOW INDICATES TROUBLE WITH THE STORAGE ALLOCATOR,STK10230
     2   )                                                              STK10240
      TEMP = I1MACH(2)                                                  STK10250
      WRITE (TEMP,  2)                                                  STK10260
   2  FORMAT (42H WHEN USING THE STACK WITH DEFAULT LENGTH.,//)         STK10270
      I = 0                                                             STK10280
         GOTO  4                                                        STK10290
   3     I = I+1                                                        STK10300
   4     K = 5                                                          STK10310
C GET THE ENTIRE STACK, I ITEMS AT A TIME.                              STK10320
C   DO THE ALLOCATIONS IN ORDER OF                                      STK10330
C   COMPLEX, LONG REAL, REAL, INTEGER AND LOGICAL.                      STK10340
            GOTO  6                                                     STK10350
   5        K = K-1                                                     STK10360
   6        IF (K .LT. 1) GOTO  16                                      STK10370
            IF (ISTKQU(K) .LT. I) GOTO  17                              STK10380
C GET ALL THE REMAINING STACK.                                          STK10390
            J = ISTKGT(ISTKQU(K), K)                                    STK10400
C TRUNCATE TO I ITEMS.                                                  STK10410
            J = ISTKMD(I)                                               STK10420
            GOTO  12                                                    STK10430
C FILL THE SPACE UP ACCORDINGLY.                                        STK10440
   7           CALL SETC(I, CMPLX(R1MACH(2), R1MACH(2)), CS(J))         STK10450
               GOTO  13                                                 STK10460
   8           CALL SETD(I, D1MACH(2), DS(J))                           STK10470
               GOTO  13                                                 STK10480
   9           CALL SETR(I, R1MACH(2), RS(J))                           STK10490
               GOTO  13                                                 STK10500
  10           CALL SETI(I, I1MACH(9), IS(J))                           STK10510
               GOTO  13                                                 STK10520
  11           CALL SETL(I, .TRUE., LS(J))                              STK10530
               GOTO  13                                                 STK10540
  12           IF (K .EQ. 1) GOTO  11                                   STK10550
               IF (K .EQ. 2) GOTO  10                                   STK10560
               IF (K .EQ. 3) GOTO  9                                    STK10570
               IF (K .EQ. 4) GOTO  8                                    STK10580
               IF (K .EQ. 5) GOTO  7                                    STK10590
  13        NALOCS = NALOCS+1                                           STK10600
            IF (ISTKST(1) .EQ. NALOCS) GOTO 15                          STK10610
               TEMP = I1MACH(2)                                         STK10620
               WRITE (TEMP,  14)                                        STK10630
  14           FORMAT (24H ISTKST(1) IS INCORRECT.)                     STK10640
  15        CONTINUE                                                    STK10650
            GOTO  5                                                     STK10660
  16     CONTINUE                                                       STK10670
         GOTO  3                                                        STK10680
  17  IF (NALOCS .GE. 6) GOTO 19                                        STK10690
         TEMP = I1MACH(2)                                               STK10700
         WRITE (TEMP,  18) NALOCS                                       STK10710
  18     FORMAT (30H THE DEFAULT STACK ONLY HOLDS , I1, 7H ITEMS,,      STK10720
     1      32H IT SHOULD HOLD SEVERAL HUNDRED.)                        STK10730
C RELEASE THE ALLOCATIONS, ONE BY ONE.                                  STK10740
  19  I = 1                                                             STK10750
         GOTO  21                                                       STK10760
  20     I = I+1                                                        STK10770
  21     IF (I .GT. NALOCS) GOTO  25                                    STK10780
         IF (ISTKST(1) .LE. 0) GOTO 22                                  STK10790
            CALL ISTKRL(1)                                              STK10800
            GOTO  24                                                    STK10810
  22        TEMP = I1MACH(2)                                            STK10820
            WRITE (TEMP,  23)                                           STK10830
  23        FORMAT (                                                    STK10840
     1         50H ALLOCATOR OUT OF ALLOCATIONS BEFORE IT SHOULD BE.)   STK10850
  24     CONTINUE                                                       STK10860
         GOTO  20                                                       STK10870
  25  IF (ISTKST(1) .EQ. 0) GOTO 27                                     STK10880
         TEMP = I1MACH(2)                                               STK10890
         WRITE (TEMP,  26)                                              STK10900
  26     FORMAT (49H AFTER DE-ALLOCATING ALL THE ITEMS, ITEMS REMAIN.)  STK10910
  27  TEMP = I1MACH(2)                                                  STK10920
      WRITE (TEMP,  28)                                                 STK10930
  28  FORMAT (                                                          STK10940
     1   39H FIRST STORAGE ALLOCATOR TEST COMPLETE.//)                  STK10950
      TEMP = I1MACH(2)                                                  STK10960
      WRITE (TEMP,  29)                                                 STK10970
  29  FORMAT (49H NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE.)     STK10980
      I = ISTKGT(2*ISTKQU(5)+10, 5)                                     STK10990
      STOP                                                              STK11000
      END                                                               STK11010
      SUBROUTINE SETC(N,V,B)                                            STK11020
C
C     SETC SETS THE N COMPLEX ITEMS IN B TO V
C
      COMPLEX B(N),V
C
      IF(N .LE. 0) RETURN
C
      DO 10 I = 1, N
 10     B(I) = V
C
      RETURN
C
      END
      SUBROUTINE SETD(N,V,B)                                            STK11160
C
C     SETD SETS THE N DOUBLE PRECISION ITEMS IN B TO V
C
      DOUBLE PRECISION B(N),V
C
      IF(N .LE. 0) RETURN
C
      DO 10 I = 1, N
 10     B(I) = V
C
      RETURN
C
      END
      SUBROUTINE SETI(N,V,B)                                            STK11300
C
C     SETI SETS THE N INTEGER ITEMS IN B TO V
C
      INTEGER B(N),V
C
      IF(N .LE. 0) RETURN
C
      DO 10 I = 1, N
 10     B(I) = V
C
      RETURN
C
      END
      SUBROUTINE SETL(N,V,B)                                            STK11440
C
C     SETL SETS THE N LOGICAL ITEMS IN B TO V
C
      LOGICAL B(N),V
C
      IF(N .LE. 0) RETURN
C
      DO 10 I = 1, N
 10     B(I) = V
C
      RETURN
C
      END
      SUBROUTINE SETR(N,V,B)                                            STK11580
C
C     SETR SETS THE N REAL ITEMS IN B TO V
C
      REAL B(N),V
C
      IF(N .LE. 0) RETURN
C
      DO 10 I = 1, N
 10     B(I) = V
C
      RETURN
C
      END
C  MAIN PROGRAM                                                         STK20010
C **********************************************                        STK20020
C                                                                       STK20030
C SECOND ALLOCATOR TEST.                                                STK20040
C TESTS THE STORAGE ALLOCATOR WHEN INITIALIZED TO A NON-DEFAULT LENGTH. STK20050
C                                                                       STK20060
C **********************************************                        STK20070
      COMMON /CSTAK/ DS                                                 STK20080
      DOUBLE PRECISION DS(5000)                                         STK20090
      INTEGER IS(1000), ISTKMD, ISTKGT, ISTKQU, ISTKST, I               STK20100
      INTEGER J, K, NALOCS, I1MACH                                      STK20110
      REAL RS(1000), R1MACH                                             STK20120
      LOGICAL LS(1000)                                                  STK20130
      COMPLEX CS(500), CMPLX                                            STK20140
      DOUBLE PRECISION D1MACH                                           STK20150
      INTEGER TEMP                                                      STK20160
      EQUIVALENCE (DS(1), CS(1), RS(1), IS(1), LS(1))                   STK20170
C INITIALIZE THE STACK.                                                 STK20180
      CALL ISTKIN(5000, 4)                                              STK20190
C NUMBER OF OUTSTANDING ALLOCATIONS.                                    STK20200
      NALOCS = 0                                                        STK20210
      TEMP = I1MACH(2)                                                  STK20220
      WRITE (TEMP,  1)                                                  STK20230
   1  FORMAT (                                                          STK20240
     1  61H AN ERROR BELOW INDICATES TROUBLE WITH THE STORAGE ALLOCATOR,STK20250
     2   )                                                              STK20260
      TEMP = I1MACH(2)                                                  STK20270
      WRITE (TEMP,  2)                                                  STK20280
   2  FORMAT (54H WHEN USING A STACK INITIALIZED TO NON-DEFAULT LENGTH.,STK20290
     1   //)                                                            STK20300
      I = 0                                                             STK20310
         GOTO  4                                                        STK20320
   3     I = I+1                                                        STK20330
   4     K = 5                                                          STK20340
C GET THE ENTIRE STACK, I ITEMS AT A TIME.                              STK20350
C   DO THE ALLOCATIONS IN ORDER OF                                      STK20360
C   COMPLEX, LONG REAL, REAL, INTEGER AND LOGICAL.                      STK20370
            GOTO  6                                                     STK20380
   5        K = K-1                                                     STK20390
   6        IF (K .LT. 1) GOTO  16                                      STK20400
            IF (ISTKQU(K) .LT. I) GOTO  17                              STK20410
C GET ALL THE REMAINING STACK.                                          STK20420
            J = ISTKGT(ISTKQU(K), K)                                    STK20430
C TRUNCATE TO I ITEMS.                                                  STK20440
            J = ISTKMD(I)                                               STK20450
            GOTO  12                                                    STK20460
C FILL THE SPACE UP ACCORDINGLY.                                        STK20470
   7           CALL SETC(I, CMPLX(R1MACH(2), R1MACH(2)), CS(J))         STK20480
               GOTO  13                                                 STK20490
   8           CALL SETD(I, D1MACH(2), DS(J))                           STK20500
               GOTO  13                                                 STK20510
   9           CALL SETR(I, R1MACH(2), RS(J))                           STK20520
               GOTO  13                                                 STK20530
  10           CALL SETI(I, I1MACH(9), IS(J))                           STK20540
               GOTO  13                                                 STK20550
  11           CALL SETL(I, .TRUE., LS(J))                              STK20560
               GOTO  13                                                 STK20570
  12           IF (K .EQ. 1) GOTO  11                                   STK20580
               IF (K .EQ. 2) GOTO  10                                   STK20590
               IF (K .EQ. 3) GOTO  9                                    STK20600
               IF (K .EQ. 4) GOTO  8                                    STK20610
               IF (K .EQ. 5) GOTO  7                                    STK20620
  13        NALOCS = NALOCS+1                                           STK20630
            IF (ISTKST(1) .EQ. NALOCS) GOTO 15                          STK20640
               TEMP = I1MACH(2)                                         STK20650
               WRITE (TEMP,  14)                                        STK20660
  14           FORMAT (24H ISTKST(1) IS INCORRECT.)                     STK20670
  15        CONTINUE                                                    STK20680
            GOTO  5                                                     STK20690
  16     CONTINUE                                                       STK20700
         GOTO  3                                                        STK20710
  17  IF (NALOCS .GE. 6) GOTO 19                                        STK20720
         TEMP = I1MACH(2)                                               STK20730
         WRITE (TEMP,  18) NALOCS                                       STK20740
  18     FORMAT (30H THE DEFAULT STACK ONLY HOLDS , I1, 7H ITEMS,,      STK20750
     1      32H IT SHOULD HOLD SEVERAL HUNDRED.)                        STK20760
C RELEASE THE ALLOCATIONS, ONE BY ONE.                                  STK20770
  19  I = 1                                                             STK20780
         GOTO  21                                                       STK20790
  20     I = I+1                                                        STK20800
  21     IF (I .GT. NALOCS) GOTO  25                                    STK20810
         IF (ISTKST(1) .LE. 0) GOTO 22                                  STK20820
            CALL ISTKRL(1)                                              STK20830
            GOTO  24                                                    STK20840
  22        TEMP = I1MACH(2)                                            STK20850
            WRITE (TEMP,  23)                                           STK20860
  23        FORMAT (                                                    STK20870
     1         50H ALLOCATOR OUT OF ALLOCATIONS BEFORE IT SHOULD BE.)   STK20880
  24     CONTINUE                                                       STK20890
         GOTO  20                                                       STK20900
  25  IF (ISTKST(1) .EQ. 0) GOTO 27                                     STK20910
         TEMP = I1MACH(2)                                               STK20920
         WRITE (TEMP,  26)                                              STK20930
  26     FORMAT (49H AFTER DE-ALLOCATING ALL THE ITEMS, ITEMS REMAIN.)  STK20940
  27  TEMP = I1MACH(2)                                                  STK20950
      WRITE (TEMP,  28)                                                 STK20960
  28  FORMAT (40H SECOND STORAGE ALLOCATOR TEST COMPLETE.,//)           STK20970
      TEMP = I1MACH(2)                                                  STK20980
      WRITE (TEMP,  29)                                                 STK20990
  29  FORMAT (49H NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE.)     STK21000
      I = ISTKGT(2*ISTKQU(5)+10, 5)                                     STK21010
      STOP                                                              STK21020
      END                                                               STK21030
