C      ALGORITHM 719, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 19, NO. 3, SEPTEMBER, 1993, PP. 286-317.
README File for the Multiprecision Package and Translator Programs

32-bit computer version
Update as of June 30, 1992

The following files are included in this "shar" file:

Name            Description

mpfun.f         MPFUN library file
testmp.f        Test program for MPFUN
transmp.f       TRANSMP program
testran.f       Test program for TRANSMP
testran.out     Reference output of test program

These programs should work correctly on any 32-bit system, including
those based on IEEE arithmetic.  For Crays or other 64-bit systems,
request separate versions of these programs from the author.

On Unix systems, the following sequence compiles the MPFUN library;
compiles, links and executes the test program for MPFUN; compiles the
TRANSMP translator program; translates the test program for TRANSMP;
compiles, links and executes the translated program; and compares the
output of the translated program with the reference output file:

Command                           Notes

f77 -c mpfun.f                    Insert -O2 or -O3 after f77 for an 
                                     optimized compile.  There should
                                     be no fatal compiler diagnostics.
f77 testmp.f mpfun.o              There should be no fatal compiler
                                     diagnostics.
a.out > testmp.out                Check testmp.out to make sure all
                                     tests passed.
f77 -o transmp transmp.f          There should be no fatal compiler
                                     diagnostics.
transmp < testran.f > tranout.f   Check the end of tranout.f to make
                                     sure there are no fatal translator
                                     errors.
f77 tranout.f mpfun.o             There should be no fatal compiler
                                     diagnostics.
a.out > tranout.out               This should complete normally.

diff tranout.out testran.out      There should be no differences here.

On IBM workstations, the four f77 lines should be replaced by

xlf -O -c mpfun.f
xlf testmp.f mpfun.o
xlf -qrecur -qcharlen=1600 -o transmp transmp.f
xlf tranout.f mpfun.o

On HP workstations, comment out the two IMPLICIT AUTOMATIC statements
in the transmp.f file before compiling.  On DEC workstations, comment
out these two lines and compile with the command

f77 -automatic -o transmp transmp.f.

These codes have been tested quite thoroughly, but a few bugs may
remain.  If you encounter any, please let me know and I will fix them
as soon as possible.

David H. Bailey
NASA Ames Research Center
Mail Stop T045-1
Moffett Field, CA 94035
Tel.: 415-604-4410
Fax:  415-604-3957
E-mail: dbailey@nas.nasa.gov

10 ^         0 x  3.14159265358979323846264338327950288419716939937510582,
10 ^         0 x  2.718281828459045235360287471352662497757247093699959574,
10 ^         8 x  1.5929408,
10 ^        14 x  1.52779903171104,
10 ^         7 x  1.798869166210583847918164697465982392760106312722056703,
10 ^         6 x  4.246554058540655594271278713230977821918624216872862863,
10 ^         6 x  1.8734,
10 ^         6 x  3.7468,
10 ^         0 x  1.78661346435546875,
10 ^         0 x  2.947257281471990863100813367572530600175591224440627617,
10 ^         1 x  1.8,
10 ^         1 x -2.492030753469781077845780729842283661121425243866422996,
10 ^         0 x  0.,
C*****************************************************************************
C
C   MPFUN: A MULTIPLE PRECISION FLOATING POINT COMPUTATION PACKAGE
C
C   Standard version
C   Version Date:  June 30, 1992
C
C   Author:
C
C      David H. Bailey                 Telephone:   415-604-4410
C      NASA Ames Research Center       Facsimile:   415-604-3957
C      Mail Stop T045-1                Internet:    dbailey@nas.nasa.gov
C      Moffett Field, CA 94035
C      USA
C
C   Restrictions:
C
C   This software has now been approved by NASA for unrestricted distribution.
C   However, usage of this software is subject to the following:
C
C   1. This software is offered without warranty of any kind, either expressed
C      or implied.  The author would appreciate, however, any reports of bugs
C      or other difficulties that may be encountered.
C   2. If modifications or enhancements to this software are made to this
C      software by others, NASA Ames reserves the right to obtain this enhanced
C      software at no cost and with no restrictions on its usage.
C   3. The author and NASA Ames are to be acknowledged in any published paper
C      based on computations using this software.  Accounts of practical
C      applications or other benefits resulting from this software are of
C      particular interest.  Please send a copy of such papers to the author.
C
C   Description:
C
C   The following information is a brief description of this program.  For
C   full details and instructions for usage, see the paper "A Portable High
C   Performance Multiprecision Package", available from the author.
C
C   This package of Fortran subroutines performs multiprecision floating point
C   arithmetic.  If sufficient main memory is available, the maximum precision
C   level is at least 16 million digits.  The maximum dynamic range is at
C   least 10^(+-14,000,000).  It employs advanced algorithms, including an
C   FFT-based multiplication routine and some recently discovered
C   quadratically convergent algorithms for pi, exp and log.  The package also
C   features extensive debug and self-checking facilities, so that it can be
C   used as a rigorous system integrity test.  All of the routines in this
C   package have been written to facilitate vector and parallel processing.
C
C   For users who do not wish to manually write code that calls these routines,
C   an automatic translator program is available from the author that converts
C   ordinary Fortran-77 code into code that calls these routines.  Contact the
C   author for details.
C
C   This package should run correctly on any computer with a Fortran-77
C   compiler that meets certain minimal floating point accuracy standards.
C   Any system based on the IEEE floating point standard, with a 25 bit
C   mantissa in single precision and a 53 bit mantissa in double precision,
C   easily meets these requirements.  All DEC VAX systems meet these
C   requirements.  All IBM mainframes and workstations meet these requirements.
C   Cray systems meet all of these requirements with double precision disabled
C   (i.e. by using only single precision).
C
C   Machine-specific tuning notes may be located by searching for the text
C   string C> in this program file.  It is highly recommended that these notes
C   be read before running this package on a specific system.  If no comment
C   accompanies a C> string, this indicates that all references to INT in the
C   next loop may be safely changed to AINT.  INT appears to be significantly
C   faster on many 32 bit systems, but AINT is slightly faster on Crays.  Also,
C   certain vectorizable DO loops that are often not recognized as such by
C   vectorizing compilers are prefaced with Cray CDIR$ IVDEP directives.  On
C   other vector systems these directives should be replaced by the
C   appropriate equivalents.
C
C   Instructions for compiling and testing this program are included in the
C   readme file that accompanies this file.
C
C*****************************************************************************
C
      BLOCK DATA
C
C   This initializes the parameters in MPCOM1 and the error codes in MPCOM2
C   with default values.
C>
C   On IEEE systems and most other 32 bit systems, set BBXC = 4096.D0,
C   NBTC = 24, NPRC = 32, and MCRC = 7.  On Cray systems, set BBXC = 2048.D0,
C   NBTC = 22, NPRC = 16, and MCRC = 8.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      PARAMETER (BBXC = 4096.D0, NBTC = 24, NPRC = 32, MCRC = 7,        
     $  BDXC = BBXC ** 2, BX2C = BDXC ** 2, RBXC = 1.D0 / BBXC,         
     $  RDXC = RBXC ** 2, RX2C = RDXC ** 2, RXXC = 16.D0 * RX2C)
      DATA BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR / BBXC, BDXC,    
     $  BX2C, RBXC, RDXC, RX2C, RXXC, NBTC, NPRC/
      DATA NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS /                 
     $  16, 0, 6, 0, MCRC, 1, 1, 1, 1024/
      DATA KER /72 * 2/
      END
C
      SUBROUTINE DPADD (A, NA, B, NB, C, NC)
C
C   This adds the DPE numbers (A, NA) and (B, NB) to yield the sum (C, NC).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION PT(64)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      SAVE PT
      DATA PT/ 64 * 0.D0/
C
      IF (IER .NE. 0) THEN
        C = 0.D0
        NC = 0
        RETURN
      ENDIF
C
C   If this is the first call to DPADD, initialize the PT table.
C
      IF (PT(1) .EQ. 0.D0) THEN
        PT(1) = 0.5D0
C
        DO 100 I = 2, 64
          PT(I) = 0.5D0 * PT(I-1)
 100    CONTINUE
C
      ENDIF
C
C   This operation reduces to five cases.
C
      IF (B .EQ. 0.D0) THEN
        C = A
        NC = NA
      ELSE IF (A .EQ. 0.D0) THEN
        C = B
        NC = NB
      ELSE IF (NA .EQ. NB) THEN
        C = A + B
        NC = NA
      ELSE IF (NA .GT. NB) THEN
        K = NA - NB
        NC = NA
        IF (K .GT. 64) THEN
          C = A
        ELSE
          C = A + B * PT(K)
        ENDIF
      ELSE
        K = NB - NA
        NC = NB
        IF (K .GT. 64) THEN
          C = B
        ELSE
          C = B + A * PT(K)
        ENDIF
      ENDIF
      IF (C .EQ. 0.D0) THEN
        NC = 0
        GOTO 130
      ENDIF
C
C   Normalize the result to a decent range if it is not.
C
 110  IF (ABS (C) .GE. BDX) THEN
        C = RDX * C
        NC = NC + NBT
        GOTO 110
      ENDIF
C
 120  IF (ABS (C) .LT. 1.D0) THEN
        C = BDX * C
        NC = NC - NBT
        GOTO 120
      ENDIF
C
 130  RETURN
      END
C
      SUBROUTINE DPDEC (A, NA, B, NB)
C
C   This converts the DPE number (A, NA) to decimal form, i.e. B * 10^NB,
C   where |B| is between 1 and 10.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (XLT = 0.3010299956639812D0)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      IF (A .NE. 0.D0) THEN
        T1 = XLT * NA + LOG10 (ABS (A))
        NB = T1
        IF (T1 .LT. 0.D0) NB = NB - 1
        B = SIGN (10.D0 ** (T1 - NB), A)
      ELSE
        B = 0.D0
        NB = 0
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE DPDIV (A, NA, B, NB, C, NC)
C
C   This divides the DPE number (A, NA) by (B, NB) to yield the quotient
C   (C, NC).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      IF (IER .NE. 0) THEN
        C = 0.D0
        NC = 0
        RETURN
      ENDIF
      IF (B .EQ. 0.D0) THEN
        IF (KER(1) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** DPDIV: Divisor is zero.')
          IER = 1
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Divide A by B and subtract exponents, unless A is zero.
C
      IF (A .EQ. 0.D0) THEN
        C = 0.D0
        NC = 0
        GOTO 120
      ELSE
        C = A / B
        NC = NA - NB
      ENDIF
C
C   Normalize the result to a decent range if it is not.
C
 100  IF (ABS (C) .GE. BDX) THEN
        C = RDX * C
        NC = NC + NBT
        GOTO 100
      ENDIF
C
 110  IF (ABS (C) .LT. 1.D0) THEN
        C = BDX * C
        NC = NC - NBT
        GOTO 110
      ENDIF
C
 120  RETURN
      END
C
      SUBROUTINE DPMUL (A, NA, B, NB, C, NC)
C
C   This multiplies the DPE number (A, NA) by (B, NB) to yield the product
C   (C, NC).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        C = 0.D0
        NC = 0
        RETURN
      ENDIF
C
C   Multiply A by B and add exponents, unless either is zero.
C
      IF (A .EQ. 0.D0 .OR. B .EQ. 0.D0) THEN
        C = 0.D0
        NC = 0
        GOTO 120
      ELSE
        C = A * B
        NC = NA + NB
      ENDIF
C
C   Normalize the result to a decent range if it is not.
C
 100  IF (ABS (C) .GE. BDX) THEN
        C = RDX * C
        NC = NC + NBT
        GOTO 100
      ENDIF
C
 110  IF (ABS (C) .LT. 1.D0) THEN
        C = BDX * C
        NC = NC - NBT
        GOTO 110
      ENDIF
C
 120  RETURN
      END
C
      SUBROUTINE DPPWR (A, NA, B, NB, C, NC)
C
C   This raises the DPE number (A, NA) to the (B, NB) power and places the
C   result in (C, NC).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (CL2 = 1.4426950408889633D0)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      IF (IER .NE. 0) THEN
        C = 0.D0
        NC = 0
        RETURN
      ENDIF
      IF (A .LE. 0.D0) THEN
        IF (KER(2) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** DPPWR: Argument is less than or equal to zero.')
          IER = 2
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      IF (B .EQ. 0.D0) THEN
        C = 1.D0
        NC = 0
        GOTO 120
      ENDIF
C
      IF (B .EQ. 1.D0 .AND. NB .EQ. 0) THEN
        C = A
        NC = NA
        GOTO 120
      ENDIF
C
C   Compute the base 2 logarithm of A and multiply by B.
C
      AL = CL2 * LOG (A) + NA
      CALL DPMUL (AL, 0, B, NB, T1, N1)
C
C   Check for possible overflow or underflow.
C
      IF (N1 .GT. 6) THEN
        IF (T1 .GT. 0.D0) THEN
          IF (KER(3) .NE. 0) THEN
            WRITE (LDB, 2)
 2          FORMAT ('*** DPPWR: Overflow')
            IER = 3
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ELSE
          C = 0.D0
          NC = 0
          GOTO 120
        ENDIF
      ENDIF
C
C   Compute 2 raised to the power B * Log_2 (A).
C
      T1 = T1 * 2.D0 ** N1
      NC = INT (T1)
      C = 2.D0 ** (T1 - NC)
C
C   Normalize the result to a decent range if it is not.
C
 100  IF (ABS (C) .GE. BDX) THEN
        C = RDX * C
        NC = NC + NBT
        GOTO 100
      ENDIF
C
 110  IF (ABS (C) .LT. 1.D0) THEN
        C = BDX * C
        NC = NC - NBT
        GOTO 110
      ENDIF
C
 120  RETURN
      END
C
      SUBROUTINE DPSQRT (A, NA, B, NB)
C
C   This computes the square root of the DPE number (A, NA) and places the
C   result in (B, NB).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      IF (IER .NE. 0) THEN
        B = 0.D0
        NB = 0
        RETURN
      ENDIF
      IF (A .LT. 0.D0) THEN
        IF (KER(4) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** DPSQRT: Argument is negative.')
          IER = 4
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      IF (A .EQ. 0.D0) THEN
        B = 0.D0
        NB = 0
        GOTO 120
      ENDIF
C
C   Divide the exponent of A by two and then take the square root of A.  If
C   NA is not an even number, then we have to multiply A by 10 before taking
C   the square root.
C
      NB = NA / 2
      IF (NA .EQ. 2 * NB) THEN
        B = SQRT (A)
      ELSE
        B = SQRT (2.D0 * A)
        IF (NA .LT. 0) NB = NB - 1
      ENDIF
C
C   Normalize the result to a decent range if it is not.
C
 100  IF (ABS (B) .GE. BDX) THEN
        B = RDX * B
        NB = NB + NBT
        GOTO 100
      ENDIF
C
 110  IF (ABS (B) .LT. 1.D0) THEN
        B = BDX * B
        NB = NB - NBT
        GOTO 110
      ENDIF
C
 120  RETURN
      END
C
      SUBROUTINE DPSUB (A, NA, B, NB, C, NC)
C
C   This subtracts the DPE number (B, NB) from (A, NA) to yield the difference
C   (C, NC).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        C = 0.D0
        NC = 0
        RETURN
      ENDIF
C
      BB = -B
      CALL DPADD (A, NA, BB, NB, C, NC)
C
      RETURN
      END
C
      SUBROUTINE MPABRT
C>
C   This routine terminates execution.  Many users will want to replace the
C   default STOP with a call to a system routine that provides a traceback.
C   Examples of code that produce traceback are included here (commented out)
C   for some systems.
C
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      WRITE (LDB, 1) IER
 1    FORMAT ('*** MPABRT: Execution terminated, error code =',I4)
C
C   Use this line on Cray systems.
C
C      CALL ABORT
C
C   Use this line plus the C routine TRACBK (available from author) on
C   Silicon Graphics IRIS systems.
C
C      CALL TRACBK
C
C   On other systems, merely terminate execution.
C
      STOP
      END
C
      SUBROUTINE MPADD (A, B, C)
C
C   This routine adds MP numbers A and B to yield the MP sum C.  It attempts
C   to include all significance of A and B in the result, up to the maximum
C   mantissa length NW.  Debug output starts with IDB = 9.
C
C   Max SP space for C: NW + 4 cells.  Max DP scratch space: NW + 4 cells.
C
      DOUBLE PRECISION D
      PARAMETER (NDB = 22)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM4/ D(1024)
      DIMENSION A(NW+2), B(NW+2), C(NW+4)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPADD I'/(6F12.0))
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 1) (B(I), I = 1, NO)
      ENDIF
C
      IA = SIGN (1., A(1))
      IB = SIGN (1., B(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NB = MIN (INT (ABS (B(1))), NW)
C
C   This first IF block checks for zero inputs.
C
      IF (NA .EQ. 0) THEN
C
C   A is zero -- the result is B.
C
        C(1) = SIGN (NB, IB)
C
        DO 100 I = 2, NB + 2
          C(I) = B(I)
 100    CONTINUE
C
        GOTO 420
      ELSEIF (NB .EQ. 0) THEN
C
C   B is zero -- the result is A.
C
        C(1) = SIGN (NA, IA)
C
        DO 110 I = 1, NA + 2
          C(I) = A(I)
 110    CONTINUE
C
        GOTO 420
      ENDIF
      MA = A(2)
      MB = B(2)
C
C   This IF block breaks the problem into different branches depending on
C   the relative sizes of the exponents of A and B.
C
      IF (MA .EQ. MB) THEN
C
C   A and B have the same exponent.
C
        NM = MIN (NA, NB)
        NX = MAX (NA, NB)
        IF (IA .EQ. IB) THEN
C
C   A and B have the same exponent and sign.
C
          D(1) = SIGN (NX, IA)
          D(2) = MA
          D(NX+3) = 0.D0
          D(NX+4) = 0.D0
C
          DO 120 I = 3, NM + 2
            D(I) = DBLE (A(I)) + DBLE (B(I))
 120      CONTINUE
C
          IF (NA .GT. NB) THEN
C
C   A is longer than B -- include extra words of A in C.
C
            DO 130 I = NM + 3, NA + 2
              D(I) = A(I)
 130        CONTINUE
C
          ELSEIF (NB .GT. NA) THEN
C
C   B is longer than A -- include extra words of B in C.
C
            DO 140 I = NM + 3, NB + 2
              D(I) = B(I)
 140        CONTINUE
C
          ENDIF
        ELSE
C
C   A and B have the same exponent but the opposite sign.  It is thus
C   necessary to scan through each vector until we find an unequal word.
C
          DO 150 I = 3, NM + 2
            IF (A(I) .NE. B(I)) GOTO 180
 150      CONTINUE
C
C   All words up to the common length are equal.
C
          IF (NA .EQ. NB) THEN
C
C   The length of A is the same as B -- result is zero.
C
            C(1) = 0.D0
            C(2) = 0.D0
            GOTO 420
          ELSEIF (NA .GT. NB) THEN
C
C   A is longer -- thus trailing words of A are shifted to start of C.
C
            NN = NA - NB
            D(1) = SIGN (NN, IA)
            D(2) = A(2) - NB
            D(NN+3) = 0.D0
            D(NN+4) = 0.D0
C
            DO 160 I = 3, NN + 2
              D(I) = A(I+NB)
 160        CONTINUE
C
          ELSEIF (NB .GT. NA) THEN
C
C   B is longer -- thus trailing words of B are shifted to start of C.
C
            NN = NB - NA
            D(1) = SIGN (NN, IB)
            D(2) = B(2) - NA
            D(NN+3) = 0.D0
            D(NN+4) = 0.D0
C
            DO 170 I = 3, NN + 2
              D(I) = B(I+NA)
 170        CONTINUE
C
          ENDIF
          GOTO 410
C
C   An unequal word was found.
C
 180      K = I - 3
          IF (A(K+3) .GT. B(K+3)) THEN
C
C   A is larger -- subtract B (shifted) from A.
C
            D(1) = SIGN (NX - K, IA)
            D(2) = A(2) - K
            D(NX-K+3) = 0.D0
            D(NX-K+4) = 0.D0
C
            DO 190 I = 3, NM - K + 2
              D(I) = DBLE (A(I+K)) - DBLE (B(I+K))
 190        CONTINUE
C
            DO 200 I = NB - K + 3, NA - K + 2
              D(I) = A(I+K)
 200        CONTINUE
C
            DO 210 I = NA - K + 3, NB - K + 2
              D(I) = - B(I+K)
 210        CONTINUE
C
          ELSE
C
C   B is larger -- subtract A (shifted) from B.
C
            D(1) = SIGN (NX - K, IB)
            D(2) = B(2) - K
            D(NX-K+3) = 0.D0
            D(NX-K+4) = 0.D0
C
            DO 220 I = 3, NM - K + 2
              D(I) = DBLE (B(I+K)) - DBLE (A(I+K))
 220        CONTINUE
C
            DO 230 I = NB - K + 3, NA - K + 2
              D(I) = - A(I+K)
 230        CONTINUE
C
            DO 240 I = NA - K + 3, NB - K + 2
              D(I) = B(I+K)
 240        CONTINUE
C
          ENDIF
        ENDIF
      ELSEIF (MA .GT. MB) THEN
C
C   Exponent of A is greater.  In other words, A has a larger magnitude.
C
        MC = MA - MB
        LA = MIN (MC, NA)
        LB = MIN (MC + NB, NW + 2)
        LM = MIN (NA, LB)
        LX = MIN (MAX (NA, LB), NW)
        D(1) = SIGN (LX, IA)
        D(2) = A(2)
        D(LX+3) = 0.D0
        D(LX+4) = 0.D0
C
        DO 250 I = 3, LA + 2
          D(I) = A(I)
 250    CONTINUE
C
C   If B is shifted NW + 2 or more words to the right of A then C = A.
C
        IF (MC .GE. NW + 2) THEN
          D(1) = SIGN (NA, IA)
          GOTO 410
        ENDIF
        IF (MC .GT. NA) THEN
C
C   There is a gap between A and the shifted B.  Fill it with zeroes.
C
          DO 260 I = NA + 3, MC + 2
            D(I) = 0.D0
 260      CONTINUE
C
          LM = MC
        ENDIF
        IF (IA .EQ. IB) THEN
C
C   A and B have the same sign -- add common words with B shifted right.
C
          DO 270 I = MC + 3, LM + 2
            D(I) = DBLE (A(I)) + DBLE (B(I-MC))
 270      CONTINUE
C
C   Include tail of A or B, whichever is longer after shift.
C
          IF (NA .GT. LB) THEN
C
            DO 280 I = LM + 3, NA + 2
              D(I) = A(I)
 280        CONTINUE
C
          ELSE
C
            DO 290 I = LM + 3, LB + 2
              D(I) = B(I-MC)
 290        CONTINUE
C
          ENDIF
        ELSE
C
C   A and B have different signs -- subtract common words with B shifted right.
C
          DO 300 I = MC + 3, LM + 2
            D(I) = DBLE (A(I)) - DBLE (B(I-MC))
 300      CONTINUE
C
C   Include tail of A or B, whichever is longer after shift.
C
          DO 310 I = LM + 3, NA + 2
            D(I) = A(I)
 310      CONTINUE
C
          DO 320 I = LM + 3, LB + 2
            D(I) = - B(I-MC)
 320      CONTINUE
C
        ENDIF
      ELSE
C
C   Exponent of B is greater.  In other words, B has a larger magnitude.
C
        MC = MB - MA
        LB = MIN (MC, NB)
        LA = MIN (MC + NA, NW + 2)
        LM = MIN (NB, LA)
        LX = MIN (MAX (NB, LA), NW)
        D(1) = SIGN (LX, IB)
        D(2) = B(2)
        D(LX+3) = 0.D0
        D(LX+4) = 0.D0
C
        DO 330 I = 3, LB + 2
          D(I) = B(I)
 330    CONTINUE
C
C   If A is shifted NW + 2 or more words to the right of B then C = B.
C
        IF (MC .GE. NW + 2) THEN
          D(1) = SIGN (NB, IB)
          GOTO 410
        ENDIF
        IF (MC .GT. NB) THEN
C
C   There is a gap between B and the shifted A.  Fill it with zeroes.
C
          DO 340 I = NB + 3, MC + 2
            D(I) = 0.D0
 340      CONTINUE
C
          LM = MC
        ENDIF
        IF (IB .EQ. IA) THEN
C
C   B and A have the same sign -- add common words with A shifted right.
C
          DO 350 I = MC + 3, LM + 2
            D(I) = DBLE (B(I)) + DBLE (A(I-MC))
 350      CONTINUE
C
C   Include tail of B or A, whichever is longer after shift.
C
          DO 360 I = LM + 3, NB + 2
            D(I) = B(I)
 360      CONTINUE
C
          DO 370 I = LM + 3, LA + 2
            D(I) = A(I-MC)
 370      CONTINUE
C
        ELSE
C
C   B and A have different signs -- subtract common words with A shifted right.
C
          DO 380 I = MC + 3, LM + 2
            D(I) = DBLE (B(I)) - DBLE (A(I-MC))
 380      CONTINUE
C
C   Include tail of B or A, whichever is longer after shift.
C
          DO 390 I = LM + 3, NB + 2
            D(I) = B(I)
 390      CONTINUE
C
          DO 400 I = LM + 3, LA + 2
            D(I) = - A(I-MC)
 400      CONTINUE
C
        ENDIF
      ENDIF
C
C   Fix up result, since some words may be negative or exceed BDX.
C
 410  CALL MPNORM (C)
C
 420  IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 2) (C(I), I = 1, NO)
 2      FORMAT ('MPADD O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPAGMX (A, B)
C
C   This performs the arithmetic-geometric mean (AGM) iterations.  This routine
C   is called by MPLOGX.  It is not intended to be called directly by the user.
C
C   Max SP space for A and B: NW + 4 cells.  Max SP scratch space: 5 * NW + 26
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
      DIMENSION A(NW+4), B(NW+4)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      N4 = NW + 4
      NS = 2 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      S(K0) = 0.
      S(K0+1) = 0.
      L1 = 0
C
 100  L1 = L1 + 1
      IF (L1 .EQ. 50) THEN
        IF (KER(5) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPAGMX: Iteration limit exceeded.')
          IER = 5
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
      ENDIF
C
      S1 = S(K0+1)
      CALL MPADD (A, B, S(K0))
      CALL MPMULD (S(K0), 0.5D0, 0, S(K1))
      CALL MPMULX (A, B, S(K0))
      CALL MPSQRX (S(K0), B)
      CALL MPEQ (S(K1), A)
      CALL MPSUB (A, B, S(K0))
C
C   Check for convergence.
C
      IF (S(K0) .NE. 0. .AND. (S(K0+1) .NE. S1 .OR. S(K0+1) .GE. -2))   
     $  GOTO 100
C
      ICS = ISS
      IF (IDB .GE. 6) WRITE (LDB, 2) L1, S(K0+1)
 2    FORMAT ('MPAGMX: Iter., Tol. Achieved =',I5,F8.0)
      RETURN
      END
C
      SUBROUTINE MPALER
C
C   This outputs error messages when a single precision scratch space
C   allocation error is detected.
C
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      IF (KER(6) .NE. 0) THEN
        WRITE (LDB, 1) ICS - 1
 1      FORMAT ('*** MPALER: Insufficient single precision scratch ',   
     $    'space.'/ 'Allocate',I10,' cells in an array in common ',     
     $    'MPCOM3 of the main '/ 'program and set IMS in common ',      
     $    'MPCOM1 to this size.')
        IER = 6
        IF (KER(IER) .EQ. 2) CALL MPABRT
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE MPANG (X, Y, PI, A)
C
C   This computes the MP angle A subtended by the MP pair (X, Y) considered as
C   a point in the x-y plane.  This is more useful than an arctan or arcsin
C   routine, since it places the result correctly in the full circle, i.e.
C   -Pi < A <= Pi.  PI is the MP value of Pi computed by a previous call to
C   MPPI.  For extra high levels of precision, use MPANGX.  The last word of
C   the result is not reliable.  Debug output starts with IDB = 5.
C
C   Max SP space for A: NW + 4 cells.  Max SP scratch space: 14 * NW + 81
C   cells.  Max DP scratch space: NW + 7 cells.
C
C   The Taylor series for Sin converges much more slowly than that of Arcsin.
C   Thus this routine does not employ Taylor series, but instead computes
C   Arccos or Arcsin by solving Cos (a) = x or Sin (a) = y using one of the
C   following Newton iterations, both of which converge to a:
C
C           z_{k+1} = z_k - [x - Cos (z_k)] / Sin (z_k)
C           z_{k+1} = z_k + [y - Sin (z_k)] / Cos (z_k)
C
C   The first is selected if Abs (x) <= Abs (y); otherwise the second is used.
C   These iterations are performed with a maximum precision level NW that
C   is dynamically changed, approximately doubling with each iteration.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION CL2, CPI, T1, T2, T3
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, CPI = 3.141592653589793D0, 
     $  NIT = 3)
      DIMENSION A(NW+4), PI(NW+2), X(NW+2), Y(NW+2)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 5) THEN
        CALL MPDEB ('MPANG I', X)
        CALL MPDEB ('MPANG I', Y)
      ENDIF
C
      IX = SIGN (1., X(1))
      NX = MIN (INT (ABS (X(1))), NW)
      IY = SIGN (1., Y(1))
      NY = MIN (INT (ABS (Y(1))), NW)
C
C   Check if both X and Y are zero.
C
      IF (NX .EQ. 0 .AND. NY .EQ. 0) THEN
        IF (KER(7) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPANG: Both arguments are zero.')
          IER = 7
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if Pi has been precomputed.
C
      CALL MPMDC (PI, T1, N1)
      IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN
        IF (KER(8) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPANG: PI must be precomputed.')
          IER = 8
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if one of X or Y is zero.
C
      IF (NX .EQ. 0) THEN
        IF (IY .GT. 0) THEN
          CALL MPMULD (PI, 0.5D0, 0, A)
        ELSE
          CALL MPMULD (PI, -0.5D0, 0, A)
        ENDIF
        GOTO 120
      ELSEIF (NY .EQ. 0) THEN
        IF (IX .GT. 0) THEN
          A(1) = 0.
          A(2) = 0.
        ELSE
          CALL MPEQ (PI, A)
        ENDIF
        GOTO 120
      ENDIF
C
      N5 = NW + 5
      NS = 5 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      K4 = K3 + N5
      NWS = NW
      NW = NW + 1
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NWS
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Normalize x and y so that x^2 + y^2 = 1.
C
      CALL MPMUL (X, X, S(K0))
      CALL MPMUL (Y, Y, S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPSQRT (S(K2), S(K3))
      CALL MPDIV (X, S(K3), S(K1))
      CALL MPDIV (Y, S(K3), S(K2))
C
C   Compute initial approximation of the angle.
C
      CALL MPMDC (S(K1), T1, N1)
      CALL MPMDC (S(K2), T2, N2)
      N1 = MAX (N1, -66)
      N2 = MAX (N2, -66)
      T1 = T1 * 2.D0 ** N1
      T2 = T2 * 2.D0 ** N2
      T3 = ATAN2 (T2, T1)
      CALL MPDMC (T3, 0, A)
C
C   The smaller of x or y will be used from now on to measure convergence.
C   This selects the Newton iteration (of the two listed above) that has the
C   largest denominator.
C
      IF (ABS (T1) .LE. ABS (T2)) THEN
        KK = 1
        CALL MPEQ (S(K1), S(K0))
      ELSE
        KK = 2
        CALL MPEQ (S(K2), S(K0))
      ENDIF
C
      NW = 3
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (one greater than powers of two).
C
      DO 110 K = 2, MQ
        NW = MIN (2 * NW - 2, NWS) + 1
 100    CONTINUE
        CALL MPCSSN (A, PI, S(K1), S(K2))
        IF (KK .EQ. 1) THEN
          CALL MPSUB (S(K0), S(K1), S(K3))
          CALL MPDIV (S(K3), S(K2), S(K4))
          CALL MPSUB (A, S(K4), S(K1))
        ELSE
          CALL MPSUB (S(K0), S(K2), S(K3))
          CALL MPDIV (S(K3), S(K1), S(K4))
          CALL MPADD (A, S(K4), S(K1))
        ENDIF
        CALL MPEQ (S(K1), A)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (A)
C
 120  IF (IDB .GE. 5) CALL MPDEB ('MPANG O', A)
C
      RETURN
      END
C
      SUBROUTINE MPANGX (X, Y, PI, A)
C
C   This computes the MP angle A subtended by the MP pair (X, Y) considered as
C   a point in the x-y plane.  This is more useful than an arctan or arcsin
C   routine, since it places the result correctly in the full circle, i.e.
C   -Pi < A <= Pi.  PI is the MP value of Pi computed by a previous call to
C   MPPI or MPPIX.  Before calling MPANGX, the array in MPCOM5 must be
C   initialized by calling MPINIX.  For modest levels of precision, use MPANG.
C   NW should be a power of two.  The last three words of the result are not
C   reliable.  Debug output starts with IDB = 6.
C
C   Max SP space for A: NW + 4 cells.  Max SP scratch space: 18 * NW + 78
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine employs a complex arithmetic version of the MPLOGX alogirthm.
C
      DOUBLE PRECISION CPI, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CPI = 3.141592653589793D0)
      DIMENSION A(NW+4), F0(8), F1(8), F4(8), PI(NW+2), X(NW+2), Y(NW+2)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) THEN
        CALL MPDEB ('MPANGX I', X)
        CALL MPDEB ('MPANGX I', Y)
      ENDIF
C
      IX = SIGN (1., X(1))
      NX = MIN (INT (ABS (X(1))), NW)
      IY = SIGN (1., Y(1))
      NY = MIN (INT (ABS (Y(1))), NW)
      NCR = 2 ** MCR
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPANG (X, Y, PI, A)
        GOTO 100
      ENDIF
C
C   Check if both X and Y are zero.
C
      IF (NX .EQ. 0 .AND. NY .EQ. 0) THEN
        IF (KER(9) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPANGX: Both arguments are zero.')
          IER = 9
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if Pi has been precomputed.
C
      CALL MPMDC (PI, T1, N1)
      IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN
        IF (KER(10) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPANGX: PI must be precomputed.')
          IER = 10
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if one of X or Y is zero.
C
      IF (NX .EQ. 0) THEN
        IF (IY .GT. 0) THEN
          CALL MPMULD (PI, 0.5D0, 0, A)
        ELSE
          CALL MPMULD (PI, -0.5D0, 0, A)
        ENDIF
        GOTO 100
      ELSEIF (NY .EQ. 0) THEN
        IF (IX .GT. 0) THEN
          A(1) = 0.
          A(2) = 0.
        ELSE
          CALL MPEQ (PI, A)
        ENDIF
        GOTO 100
      ENDIF
C
C   Define scratch space.
C
      N4 = NW + 4
      N42 = 2 * N4
      NS = 4 * N42
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N42
      K2 = K1 + N42
      K3 = K2 + N42
      F0(1) = 0.
      F0(2) = 0.
      F0(3) = 0.
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      F4(1) = 1.
      F4(2) = 0.
      F4(3) = 4.
C
C   Multiply the input by a large power of two.
C
      CALL MPMDC (X, T1, N1)
      N2 = NBT * (NW / 2 + 2) - N1
      TN = N2
      CALL MPMULD (X, 1.D0, N2, S(K1))
      CALL MPMULD (Y, 1.D0, N2, S(K2))
      CALL MPMMPC (S(K1), S(K2), N4, S(K0))
C
C   Perform AGM iterations.
C
      CALL MPMMPC (F1, F0, N4, S(K1))
      CALL MPMMPC (F4, F0, N4, S(K3))
      CALL MPCDVX (N4, S(K3), S(K0), S(K2))
      CALL MPCAGX (S(K1), S(K2))
C
C   Compute A = Imag (Pi / (2 * Z)), where Z is the limit of the complex AGM.
C
      CALL MPMULD (S(K1), 2.D0, 0, S(K0))
      CALL MPMULD (S(K1+N4), 2.D0, 0, S(K0+N4))
      CALL MPMMPC (PI, F0, N4, S(K2))
      CALL MPCDVX (N4, S(K2), S(K0), S(K1))
      CALL MPEQ (S(K1+N4), A)
      ICS = ISS
C
 100  IF (IDB .GE. 6) CALL MPDEB ('MPANGX O', A)
C
      RETURN
      END
C
      SUBROUTINE MPCADD (L, A, B, C)
C
C   This computes the sum of the MPC numbers A and B and returns the MPC
C   result in C.  L is the offset between real and imaginary parts in A, B
C   and C.  L must be at least NW + 4.  Debug output starts with IDB = 9.
C
C   Max SP space for C: 2 * L cells.
C
      DIMENSION A(2*L), B(2*L), C(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) WRITE (LDB, 1)
 1    FORMAT ('MPCADD')
C
      IF (L .LT. NW + 4) THEN
        IF (KER(11) .NE. 0) THEN
          WRITE (LDB, 2) L, NW + 4
 2        FORMAT ('*** MPCADD: Offset parameter is too small',2I8)
          IER = 11
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      L1 = L + 1
      CALL MPADD (A, B, C)
      CALL MPADD (A(L1), B(L1), C(L1))
C
      RETURN
      END
C
      SUBROUTINE MPCAGX (A, B)
C
C   This performs the arithmetic-geometric mean (AGM) iterations.  This routine
C   is called by MPANGX.  It is not intended to be called directly by the user.
C
C   Max SP space for A and B: 2*NW + 8 cells.  Max SP scratch space: 10*NW + 46
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
      DIMENSION A(2*NW+8), B(2*NW+8)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + 2 * N4
      S(K0) = 0.
      S(K0+1) = 0.
      L1 = 0
C
 100  L1 = L1 + 1
      IF (L1 .EQ. 50) THEN
        IF (KER(12) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPCAGX: Iteration limit exceeded.')
          IER = 12
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
      ENDIF
C
      S1 = S(K0+1)
      CALL MPCADD (N4, A, B, S(K0))
      CALL MPMULD (S(K0), 0.5D0, 0, S(K1))
      CALL MPMULD (S(K0+N4), 0.5D0, 0, S(K1+N4))
      CALL MPCMLX (N4, A, B, S(K0))
      CALL MPCSQX (N4, S(K0), B)
      CALL MPCEQ (N4, S(K1), A)
      CALL MPSUB (A, B, S(K0))
C
C   Check for convergence.
C
      IF (S(K0) .NE. 0. .AND. (S(K0+1) .NE. S1 .OR. S(K0+1) .GE. -2))   
     $  GOTO 100
C
      ICS = ISS
      IF (IDB .GE. 6) WRITE (LDB, 2) L1, S(K0+1)
 2    FORMAT ('MPCAGX: Iter., Tol. Achieved =',I5,F8.0)
      RETURN
      END
C
      SUBROUTINE MPCBRT (A, B)
C
C   This computes the cube root of the MP number A and returns the MP result
C   in B.  For extra high levels of precision, use MPCBRX.  Debug output
C   starts with IDB = 7.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 3 * NW + 15
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   This subroutine employs the following Newton-Raphson iteration, which
C   converges to A ^ (-2/3):
C
C          X_{n+1} = X_k + (X_k / 3) * (1 - A^2 * X_k^3)
C
C   Multiplying the final approximation to A ^ (-2/3) by A gives the cube
C   root. These iterations are performed with a maximum precision level NW that
C   is dynamically changed, approximately doubling with each iteration.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION CL2, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 3)
      DIMENSION A(NW+2), B(NW+4), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPCBRT I'/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
C
      IF (NA .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 120
      ENDIF
      IF (IA .LT. 0.D0) THEN
        IF (KER(13) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPCBRT: Argument is negative.')
          IER = 13
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N5 = NW + 5
      NS = 3 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      NWS = NW
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Compute A^2 outside of the iteration loop.
C
      NW = NWS + 1
      CALL MPMUL (A, A, S(K0))
C
C   Compute the initial approximation of A ^ (-2/3).
C
      CALL MPMDC (A, T1, N)
      N3 = - 2 * N / 3
      T2 = (T1 * 2.D0 ** (N + 3.D0 * N3 / 2.D0)) ** (-2.D0 / 3.D0)
      CALL MPDMC (T2, N3, B)
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
      NW = 3
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (one greater than powers of two).
C
      DO 110 K = 2, MQ
        NW = MIN (2 * NW - 2, NWS) + 1
 100    CONTINUE
        CALL MPMUL (B, B, S(K1))
        CALL MPMUL (B, S(K1), S(K2))
        CALL MPMUL (S(K0), S(K2), S(K1))
        CALL MPSUB (F, S(K1), S(K2))
        CALL MPMUL (B, S(K2), S(K1))
        CALL MPDIVD (S(K1), 3.D0, 0, S(K2))
        CALL MPADD (B, S(K2), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Multiply by A to give final result.
C
      CALL MPMUL (A, B, S(K1))
      CALL MPEQ (S(K1), B)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (B)
C
 120  IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPCBRT O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCBRX (A, B)
C
C   This computes the cube root of the MP number A and returns the MP result
C   in B.  Before calling MPCBRX, the array in MPCOM5 must be initialized by
C   calling MPINIX.  For modest levels of precision, use MPCBRT.  NW should be
C   a power of two.  The last three words of the result are not reliable.
C   Debug output starts with IDB = 6.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 4.5 * NW + 27
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine uses basically the same Newton iteration algorithm as MPCBRT.
C   In fact, this routine calls MPCBRT to obtain an initial approximation.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1)
      DIMENSION A(NW+2), B(NW+4), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPCBRX I'/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NCR = 2 ** MCR
C
      IF (NA .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 120
      ENDIF
      IF (IA .LT. 0.D0) THEN
        IF (KER(14) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPCBRX: Argument is negative.')
          IER = 14
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPCBRT (A, B)
        GOTO 120
      ENDIF
      N4 = NW + 4
      NS = 3 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      NWS = NW
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Compute A^2 outside of the iteration loop.
C
      CALL MPMULX (A, A, S(K0))
C
C   Compute the initial approximation of A ^ (-2/3).
C
      NW = NCR
      CALL MPCBRT (A, S(K1))
      CALL MPDIV (S(K1), A, B)
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (powers of two).
C
      DO 110 K = MCR + 1, MQ
        AN = NW
        NW = MIN (2 * NW, NWS)
 100    CONTINUE
        CALL MPMULX (B, B, S(K1))
        CALL MPMULX (B, S(K1), S(K2))
        CALL MPMULX (S(K0), S(K2), S(K1))
        CALL MPSUB (F, S(K1), S(K2))
        S(K2) = MIN (S(K2), AN)
        CALL MPMULX (B, S(K2), S(K1))
        CALL MPDIVD (S(K1), 3.D0, 0, S(K2))
        CALL MPADD (B, S(K2), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Multiply by A to give final result.
C
      CALL MPMULX (A, B, S(K1))
      CALL MPEQ (S(K1), B)
      ICS = ISS
C
 120  IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPCBRX O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCDIV (L, A, B, C)
C
C   This routine divides the MP complex numbers A and B to yield the MPC
C   quotient C.  L is the offset between real and imaginary parts in A, B
C   and the result C.  L must be at least NW + 4.  For extra high levels of
C   precision, use MPCDVX.  The last word is not reliable.  Debug output
C   starts with IDB = 7
C
C   Max SP space for C: 2 * L cells.  Max SP scratch space: 5 * NW + 20
C   cells.  Max DP scratch space: NW + 4 cells.
C
C   This routine employs the formula described in MPCMUL to save multiprecision
C   multiplications.
C
      PARAMETER (NDB = 22)
      DIMENSION A(2*L), B(2*L), C(2*L), F(8)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 7) THEN
        WRITE (LDB, 1) L
 1      FORMAT ('MPCDIV I',I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCDIV I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 2) (B(I), I = 1, NO)
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 2) (B(L+I), I = 1, NO)
      ENDIF
C
      IF (L .LT. NW + 4) THEN
        IF (KER(15) .NE. 0) THEN
          WRITE (LDB, 3) L, NW + 4
 3        FORMAT ('*** MPCDIV: Offset parameter is too small',2I8)
          IER = 15
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      IF (B(1) .EQ. 0. .AND. B(L1) .EQ. 0.) THEN
        IF (KER(16) .NE. 0) THEN
          WRITE (LDB, 4)
 4        FORMAT ('*** MPCDIV: Divisor is zero.')
          IER = 16
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      NS = 5 * N4
      ISS = ICS
      ICS = ICS + NS
      IF (ICS - 1 .GT. IMS) CALL MPALER
      IHS = MAX (ICS, IHS)
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      K4 = K3 + N4
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
C
      CALL MPMUL (A, B, S(K0))
      CALL MPMUL (A(L1), B(L1), S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPSUB (S(K0), S(K1), S(K3))
      CALL MPADD (A, A(L1), S(K0))
      CALL MPSUB (B, B(L1), S(K1))
      CALL MPMUL (S(K0), S(K1), S(K4))
      CALL MPSUB (S(K4), S(K3), S(K1))
      CALL MPMUL (B, B, S(K0))
      CALL MPMUL (B(L1), B(L1), S(K3))
      CALL MPADD (S(K0), S(K3), S(K4))
      CALL MPDIV (F, S(K4), S(K0))
      CALL MPMUL (S(K2), S(K0), C)
      CALL MPMUL (S(K1), S(K0), C(L1))
      ICS = ISS
C
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 5) (C(I), I = 1, NO)
 5      FORMAT ('MPCDIV O'/(6F12.0))
        NO = MIN (INT (ABS (C(L1))), NDB) + 2
        WRITE (LDB, 5) (C(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCDVX (L, A, B, C)
C
C   This routine divides the MP complex numbers A and B to yield the MPC
C   quotient C.  L is the offset between real and imaginary parts in A, B
C   the result C.  L must be at least NW + 4.  Before calling MPCDVX, the
C   array in MPCOM5 must be initialized by calling MPINIX.  For modest levels
C   of precision, use MPCDIV.  NW should be a power of two.  The last two
C   words are not reliable.  Debug output starts with IDB = 7
C
C   Max SP space for C: 2 * L cells.  Max SP scratch space: 7 * NW + 28
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine employs the same scheme as MPCDIV.
C
      PARAMETER (NDB = 22)
      DIMENSION A(2*L), B(2*L), C(2*L), F(8)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 7) THEN
        WRITE (LDB, 1) L
 1      FORMAT ('MPCDVX I',I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCDVX I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 2) (B(I), I = 1, NO)
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 2) (B(L+I), I = 1, NO)
      ENDIF
C
      IF (L .LT. NW + 4) THEN
        IF (KER(17) .NE. 0) THEN
          WRITE (LDB, 3) L, NW + 4
 3        FORMAT ('*** MPCDVX: Offset parameter is too small',2I8)
          IER = 17
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      IF (B(1) .EQ. 0. .AND. B(L1) .EQ. 0.) THEN
        IF (KER(18) .NE. 0) THEN
          WRITE (LDB, 4)
 4        FORMAT ('*** MPCDVX: Divisor is zero.')
          IER = 18
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      NS = 5 * N4
      ISS = ICS
      ICS = ICS + NS
      IF (ICS - 1 .GT. IMS) CALL MPALER
      IHS = MAX (ICS, IHS)
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      K4 = K3 + N4
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
C
      CALL MPMULX (A, B, S(K0))
      CALL MPMULX (A(L1), B(L1), S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPSUB (S(K0), S(K1), S(K3))
      CALL MPADD (A, A(L1), S(K0))
      CALL MPSUB (B, B(L1), S(K1))
      CALL MPMULX (S(K0), S(K1), S(K4))
      CALL MPSUB (S(K4), S(K3), S(K1))
      CALL MPMULX (B, B, S(K0))
      CALL MPMULX (B(L1), B(L1), S(K3))
      CALL MPADD (S(K0), S(K3), S(K4))
      CALL MPDIVX (F, S(K4), S(K0))
      CALL MPMUL (S(K2), S(K0), C)
      CALL MPMUL (S(K1), S(K0), C(L1))
      ICS = ISS
C
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 5) (C(I), I = 1, NO)
 5      FORMAT ('MPCDVX O'/(6F12.0))
        NO = MIN (INT (ABS (C(L1))), NDB) + 2
        WRITE (LDB, 5) (C(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCEQ (L, A, B)
C
C   This sets the MPC number B equal to the MPC number A.  L is the offset
C   between real and imaginary parts in A and B.  Debug output starts with
C   IDB = 10.
C
C   Max SP space for B: 2 * L cells.
C
      DIMENSION A(2*L), B(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 10) WRITE (LDB, 1)
 1    FORMAT ('MPCEQ')
C
      I1 = SIGN (1., A(1))
      N1 = MIN (INT (ABS (A(1))), NW, L - 2)
      I2 = SIGN (1., A(L+1))
      N2 = MIN (INT (ABS (A(L+1))), NW, L - 2)
      B(1) = SIGN (N1, I1)
      B(L+1) = SIGN (N2, I2)
C
      DO 100 I = 2, N1 + 2
        B(I) = A(I)
 100  CONTINUE
C
      DO 110 I = 2, N2 + 2
        B(L+I) = A(L+I)
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPCFFT (IS, M, X, Y)
C
C   This routine computes the 2^M -point complex-to-complex FFT of X.  See
C   article by DHB in Intl. J. of Supercomputer Applications, Spring 1988,
C   p. 82 - 87).  X and Y are double precision.  X is both the input and the
C   output array, while Y is a scratch array.  Both X and Y must be
C   dimensioned with 2 * N cells, where N = 2^M.  The data in X are assumed
C   to have real and imaginary parts separated by N cells.  A call to MPCFFT
C   with IS = 1 (or -1) indicates a call to perform a FFT with positive (or
C   negative) exponentials.  M must be at least two.  Before calling MPCRFT,
C   the array in MPCOM5 must be initialized by calling MPINIX.
C
C   In this application, MPCFFT is called by MPRCFT and MPCRFT, which are in
C   turn called by MPMULX.  This routine is not intended to be called directly
C   by the user.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(*), Y(*)
C
      N = 2 ** M
C>
C   For Cray computers, it is most efficient to limit M1 to 6.  For most
C   scalar computers, it is best to limit M1 to 2.  Uncomment whichever of the
C   next two lines is appropriate.
C
C      M1 = MIN (M / 2, 6)
      M1 = MIN (M / 2, 2)
      M2 = M - M1
      N2 = 2 ** M1
      N1 = 2 ** M2
C
C   Perform one variant of the Stockham FFT.
C
      DO 100 L = 1, M1, 2
        CALL MPFFT1 (IS, L, M, X, Y)
        IF (L .EQ. M1) GOTO 120
        CALL MPFFT1 (IS, L + 1, M, Y, X)
 100  CONTINUE
C
C   Perform a transposition of X treated as a N2 x N1 x 2 matrix.
C
      CALL MPTRAN (N1, N2, X, Y)
C
C   Perform second variant of the Stockham FFT from Y to X and X to Y.
C
      DO 110 L = M1 + 1, M, 2
        CALL MPFFT2 (IS, L, M, Y, X)
        IF (L .EQ. M) GOTO 160
        CALL MPFFT2 (IS, L + 1, M, X, Y)
 110  CONTINUE
C
      GOTO 140
C
C   Perform a transposition of Y treated as a N2 x N1 x 2 matrix.
C
 120  CALL MPTRAN (N1, N2, Y, X)
C
C   Perform second variant of the Stockham FFT from X to Y and Y to X.
C
      DO 130 L = M1 + 1, M, 2
        CALL MPFFT2 (IS, L, M, X, Y)
        IF (L .EQ. M) GOTO 140
        CALL MPFFT2 (IS, L + 1, M, Y, X)
 130  CONTINUE
C
      GOTO 160
C
C   Copy Y to X.
C
 140  DO 150 I = 1, 2 * N
        X(I) = Y(I)
 150  CONTINUE
C
 160  RETURN
      END
C
      SUBROUTINE MPCMLX (L, A, B, C)
C
C   This routine multiplies the MP complex numbers A and B to yield the MPC
C   product C.  L is the offset between real and imaginary parts in A, B and
C   the result C.  L must be at least NW + 4.  Before calling MPCMLX, the
C   array in MPCOM5 must be initialized by calling MPINIX.  For modest levels
C   of precision, use MPCMUL.  NW should be a power of two.  The last word is
C   not reliable.  Debug output starts with IDB = 7.
C
C   Max SP space for C: 2 * L cells.  Max SP scratch space: 4 * NW + 16
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine employs the same scheme as MPCMUL.
C
      PARAMETER (NDB = 22)
      DIMENSION A(2*L), B(2*L), C(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 7) THEN
        WRITE (LDB, 1) L
 1      FORMAT ('MPCMLX I',I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCMLX I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 2) (B(I), I = 1, NO)
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 2) (B(L+I), I = 1, NO)
      ENDIF
C
      IF (L .LT. NW + 4) THEN
        IF (KER(19) .NE. 0) THEN
          WRITE (LDB, 3) L, NW + 4
 3        FORMAT ('*** MPCMLX: Offset parameter is too small',2I8)
          IER = 19
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IF (ICS - 1 .GT. IMS) CALL MPALER
      IHS = MAX (ICS, IHS)
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
C
      CALL MPMULX (A, B, S(K0))
      CALL MPMULX (A(L1), B(L1), S(K1))
      CALL MPSUB (S(K0), S(K1), C)
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPADD (A, A(L1), S(K0))
      CALL MPADD (B, B(L1), S(K1))
      CALL MPMULX (S(K0), S(K1), S(K3))
      CALL MPSUB (S(K3), S(K2), C(L1))
      ICS = ISS
C
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 4) (C(I), I = 1, NO)
 4      FORMAT ('MPCMLX O'/(6F12.0))
        NO = MIN (INT (ABS (C(L1))), NDB) + 2
        WRITE (LDB, 4) (C(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCMUL (L, A, B, C)
C
C   This routine multiplies the MP complex numbers A and B to yield the MPC
C   product C.  L is the offset between real and imaginary parts in A, B and
C   the result C.  L must be at least NW + 4.  For extra high levels of
C   precision, use MPCMLX.  The last word is not reliable.  Debug output
C   starts with IDB = 7.
C
C   Max SP space for C: 2 * L cells.  Max SP scratch space: 4 * NW + 16
C   cells.  Max DP scratch space: NW + 4 cells.
C
C   This routine employs the formula
C
C   (a_1 + a_2 i) (b_1 + b_2 i)  =  [a_1 b_1 - a_2 b_2]  +
C                [(a_1 + b_1) (a_2 + b_2) - (a_1 b_1 + a_2 b_2)] i
C
C   Note that this formula can be implemented with only three multiplications
C   whereas the conventional formula requires four.
C
      PARAMETER (NDB = 22)
      DIMENSION A(2*L), B(2*L), C(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE.7) THEN
        WRITE (LDB, 1) L
 1      FORMAT ('MPCMUL I',I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCMUL I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 2) (B(I), I = 1, NO)
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 2) (B(L+I), I = 1, NO)
      ENDIF
C
      IF (L .LT. NW + 4) THEN
        IF (KER(20) .NE. 0) THEN
          WRITE (LDB, 3) L, NW + 4
 3        FORMAT ('*** MPCMUL: Offset parameter is too small',2I8)
          IER = 20
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IF (ICS - 1 .GT. IMS) CALL MPALER
      IHS = MAX (ICS, IHS)
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
C
      CALL MPMUL (A, B, S(K0))
      CALL MPMUL (A(L1), B(L1), S(K1))
      CALL MPSUB (S(K0), S(K1), C)
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPADD (A, A(L1), S(K0))
      CALL MPADD (B, B(L1), S(K1))
      CALL MPMUL (S(K0), S(K1), S(K3))
      CALL MPSUB (S(K3), S(K2), C(L1))
      ICS = ISS
C
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 4) (C(I), I = 1, NO)
 4      FORMAT ('MPCMUL O'/(6F12.0))
        NO = MIN (INT (ABS (C(L1))), NDB) + 2
        WRITE (LDB, 4) (C(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCPLX (N, LA, A, X1, NX, LX, X)
C
C   This routine finds a complex root of the N-th degree polynomial whose
C   MPC coefficients are in A by Newton-Raphson iterations, beginning
C   at the complex DPE value (X1(1), NX(1)) + i (X1(2), NX(2)), and returns
C   the MPC root in X.  The N + 1 coefficients a_0, a_1, ..., a_N are
C   assumed to start in locations A(1), A(2*LA+1), A(4*LA+1), etc.  LA is the
C   offset between the real and the imaginary parts of each input coefficient.
C   Typically LA = NW + 4.  LX, also an input parameter, is the offset between
C   the real and the imaginary parts of the result to be stored in X.  LX
C   should be at least NW + 4.  Before calling MPCPLX, the array in MPCOM5
C   be initialized by calling MPINIX.  For modest levels of precision, use
C   MPCPOL.  NW should be a power of two.  The last two words of the result
C   are not reliable.  Debug output starts with IDB = 5.
C
C   Max SP space for X: 2 * LX cells.  Max SP scratch space: 17.5 * NW + 115
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   See the note in MPPOL about repeated roots.
C
C   This routine employs the same scheme as MPCPOL.
C
      CHARACTER*8 CX
      DOUBLE PRECISION T1, X1
      DIMENSION A(2*LA,N+1), NX(2), X(2*LX), X1(2)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        X(LX+1) = 0.
        X(LX+2) = 0.
      ENDIF
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 1) N, LX
 1      FORMAT ('MPCPLX I',2I6)
C
        DO 100 K = 0, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, A(1,K+1))
          CALL MPDEB (CX, A(LA+1,K+1))
 100    CONTINUE
C
        WRITE (LDB, 2) X1(2), NX(2)
 2      FORMAT ('MPCPLX I',F16.12,' x 10 ^',I6,F20.12,' x 10^',I6)
      ENDIF
C
C   Check if precision level is too low to justify the advanced routine.
C
      NCR = 2 ** MCR
      IF (NW .LE. NCR) THEN
        CALL MPCPOL (N, LA, A, X1, NX, LX, X)
        L1 = 0
        GOTO 150
      ENDIF
C
C   Check if the polynomial is proper.
C
      IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN
        IF (KER(21) .NE. 0) THEN
          WRITE (LDB, 3)
 3        FORMAT ('*** MPCPLX: Either the first or last input ',        
     $      'coefficient is zero.')
          IER = 21
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      N8 = 2 * N4
      NS = 10 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N8
      K2 = K1 + N8
      K3 = K2 + N8
      K4 = K3 + N8
      NWS = NW
C
C   Set the initial value.
C
      NW = NCR
      CALL MPCPOL (N, LA, A, X1, NX, N4, S(K0))
      TL = -4.
      L1 = 0
      LS = -10
C
C   Perform MP Newton-Raphson iterations to solve P(x) = 0.
C
 110  L1 = L1 + 1
      IF (L1 .EQ. 50) THEN
        IF (KER(22) .NE. 0) THEN
          WRITE (LDB, 4)
 4        FORMAT ('*** MPCPLX: Iteration limit exceeded.')
          IER = 22
          IF (KER(IER) .EQ. 2) CALL MPABRT
          ICS = ISS
          NW = NWS
          RETURN
        ENDIF
      ENDIF
C
C   Compute P(x).
C
      CALL MPMMPC (A(1,N+1), A(LA+1,N+1), N4, S(K1))
C
      DO 120 K = N - 1, 0, -1
        CALL MPCMLX (N4, S(K0), S(K1), S(K2))
        CALL MPADD (S(K2), A(1,K+1), S(K1))
        CALL MPADD (S(K2+N4), A(LA+1,K+1), S(K1+N4))
 120  CONTINUE
C
C   Compute P'(x).
C
      T1 = N
      CALL MPMULD (A(1,N+1), T1, 0, S(K2))
      CALL MPMULD (A(LA+1,N+1), T1, 0, S(K2+N4))
C
      DO 130 K = N - 1, 1, -1
        CALL MPCMLX (N4, S(K0), S(K2), S(K3))
        T1 = K
        CALL MPMULD (A(1,K+1), T1, 0, S(K4))
        CALL MPMULD (A(LA+1,K+1), T1, 0, S(K4+N4))
        CALL MPCADD (N4, S(K3), S(K4), S(K2))
 130  CONTINUE
C
C   Compute P(x) / P'(x) and update x.
C
      CALL MPCDVX (N4, S(K1), S(K2), S(K3))
      CALL MPCSUB (N4, S(K0), S(K3), S(K4))
C
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 5) L1
 5      FORMAT ('ITERATION',I4)
        CALL MPDEB ('X', S(K0))
        CALL MPDEB (' ', S(K0+N4))
        CALL MPDEB ('P(X)', S(K1))
        CALL MPDEB (' ', S(K1+N4))
        CALL MPDEB ('P''(X)', S(K2))
        CALL MPDEB (' ', S(K2+N4))
        CALL MPDEB ('CORR', S(K3))
        CALL MPDEB (' ', S(K3+N4))
      ENDIF
      CALL MPCEQ (N4, S(K4), S(K0))
C
C   If this was the second iteration at full precision, there is no need to
C   continue (the adjusted value of x is correct); otherwise repeat.
C
      IF (L1 .EQ. LS + 1) GOTO 140
      IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL .OR. S(K3+N4) .NE. 0.     
     $  .AND. S(K3+N4+1) .GT. TL) GOTO 110
C
C   Newton iterations have converged to current precision.  Increase precision
C   and continue.
C
      IF (NW .EQ. NWS) GOTO 140
      NW = MIN (2 * NW, NWS)
      IF (NW .EQ. NWS) LS = L1
      IF (NW .LE. 32) THEN
        TL = 2 - NW
      ELSEIF (NW .LE. 256) THEN
        TL = 3 - NW
      ELSE
        TL = 4 - NW
      ENDIF
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 6) NW
 6      FORMAT (6X,'New NW =', I8)
      ENDIF
      GOTO 110
C
 140  CALL MPMMPC (S(K0), S(K0+N4), LX, X)
      ICS = ISS
C
 150  IF (IDB .GE. 5) THEN
        WRITE (LDB, 7) L1
 7      FORMAT ('Iteration count:',I5)
        CALL MPDEB ('MPCPLX O', X)
        CALL MPDEB (' ', X(LX+1))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCPOL (N, LA, A, X1, NX, LX, X)
C
C   This routine finds a complex root of the N-th degree polynomial whose
C   MPC coefficients are in A by Newton-Raphson iterations, beginning
C   at the complex DPE value (X1(1), NX(1)) + i (X1(2), NX(2)), and returns
C   the MPC root in X.  The N + 1 coefficients a_0, a_1, ..., a_N are
C   assumed to start in locations A(1), A(2*LA+1), A(4*LA+1), etc.  LA is the
C   offset between the real and the imaginary parts of each input coefficient.
C   Typically LA = NW + 4.  LX, also an input parameter, is the offset between
C   the real and the imaginary parts of the result to be stored in X.  LX must
C   be at least NW + 4.  For extra high levels of precision, use MPCPLX.
C   Debug output starts with IDB = 5.
C
C   Max SP space for X: 2 * LX cells.  Max SP scratch space: 15 * NW + 75
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   See the note about repeated roots in MPPOL.
C
C   This routine employs the complex form of the Newton-Raphson iteration:
C
C   X_{k+1} = X_k - P(X_k) / P'(X_k)
C
C   These iterations are performed with a maximum precision level NW that is
C   dynamically changed, approximately doubling with each iteration.
C
      CHARACTER*8 CX
      DOUBLE PRECISION T1, X1
      DIMENSION A(2*LA,N+1), NX(2), X(2*LX), X1(2)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        X(LX+1) = 0.
        X(LX+2) = 0.
      ENDIF
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 1) N, LX
 1      FORMAT ('MPCPOL I',2I6)
C
        DO 100 K = 0, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, A(1,K+1))
          CALL MPDEB (CX, A(LA+1,K+1))
 100    CONTINUE
C
        WRITE (LDB, 2) X1(1), NX(1), X1(2), NX(2)
 2      FORMAT ('MPCPOL I',F16.12,' x 10 ^',I6,F20.12,' x 10^',I6)
      ENDIF
C
C  Check if the polynomial is proper.
C
      IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN
        IF (KER(23) .NE. 0) THEN
          WRITE (LDB, 3)
 3        FORMAT ('*** MPCPOL: Either the first or last input ',        
     $      'coefficient is zero.')
          IER = 23
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N5 = NW + 5
      N10 = 2 * N5
      NS = 10 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N10
      K2 = K1 + N10
      K3 = K2 + N10
      K4 = K3 + N10
      NWS = NW
      NW = NW + 1
C
C   Set the initial value.
C
      CALL MPDMC (X1(1), NX(1), S(K0))
      CALL MPDMC (X1(2), NX(2), S(K0+N5))
      NW = 5
      TL = -4.
      L1 = 0
      LS = -10
C
C   Perform MP Newton-Raphson iterations to solve P(x) = 0.
C
 110  L1 = L1 + 1
      IF (L1 .EQ. 50) THEN
        IF (KER(24) .NE. 0) THEN
          WRITE (LDB, 4)
 4        FORMAT ('*** MPCPOL: Iteration limit exceeded.')
          IER = 24
          IF (KER(IER) .EQ. 2) CALL MPABRT
          ICS = ISS
          NW = NWS
          RETURN
        ENDIF
      ENDIF
C
C   Compute P(x).
C
      CALL MPMMPC (A(1,N+1), A(LA+1,N+1), N5, S(K1))
C
      DO 120 K = N - 1, 0, -1
        CALL MPCMUL (N5, S(K0), S(K1), S(K2))
        CALL MPADD (S(K2), A(1,K+1), S(K1))
        CALL MPADD (S(K2+N5), A(LA+1,K+1), S(K1+N5))
 120  CONTINUE
C
C   Compute P'(x).
C
      T1 = N
      CALL MPMULD (A(1,N+1), T1, 0, S(K2))
      CALL MPMULD (A(LA+1,N+1), T1, 0, S(K2+N5))
C
      DO 130 K = N - 1, 1, -1
        CALL MPCMUL (N5, S(K0), S(K2), S(K3))
        T1 = K
        CALL MPMULD (A(1,K+1), T1, 0, S(K4))
        CALL MPMULD (A(LA+1,K+1), T1, 0, S(K4+N5))
        CALL MPCADD (N5, S(K3), S(K4), S(K2))
 130  CONTINUE
C
C   Compute P(x) / P'(x) and update x.
C
      CALL MPCDIV (N5, S(K1), S(K2), S(K3))
      CALL MPCSUB (N5, S(K0), S(K3), S(K4))
C
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 5) L1
 5      FORMAT ('Iteration',I4)
        CALL MPDEB ('X', S(K0))
        CALL MPDEB (' ', S(K0+N5))
        CALL MPDEB ('P(X)', S(K1))
        CALL MPDEB (' ', S(K1+N5))
        CALL MPDEB ('P''(X)', S(K2))
        CALL MPDEB (' ', S(K2+N5))
        CALL MPDEB ('CORR', S(K3))
        CALL MPDEB (' ', S(K3+N5))
      ENDIF
      CALL MPCEQ (N5, S(K4), S(K0))
C
C   If this was the second iteration at full precision, there is no need to
C   continue (the adjusted value of x is correct); otherwise repeat.
C
      IF (L1 .EQ. LS + 1) GOTO 140
      IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL .OR. S(K3+N5) .NE. 0.     
     $  .AND. S(K3+N5+1) .GT. TL) GOTO 110
C
C   Newton iterations have converged to current precision.  Increase precision
C   and continue.
C
      IF (NW .EQ. NWS + 1) GOTO 140
      NW = MIN (2 * NW - 2, NWS) + 1
      IF (NW .EQ. NWS + 1) LS = L1
      TL = 1 - NW
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 6) NW
 6      FORMAT (6X,'New NW =', I8)
      ENDIF
      GOTO 110
C
 140  CALL MPMMPC (S(K0), S(K0+N5), LX, X)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (X)
      CALL MPROUN (X(LX+1))
C
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 7) L1
 7      FORMAT ('Iteration count:',I5)
        CALL MPDEB ('MPCPOL O', X)
        CALL MPDEB (' ', X(LX+1))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCPR (A, B, IC)
C
C   This routine compares the MP numbers A and B and returns in IC the value
C   -1, 0, or 1 depending on whether A < B, A = B, or A > B.  It is faster
C   than merely subtracting A and B and looking at the sign of the result.
C   Debug output begins with IDB = 9.
C
      DIMENSION A(NW+4), B(NW+4)
      PARAMETER (NDB = 22)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        IC = 0
        RETURN
      ENDIF
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPCPR I'/(6F12.0))
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 1) (B(I), I = 1, NO)
      ENDIF
      IA = SIGN (1., A(1))
      IF (A(1) .EQ. 0.) IA = 0
      IB = SIGN (1., B(1))
      IF (B(1) .EQ. 0.) IB = 0
C
C   Compare signs.
C
      IF (IA .NE. IB) THEN
        IC = SIGN (1, IA - IB)
        GOTO 110
      ENDIF
C
C   The signs are the same.  Compare exponents.
C
      MA = A(2)
      MB = B(2)
      IF (MA .NE. MB) THEN
        IC = IA * SIGN (1, MA - MB)
        GOTO 110
      ENDIF
C
C   The signs and the exponents are the same.  Compare mantissas.
C
      NA = MIN (INT (ABS (A(1))), NW)
      NB = MIN (INT (ABS (B(1))), NW)
C
      DO 100 I = 3, MIN (NA, NB) + 2
        IF (A(I) .NE. B(I)) THEN
          IC = IA * SIGN (1., A(I) - B(I))
          GOTO 110
        ENDIF
 100  CONTINUE
C
C   The mantissas are the same to the common length.  Compare lengths.
C
      IF (NA .NE. NB) THEN
        IC = IA * SIGN (1, NA - NB)
        GOTO 110
      ENDIF
C
C   The signs, exponents, mantissas and lengths are the same.  Thus A = B.
C
      IC = 0
C
 110  IF (IDB .GE. 9) WRITE (6, 2) IC
 2    FORMAT ('MPCPR O',I4)
      RETURN
      END
C
      SUBROUTINE MPCPWR (L, A, N, B)
C
C   This computes the N-th power of the MPC number A and returns the MPC
C   result C in B.  When N is zero, 1 is returned.  When N is negative, the
C   reciprocal of A ^ |N| is returned.  L is the offset between real and
C   imaginary parts in A and B.  L should be at least NW + 4.  For extra high
C   levels of precision, use MPCPWX.  Debug output starts with IDB = 7.
C
C   Max SP space for B: 2 * L cells.  Max SP scratch space: 6 * NW + 30
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   This routine employs the binary method for exponentiation.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22)
      DIMENSION A(2*L), B(2*L), F1(8), F2(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 7) THEN
        WRITE (6, 1) L, N
 1      FORMAT ('MPCPWR I',2I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCPWR I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
      ENDIF
C
      NA1 = MIN (INT (ABS (A(1))), NW)
      NA2 = MIN (INT (ABS (A(L1))), NW)
      IF (NA1 .EQ. 0 .AND. NA2 .EQ. 0) THEN
        IF (N .GE. 0) THEN
          B(1) = 0.
          B(2) = 0.
          B(L1) = 0.
          B(L1+1) = 0.
          GOTO 120
        ELSE
          IF (KER(25) .NE. 0) THEN
            WRITE (LDB, 3)
 3          FORMAT ('*** MPCPWR: Argument is zero and N is negative or',
     $        ' zero.')
            IER = 25
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ENDIF
C
      N5 = NW + 5
      NS = 6 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + 2 * N5
      K2 = K1 + 2 * N5
      NWS = NW
      NW = NW + 1
      NN = ABS (N)
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      F2(1) = 0.
      F2(2) = 0.
      CALL MPMMPC (A, A(L1), N5, S(K0))
      IF (NN .EQ. 0) THEN
        CALL MPMMPC (F1, F2, L, B)
        NW = NWS
        ICS = ISS
        GOTO 120
      ELSEIF (NN .EQ. 1) THEN
        CALL MPCEQ (N5, S(K0), S(K2))
        GOTO 110
      ELSEIF (NN .EQ. 2) THEN
        CALL MPCMUL (N5, S(K0), S(K0), S(K2))
        GOTO 110
      ENDIF
C
C   Determine the least integer MN such that 2 ^ MN .GT. NN.
C
      T1 = NN
      MN = CL2 * LOG (T1) + 1.D0 + RXX
      CALL MPMMPC (F1, F2, N5, S(K2))
      KN = NN
C
C   Compute B ^ N using the binary rule for exponentiation.
C
      DO 100 J = 1, MN
        KK = KN / 2
        IF (KN .NE. 2 * KK) THEN
          CALL MPCMUL (N5, S(K2), S(K0), S(K1))
          CALL MPCEQ (N5, S(K1), S(K2))
        ENDIF
        KN = KK
        IF (J .LT. MN) THEN
          CALL MPCMUL (N5, S(K0), S(K0), S(K1))
          CALL MPCEQ (N5, S(K1), S(K0))
        ENDIF
 100  CONTINUE
C
C   Compute reciprocal if N is negative.
C
 110  IF (N .LT. 0) THEN
        CALL MPMMPC (F1, F2, N5, S(K1))
        CALL MPCDIV (N5, S(K1), S(K2), S(K0))
        CALL MPCEQ (N5, S(K0), S(K2))
      ENDIF
      CALL MPMMPC (S(K2), S(N5+K2), L, B)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (B)
      CALL MPROUN (B(L1))
C
 120  IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 4) (B(I), I = 1, NO)
 4      FORMAT ('MPCPWR O'/(6F12.0))
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 4) (B(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCPWX (L, A, N, B)
C
C   This computes the N-th power of the MPC number A and returns the MPC
C   result C in B.  When N is zero, 1 is returned.  When N is negative, the
C   reciprocal of A ^ |N| is returned.  L is the offset between real and
C   imaginary parts in A and B.  L should be at least NW + 4.  Before calling
C   MPCPWX, the array in MPCOM5 must be initialized by calling MPINIX.  For
C   modest levels of precision, use MPCPWR.  NW should be a power of two.
C   The last two words of the result are not reliable.  Debug output starts
C   with IDB = 6.
C
C   Max SP space for B: 2 * L cells.  Max SP scratch space: 8 * NW + 32
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine employs the binary method for exponentiation.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22)
      DIMENSION A(2*L), B(2*L), F1(8), F2(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 6) THEN
        WRITE (6, 1) L, N
 1      FORMAT ('MPCPWX I',2I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCPWX I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
      ENDIF
C
      NA1 = MIN (INT (ABS (A(1))), NW)
      NA2 = MIN (INT (ABS (A(L1))), NW)
      NCR = 2 ** MCR
C
C   Check if precision level of A is too low to justify advanced routine.
C
      IF (NA1 .LE. NCR .AND. NA2 .LE. NCR) THEN
        CALL MPCPWR (L, A, N, B)
        GOTO 120
      ENDIF
      IF (NA1 .EQ. 0 .AND. NA2 .EQ. 0) THEN
        IF (N .GE. 0) THEN
          B(1) = 0.
          B(2) = 0.
          B(L1) = 0.
          B(L1+1) = 0.
          GOTO 120
        ELSE
          IF (KER(26) .NE. 0) THEN
            WRITE (LDB, 3)
 3          FORMAT ('*** MPCPWX: Argument is zero and N is negative or',
     $        ' zero.')
            IER = 26
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ENDIF
C
      N4 = NW + 4
      NS = 6 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + 2 * N4
      K2 = K1 + 2 * N4
      NN = ABS (N)
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      F2(1) = 0.
      F2(2) = 0.
      CALL MPMMPC (A, A(L1), N4, S(K0))
      IF (NN .EQ. 0) THEN
        CALL MPMMPC (F1, F2, L, B)
        ICS = ISS
        GOTO 120
      ELSEIF (NN .EQ. 1) THEN
        CALL MPCEQ (N4, S(K0), S(K2))
        GOTO 110
      ELSEIF (NN .EQ. 2) THEN
        CALL MPCMLX (N4, S(K0), S(K0), S(K2))
        GOTO 110
      ENDIF
C
C   Determine the least integer MN such that 2 ^ MN .GT. NN.
C
      T1 = NN
      MN = CL2 * LOG (T1) + 1.D0 + RXX
      CALL MPMMPC (F1, F2, N4, S(K2))
      KN = NN
C
C   Compute B ^ N using the binary rule for exponentiation.
C
      DO 100 J = 1, MN
        KK = KN / 2
        IF (KN .NE. 2 * KK) THEN
          CALL MPCMLX (N4, S(K2), S(K0), S(K1))
          CALL MPCEQ (N4, S(K1), S(K2))
        ENDIF
        KN = KK
        IF (J .LT. MN) THEN
          CALL MPCMLX (N4, S(K0), S(K0), S(K1))
          CALL MPCEQ (N4, S(K1), S(K0))
        ENDIF
 100  CONTINUE
C
C   Compute reciprocal if N is negative.
C
 110  IF (N .LT. 0) THEN
        CALL MPMMPC (F1, F2, N4, S(K1))
        CALL MPCDVX (N4, S(K1), S(K2), S(K0))
        CALL MPCEQ (N4, S(K0), S(K2))
      ENDIF
      CALL MPMMPC (S(K2), S(N4+K2), L, B)
      ICS = ISS
C
 120  IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 4) (B(I), I = 1, NO)
 4      FORMAT ('MPCPWX O'/(6F12.0))
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 4) (B(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCRFT (IS, M, X, Y)
C
C   This performs an N-point complex-to-real FFT, where N = 2^M.  X and Y
C   are double precision arrays.  X is both the input and the output data
C   array, and Y is a scratch array.  N/2 + 1 complex pairs are input, with
C   real and imaginary parts separated by N/2 + 1 locations, and N real
C   values are output .  A call to MPCRFT with IS = 1 (or -1) indicates a call
C   to perform a complex-to-real FFT with positive (or negative) exponentials.
C   M must be at least three.  The arrays X and Y must be dimensioned with
C   N + 2 cells.  Before calling MPCRFT, the U array in MPCOM5 must be
C   initialized by calling MPINIX.
C
C   In this application, MPCRFT is called by MPMULX.  This routine is not
C   intended to be called directly by the user.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(*), Y(*)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM5/ U(1024)
C
C   Set initial parameters.
C
      K = U(1)
      MX = MOD (K, 64)
      NU = K / 64
      N = 2 ** M
      N2 = N / 2
      N21 = N2 + 1
      N4 = N / 4
      KU = N / 2
      KN = KU + NU
C
C   Check if input parameters are invalid.
C
      IF ((IS .NE. 1 .AND. IS .NE. -1) .OR. M .LT. 3 .OR. M .GT. MX)    
     $  THEN
        IF (KER(27) .NE. 0) THEN
          WRITE (LDB, 1)  IS, M, MX
 1        FORMAT ('*** MPCRFT: Either U has not been initialized'/      
     $      'or else one of the input parameters is invalid', 3I5)
          IER = 27
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Construct the input to MPCFFT.
C
      Y(1) = 0.5D0 * (X(1) + X(N21))
      Y(N2+1) = 0.5D0 * (X(1) - X(N21))
      Y(N4+1) = X(N4+1)
      Y(N4+N2+1) = -IS * X(N4+N2+2)
C
CDIR$ IVDEP
      DO 100 K = 2, N4
        X11 = X(K)
        X12 = X(K+N21)
        X21 = X(N2+2-K)
        X22 = X(N+3-K)
        A1 = X11 + X21
        A2 = X11 - X21
        B1 = X12 + X22
        B2 = X12 - X22
        U1 = U(K+KU)
        U2 = IS * U(K+KN)
        T1 = U1 * B1 + U2 * A2
        T2 = U1 * A2 - U2 * B1
        Y(K) = 0.5D0 * (A1 - T1)
        Y(K+N2) = 0.5D0 * (B2 + T2)
        Y(N2+2-K) = 0.5D0 * (A1 + T1)
        Y(N+2-K) = 0.5D0 * (-B2 + T2)
 100  CONTINUE
C
C   Perform a normal N/2-point FFT on Y.
C
      CALL MPCFFT (IS, M - 1, Y, X)
C
C   Copy Y to X such that Y(k) = X(2k-1) + i X(2k).
C
CDIR$ IVDEP
      DO 110 K = 1, N2
        X(2*K-1) = Y(K)
        X(2*K) = Y(K+N2)
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPCSHX (A, PI, AL2, X, Y)
C
C   This computes the hyperbolic cosine and sine of the MP number A and
C   returns the two MP results in X and Y, respectively.  PI is the MP value
C   of Pi computed by a previous call to MPPI or MPPIX.  AL2 is the MP value
C   of Log (10) computed by a previous call to MPLOG or MPLOGX.  Before
C   calling MPCSHX, the array in MPCOM5 must be initialized by calling MPINIX.
C   For modest levels of precision, use MPCSSH.  NW should be a power of two.
C   The last four words of the result are not reliable.  Debug output starts
C   with IDB = 5.
C
C   Max SP space for X and Y: NW + 4 cells.  Max SP scratch space:
C   28 * NW + 132 cells.  Max DP scratch space: 12 * NX + 6 cells.
C
      DIMENSION A(NW+2), F(8), AL2(NW+2), PI(NW+2), X(NW+4), Y(NW+4)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        Y(1) = 0.
        Y(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 5) CALL MPDEB ('MPCSHX I', A)
C
      N4 = NW + 4
      NS = 3 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
C
      CALL MPEXPX (A, PI, AL2, S(K0))
      CALL MPDIVX (F, S(K0), S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, X)
      CALL MPSUB (S(K0), S(K1), S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, Y)
      ICS = ISS
C
      IF (IDB .GE. 5) THEN
        CALL MPDEB ('MPCSHX O', X)
        CALL MPDEB ('MPCSHX O', Y)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCSQR (L, A, B)
C
C   This routine computes the complex square root of the MPC number C.  L is
C   the offset between real and imaginary parts in A and B.  L must be at
C   least NW + 4.  For extra high levels of precision, use MPCSQX.  The last
C   word is not reliable.  Debug output starts with IDB = 6.
C
C   Max SP space for B: 2 * L cells.  Max SP scratch space: 5 * NW + 22
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   This routine uses the following formula, where A1 and A2 are the real and
C   imaginary parts of A, and where R = Sqrt [A1 ^ 2 + A2 ^2]:
C
C      B = Sqrt [(R + A1) / 2] + I Sqrt [(R - A1) / 2]
C
C   If the imaginary part of A is < 0, then the imaginary part of B is also
C   set to be < 0.
C
      PARAMETER (NDB = 22)
      DIMENSION A(2*L), B(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 1) L
 1      FORMAT ('MPCSQR I',I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCSQR I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
      ENDIF
C
      IF (A(1) .EQ. 0. .AND. A(L+1) .EQ. 0.) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        GOTO 100
      ENDIF
C
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IF (ICS - 1 .GT. IMS) CALL MPALER
      IHS = MAX (ICS, IHS)
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
C
      CALL MPMUL (A, A, S(K0))
      CALL MPMUL (A(L1), A(L1), S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPSQRT (S(K2), S(K0))
      CALL MPEQ (A, S(K1))
      S(K1) = ABS (S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, S(K1))
      CALL MPSQRT (S(K1), S(K0))
      CALL MPMULD (S(K0), 2.D0, 0, S(K1))
      IF (A(1) .GE. 0.) THEN
        CALL MPEQ (S(K0), B)
        CALL MPDIV (A(L1), S(K1), B(L1))
      ELSE
        CALL MPDIV (A(L1), S(K1), B)
        B(1) = ABS (B(1))
        CALL MPEQ (S(K0), B(L1))
        B(L1) = SIGN (B(L1), A(L1))
      ENDIF
      ICS = ISS
C
 100  IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPCSQR O'/(6F12.0))
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 3) (B(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCSQX (L, A, B)
C
C   This routine computes the complex square root of the MPC number C.  L is
C   the offset between real and imaginary parts in A and B.  L must be at
C   least NW + 4.  For modest levels of precision, use MPCSQR.  The last two
C   words are not reliable.  Debug output starts with IDB = 5.
C
C   Max SP space for B: 2 * L cells.  Max SP scratch space: 6 * NW + 30.
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine uses the same algorithm as MPCSQR.
C
      PARAMETER (NDB = 22)
      DIMENSION A(2*L), B(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        RETURN
      ENDIF
      L1 = L + 1
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 1) L
 1      FORMAT ('MPCSQX I',I10)
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPCSQX I'/(6F12.0))
        NO = MIN (INT (ABS (A(L1))), NDB) + 2
        WRITE (LDB, 2) (A(L+I), I = 1, NO)
      ENDIF
C
      IF (A(1) .EQ. 0. .AND. A(L+1) .EQ. 0.) THEN
        B(1) = 0.
        B(2) = 0.
        B(L+1) = 0.
        B(L+2) = 0.
        GOTO 100
      ENDIF
C
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IF (ICS - 1 .GT. IMS) CALL MPALER
      IHS = MAX (ICS, IHS)
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
C
      CALL MPMULX (A, A, S(K0))
      CALL MPMULX (A(L1), A(L1), S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPSQRX (S(K2), S(K0))
      CALL MPEQ (A, S(K1))
      S(K1) = ABS (S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, S(K1))
      CALL MPSQRX (S(K1), S(K0))
      CALL MPMULD (S(K0), 2.D0, 0, S(K1))
      IF (A(1) .GE. 0.) THEN
        CALL MPEQ (S(K0), B)
        CALL MPDIVX (A(L1), S(K1), B(L1))
      ELSE
        CALL MPDIVX (A(L1), S(K1), B)
        B(1) = ABS (B(1))
        CALL MPEQ (S(K0), B(L1))
        B(L1) = SIGN (B(L1), A(L1))
      ENDIF
      ICS = ISS
C
 100  IF (IDB .GE. 5) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPCSQX O'/(6F12.0))
        NO = MIN (INT (ABS (B(L1))), NDB) + 2
        WRITE (LDB, 3) (B(L+I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCSSH (A, AL2, X, Y)
C
C   This computes the hyperbolic cosine and sine of the MP number A and
C   returns the two MP results in X and Y, respectively.  AL2 is the MP value
C   of Log (10) computed by a previous call to MPLOG.  For extra high levels of
C   precision, use MPCSHX.  The last word of the result is not reliable.
C   Debug output starts with IDB = 5.
C
C   Max SP space for X and Y: NW + 4 cells.  Max SP scratch space: 9 * NW + 50
C   cells.  Max DP scratch space: NW + 6 cells.
C
      DIMENSION A(NW+2), F(8), AL2(NW+2), X(NW+4), Y(NW+4)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        Y(1) = 0.
        Y(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 5) CALL MPDEB ('MPCSSH I', A)
C
      N5 = NW + 5
      NS = 4 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      NWS = NW
      NW = NW + 1
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
C
      CALL MPEXP (A, AL2, S(K0))
      CALL MPDIV (F, S(K0), S(K1))
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, S(K3))
      CALL MPEQ (S(K3), X)
      CALL MPSUB (S(K0), S(K1), S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, S(K3))
      CALL MPEQ (S(K3), Y)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (X)
      CALL MPROUN (Y)
C
      IF (IDB .GE. 5) THEN
        CALL MPDEB ('MPCSSH O', X)
        CALL MPDEB ('MPCSSH O', Y)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCSSN (A, PI, X, Y)
C
C   This computes the cosine and sine of the MP number A and returns the two MP
C   results in X and Y, respectively.  PI is the MP value of Pi computed by a
C   previous call to MPPI.  For extra high levels of precision, use MPCSSX.
C   The last word of the result is not reliable.  Debug output starts with
C   IDB = 6.
C
C   Max SP space for X and Y: NW + 4 cells.  Max SP scratch space: 9 * NW + 47
C   cells.  Max DP scratch space: NW + 6 cells.
C
C   This routine uses the conventional Taylor's series for Sin (s):
C
C   Sin (s) =  s - s^3 / 3! + s^5 / 5! - s^7 / 7! ...
C
C   where s = t - a * pi / 2 - b * pi / 16 and the integers a and b are chosen
C   to minimize the absolute value of s.  We can then compute
C
C   Sin (t) = Sin (s + a * pi / 2 + b * pi / 16)
C   Cos (t) = Cos (s + a * pi / 2 + b * pi / 16)
C
C   by applying elementary trig identities for sums.  The sine and cosine of
C   b * pi / 16 are of the form 1/2 * Sqrt {2 +- Sqrt [2 +- Sqrt(2)]}.
C   Reducing t in this manner insures that -Pi / 32 < s <= Pi / 32, which
C   accelerates convergence in the above series.
C
      DOUBLE PRECISION CPI, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CPI = 3.141592653589793D0)
      DIMENSION A(NW+2), F(8), PI(NW+2), X(NW+4), Y(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        Y(1) = 0.
        Y(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) CALL MPDEB ('MPCSSN I', A)
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      IF (NA .EQ. 0) THEN
        X(1) = 1.
        X(2) = 0.
        X(3) = 1.
        Y(1) = 0.
        Y(2) = 0.
        L1 = 0
        GOTO 120
      ENDIF
C
C   Check if Pi has been precomputed.
C
      CALL MPMDC (PI, T1, N1)
      IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN
        IF (KER(28) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPCSSN: PI must be precomputed.')
          IER = 28
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N5 = NW + 5
      NS = 7 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      K4 = K3 + N5
      K5 = K4 + N5
      K6 = K5 + N5
      NWS = NW
      NW = NW + 1
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
C
C   Reduce to between - Pi and Pi.
C
      CALL MPMULD (PI, 2.D0, 0, S(K0))
      CALL MPDIV (A, S(K0), S(K1))
      CALL MPNINT (S(K1), S(K2))
      CALL MPSUB (S(K1), S(K2), S(K3))
C
C   Determine nearest multiple of Pi / 2, and within a quadrant, the nearest
C   multiple of Pi / 16.  Through most of the rest of this subroutine, KA and
C   KB are the integers a and b of the algorithm above.
C
      CALL MPMDC (S(K3), T1, N1)
      IF (N1 .GE. -24) THEN
        T1 = T1 * 2.D0 ** N1
        T2 = 4.D0 * T1
        KA = NINT (T2)
        KB = NINT (8.D0 * (T2 - KA))
      ELSE
        KA = 0
        KB = 0
      ENDIF
      T1 = (8 * KA + KB) / 32.D0
      CALL MPDMC (T1, 0, S(K1))
      CALL MPSUB (S(K3), S(K1), S(K2))
      CALL MPMUL (S(K0), S(K2), S(K1))
C
C   Compute cosine and sine of the reduced argument s using Taylor's series.
C
      IF (S(K1) .EQ. 0.) THEN
        S(K0) = 0.
        S(K0+1) = 0.
        L1 = 0
        GOTO 110
      ENDIF
      CALL MPEQ (S(K1), S(K0))
      CALL MPMUL (S(K0), S(K0), S(K2))
      L1 = 0
C
 100  L1 = L1 + 1
      IF (L1 .EQ. 10000) THEN
        IF (KER(29) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPCSSN: Iteration limit exceeded.')
          IER = 29
          IF (KER(IER) .EQ. 2) CALL MPABRT
          ICS = ISS
          NW = NWS
          RETURN
        ENDIF
      ENDIF
C
      T2 = - (2.D0 * L1) * (2.D0 * L1 + 1.D0)
      CALL MPMUL (S(K2), S(K1), S(K3))
      CALL MPDIVD (S(K3), T2, 0, S(K1))
      CALL MPADD (S(K1), S(K0), S(K3))
      CALL MPEQ (S(K3), S(K0))
C
C   Check for convergence of the series.
C
      IF (S(K1) .NE. 0. .AND. S(K1+1) .GE. S(K0+1) - NW) GOTO 100
C
C   Compute Cos (s) = Sqrt [1 - Sin^2 (s)].
C
 110  CALL MPEQ (S(K0), S(K1))
      CALL MPMUL (S(K0), S(K0), S(K2))
      CALL MPSUB (F, S(K2), S(K3))
      CALL MPSQRT (S(K3), S(K0))
C
C   Compute cosine and sine of b * Pi / 16.
C
      KC = ABS (KB)
      F(3) = 2.
      IF (KC .EQ. 0) THEN
        S(K2) = 1.
        S(K2+1) = 0.
        S(K2+2) = 1.
        S(K3) = 0.
        S(K3+1) = 0.
      ELSE
        IF (KC .EQ. 1) THEN
          CALL MPSQRT (F, S(K4))
          CALL MPADD (F, S(K4), S(K5))
          CALL MPSQRT (S(K5), S(K4))
        ELSEIF (KC .EQ. 2) THEN
          CALL MPSQRT (F, S(K4))
        ELSEIF (KC .EQ. 3) THEN
          CALL MPSQRT (F, S(K4))
          CALL MPSUB (F, S(K4), S(K5))
          CALL MPSQRT (S(K5), S(K4))
        ELSEIF (KC .EQ. 4) THEN
          S(K4) = 0.
          S(K4+1) = 0.
        ENDIF
        CALL MPADD (F, S(K4), S(K5))
        CALL MPSQRT (S(K5), S(K3))
        CALL MPMULD (S(K3), 0.5D0, 0, S(K2))
        CALL MPSUB (F, S(K4), S(K5))
        CALL MPSQRT (S(K5), S(K4))
        CALL MPMULD (S(K4), 0.5D0, 0, S(K3))
      ENDIF
      IF (KB .LT. 0) S(K3) = - S(K3)
C
C   Apply the trigonometric summation identities to compute cosine and sine of
C   s + b * Pi / 16.
C
      CALL MPMUL (S(K0), S(K2), S(K4))
      CALL MPMUL (S(K1), S(K3), S(K5))
      CALL MPSUB (S(K4), S(K5), S(K6))
      CALL MPMUL (S(K1), S(K2), S(K4))
      CALL MPMUL (S(K0), S(K3), S(K5))
      CALL MPADD (S(K4), S(K5), S(K1))
      CALL MPEQ (S(K6), S(K0))
C
C   This code in effect applies the trigonometric summation identities for
C   (s + b * Pi / 16) + a * Pi / 2.
C
      IF (KA .EQ. 0) THEN
        CALL MPEQ (S(K0), X)
        CALL MPEQ (S(K1), Y)
      ELSEIF (KA .EQ. 1) THEN
        CALL MPEQ (S(K1), X)
        X(1) = - X(1)
        CALL MPEQ (S(K0), Y)
      ELSEIF (KA .EQ. -1) THEN
        CALL MPEQ (S(K1), X)
        CALL MPEQ (S(K0), Y)
        Y(1) = - Y(1)
      ELSEIF (KA .EQ. 2 .OR. KA .EQ. -2) THEN
        CALL MPEQ (S(K0), X)
        X(1) = - X(1)
        CALL MPEQ (S(K1), Y)
        Y(1) = - Y(1)
      ENDIF
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (X)
      CALL MPROUN (Y)
C
 120  IF (IDB .GE. 6) THEN
        WRITE (LDB, 3) L1
 3      FORMAT ('Iteration count:',I5)
        CALL MPDEB ('MPCSSN O', X)
        CALL MPDEB ('MPCSSN O', Y)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCSSX (A, PI, X, Y)
C
C   This computes the cosine and sine of the MP number A and returns the two MP
C   results in X and Y, respectively.  PI is the MP value of Pi computed by a
C   previous call to MPPI or MPPIX.  Before calling MPCSSX, the array in
C   MPCOM5 must be initialized by calling MPINIX.  For modest levels of
C   precision, use MPCSSN.  NW should be a power of two.  The last four words
C   of the result are not reliable.  Debug output starts with IDB = 5.
C
C   Max SP space for X and Y: NW + 4 cells.  Max SP scratch space: 26*NW + 110
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine employs a complex arithmetic version of the scheme used in
C   MPEXPX.
C
      DOUBLE PRECISION CL2, CPI, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, CPI = 3.141592653589793D0, 
     $  NIT = 1)
      DIMENSION A(NW+2), F1(8), PI(NW+2), X(NW+4), Y(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        Y(1) = 0.
        Y(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 5) CALL MPDEB ('MPCSSX I', A)
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NCR = 2 ** MCR
C
C   Check if precision level is too low to justify advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPCSSN (A, PI, X, Y)
        L1 = 0
        GOTO 120
      ENDIF
C
C   Check if input is zero.
C
      IF (NA .EQ. 0) THEN
        X(1) = 1.
        X(2) = 0.
        X(3) = 1.
        Y(1) = 0.
        Y(2) = 0.
        L1 = 0
        GOTO 120
      ENDIF
C
C   Check if Pi has been precomputed.
C
      CALL MPMDC (PI, T1, N1)
      IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN
        IF (KER(30) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPCSSX: PI must be precomputed.')
          IER = 30
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      N42 = 2 * N4
      NS = 4 * N42
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N42
      K2 = K1 + N42
      K3 = K2 + N42
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      NWS = NW
C
C   Reduce argument to between - Pi and Pi.
C
      CALL MPMULD (PI, 2.D0, 0, S(K0))
      CALL MPDIVX (A, S(K0), S(K1))
      CALL MPNINT (S(K1), S(K2))
      CALL MPMUL (S(K2), S(K0), S(K1))
      CALL MPSUB (A, S(K1), S(K0))
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T2 = NWS
      MQ = CL2 * LOG (T2) + 1.D0 - RXX
      CALL MPEQ (F1, S(K2))
C
C   Compute initial approximation to [Cos (A), Sin (A)].
C
      NW = NCR
      CALL MPCSSN (S(K0), PI, S(K3), S(K3+N4))
      IQ = 0
C
C   Perform the Newton-Raphson iteration with a dynamically changing precision
C   level NW.
C
      DO 110 K = MCR + 1, MQ
        NW = MIN (2 * NW, NWS)
 100    CONTINUE
        CALL MPANGX (S(K3), S(K3+N4), PI, S(K1))
        CALL MPSUB (S(K0), S(K1), S(K2+N4))
        CALL MPCMLX (N4, S(K3), S(K2), S(K1))
        CALL MPCEQ (N4, S(K1), S(K3))
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   The final (cos, sin) result must be normalized to have magnitude 1.
C
      CALL MPMULX (S(K3), S(K3), S(K0))
      CALL MPMULX (S(K3+N4), S(K3+N4), S(K0+N4))
      CALL MPADD (S(K0), S(K0+N4), S(K1))
      CALL MPSQRX (S(K1), S(K2))
      CALL MPDIVX (S(K3), S(K2), S(K0))
      CALL MPDIVX (S(K3+N4), S(K2), S(K0+N4))
      CALL MPMPCM (N4, S(K0), X, Y)
      ICS = ISS
C
 120  IF (IDB .GE. 5) THEN
        CALL MPDEB ('MPCSSX O', X)
        CALL MPDEB ('MPCSSX O', Y)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPCSUB (L, A, B, C)
C
C   This subracts the MPC numbers A and B and returns the MPC difference in
C   C.  L is the offset between real and imaginary parts in A, B and C.  L
C   must be at least NW + 4.  Debug output starts with IDB = 9.
C
C   Max SP space for C: 2 * L cells.
C
      DIMENSION A(2*L), B(2*L), C(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) WRITE (LDB, 1)
 1    FORMAT ('MPCSUB')
C
      L1 = L + 1
      CALL MPSUB (A, B, C)
      CALL MPSUB (A(L1), B(L1), C(L1))
C
      RETURN
      END
C
      SUBROUTINE MPDEB (CS, A)
C
C   This outputs the character string CS, the exponent of the MP number A, and
C   the first 50 digits of A, all on one line.  CS must either be a literal
C   string not exceeding 12 characters in length or a variable of type
C   CHARACTER*n, where n does not exceed 12.
C
      CHARACTER*(*) CS
      CHARACTER*1 B(160)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      DIMENSION A(NW+2)
C
      IF (IER .NE. 0) RETURN
      IDS = IDB
      IDB = 0
      NWS = NW
      NW = MIN (NW, 10)
      CALL MPOUTC (A, B, N)
      N = MIN (N, 70)
      WRITE (LDB, 1) CS, ' ', (B(K), K = 1, 4), (B(K), K = 9, N)
 1    FORMAT (A12,67A1:/(79A1))
      IDB = IDS
      NW = NWS
      RETURN
      END
C
      SUBROUTINE MPDIV (A, B, C)
C
C   This divides the MP number A by the MP number B to yield the MP quotient C.
C   For extra high levels of precision, use MPDIVX.  Debug output starts with
C   IDB = 8.
C
C   Max SP space for C: NW + 4 cells.  Max DP scratch space: NW + 4 cells.
C
      DOUBLE PRECISION D, RB, SS, T1, T2, T3
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM4/ D(1024)
      DIMENSION A(NW+2), B(NW+2), C(NW+4)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPDIV I'/(6F12.0))
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 1) (B(I), I = 1, NO)
      ENDIF
C
      IA = SIGN (1., A(1))
      IB = SIGN (1., B(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NB = MIN (INT (ABS (B(1))), NW)
C
C   Check if dividend is zero.
C
      IF (NA .EQ. 0) THEN
        C(1) = 0.
        C(2) = 0.
        GOTO 190
      ENDIF
      IF (NB .EQ. 1 .AND. B(3) .EQ. 1.) THEN
C
C   Divisor is 1 or -1 -- result is A or -A.
C
        C(1) = SIGN (NA, IA * IB)
        C(2) = A(2) - B(2)
C
        DO 100 I = 3, NA + 2
          C(I) = A(I)
 100    CONTINUE
C
        GOTO 190
      ENDIF
C
C   Check if divisor is zero.
C
      IF (NB .EQ. 0) THEN
        IF (KER(31) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPDIV: Divisor is zero.')
          IER = 31
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Initialize trial divisor and trial dividend.
C
      T1 = BDX * B(3)
      IF (NB .GE. 2) T1 = T1 + B(4)
      IF (NB .GE. 3) T1 = T1 + RDX * B(5)
      IF (NB .GE. 4) T1 = T1 + RX2 * B(6)
      RB = 1.D0 / T1
      MD = MIN (NA + NB, NW)
      D(1) = 0.D0
C
      DO 110 I = 2, NA + 1
        D(I) = A(I+1)
 110  CONTINUE
C
      DO 120 I = NA + 2, MD + 4
        D(I) = 0.D0
 120  CONTINUE
C
C   Perform ordinary long division algorithm.  First compute only the first
C   NA words of the quotient.
C>
      DO 140 J = 2, NA + 1
        T1 = INT (RB * (BX2 * D(J-1) + BDX * D(J) + D(J+1)))
        J3 = J - 3
        I2 = MIN (NB, NW + 2 - J3) + 2
C>
CDIR$ IVDEP
        DO 130 I = 3, I2
          I3 = I + J3
          T2 = D(I3) - T1 * B(I)
          T3 = INT (T2 * RDX)
          D(I3) = T2 - T3 * BDX
          D(I3-1) = D(I3-1) + T3
 130    CONTINUE
C
C   If the trial divisor was correct, D(J-1) will be zero.  If D(J-1) is not
C   zero, add it (multiplied by the radix) into D(J).
C
        D(J) = D(J) + BDX * D(J-1)
        D(J-1) = T1
 140  CONTINUE
C
C   Compute additional words of the quotient, as long as the remainder
C   is nonzero.
C>
      DO 160 J = NA + 2, NW + 3
        T1 = INT (RB * (BX2 * D(J-1) + BDX * D(J) + D(J+1)))
        J3 = J - 3
        I2 = MIN (NB, NW + 2 - J3) + 2
        IJ = I2 + J3
        SS = 0.D0
C>
CDIR$ IVDEP
        DO 150 I = 3, I2
          I3 = I + J3
          T2 = D(I3) - T1 * B(I)
          T3 = INT (T2 * RDX)
          D(I3) = T2 - T3 * BDX
          D(I3-1) = D(I3-1) + T3
          SS = SS + ABS (D(I3-1))
 150    CONTINUE
C
        SS = SS + ABS (D(IJ))
        D(J) = D(J) + BDX * D(J-1)
        D(J-1) = T1
        IF (SS .EQ. 0.D0) GOTO 170
        IF (IJ .LE. NW + 2) D(IJ+2) = 0.D0
 160  CONTINUE
C
C   Set sign and exponent, and fix up result.
C
      J = NW + 3
C
 170  D(J) = 0.D0
      IF (D(1) .EQ. 0.D0) THEN
        IS = 1
      ELSE
        IS = 2
      ENDIF
      NC = MIN (J - 1, NW)
      D(NC+3) = 0.D0
      D(NC+4) = 0.D0
C
      DO 180 I = J + 1, 3, -1
        D(I) = D(I-IS)
 180  CONTINUE
C
      D(1) = SIGN (NC, IA * IB)
      D(2) = A(2) - B(2) + IS - 2
      CALL MPNORM (C)
C
 190  IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 3) (C(I), I = 1, NO)
 3      FORMAT ('MPDIV O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPDIVD (A, B, N, C)
C
C   This routine divides the MP number A by the DPE number (B, N) to yield
C   the MP quotient C.   Debug output starts with IDB = 9.
C
C   Max SP space for C: NW + 4 cells.  Max DP space: NW + 4 cells.
C
      DOUBLE PRECISION B, BB, BR, D, DD, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
      COMMON /MPCOM4/ D(1024)
      DIMENSION A(NW+2), C(NW+4), F(8)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPDIVD I'/(6F12.0))
        WRITE (LDB, 2) B, N
 2      FORMAT ('MPDIVD I',1PD25.15,I10)
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      IB = SIGN (1.D0, B)
C
C   Check if dividend is zero.
C
      IF (NA .EQ. 0) THEN
        C(1) = 0.
        C(2) = 0.
        GOTO 150
      ENDIF
C
C   Check if divisor is zero.
C
      IF (B .EQ. 0.D0) THEN
        IF (KER(32) .NE. 0) THEN
          WRITE (LDB, 3)
 3        FORMAT ('*** MPDIVD: Divisor is zero.')
          IER = 32
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
      N1 = N / NBT
      N2 = N - NBT * N1
      BB = ABS (B) * 2.D0 ** N2
C
C   Reduce BB to within 1 and BDX.
C
      IF (BB .GE. BDX) THEN
C
        DO 100 K = 1, 100
          BB = RDX * BB
          IF (BB .LT. BDX) THEN
            N1 = N1 + K
            GOTO 120
          ENDIF
 100    CONTINUE
C
      ELSEIF (BB .LT. 1.D0) THEN
C
        DO 110 K = 1, 100
          BB = BDX * BB
          IF (BB .GE. 1.D0) THEN
            N1 = N1 - K
            GOTO 120
          ENDIF
 110    CONTINUE
C
      ENDIF
C
C   If B cannot be represented exactly in a single mantissa word, use MPDIV.
C
 120  IF (BB .NE. AINT (BB)) THEN
        BB = SIGN (BB, B)
        CALL MPDMC (BB, N1 * NBT, F)
        CALL MPDIV (A, F, C)
        GOTO 150
      ENDIF
C
      BR = 1.D0 / BB
      DD = A(3)
C
C   Perform short division (not vectorizable at present).  Continue as long as
C   the remainder remains nonzero.
C>
      DO 130 J = 2, NW + 3
        T1 = INT (BR * DD)
        D(J+1) = T1
        DD = BDX * (DD - T1 * BB)
        IF (J .LE. NA) THEN
          DD = DD + A(J+2)
        ELSE
          IF (DD .EQ. 0.D0) GOTO 140
        ENDIF
 130  CONTINUE
C
C   Set sign and exponent of result.
C
      J = NW + 3
C
 140  NC = MIN (J - 1, NW)
      D(1) = SIGN (NC, IA * IB)
      D(2) = A(2) - N1
      IF (J .LE. NW + 2) D(J+2) = 0.D0
      IF (J .LE. NW + 1) D(J+3) = 0.D0
      CALL MPNORM (C)
C
 150  IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 4) (C(I), I = 1, NO)
 4      FORMAT ('MPDIVD O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPDIVX (A, B, C)
C
C   This divides the MP number A by the MP number B and returns the MP result
C   in C.  Before calling MPDIVX, the array in MPCOM5 must be initialized by
C   calling MPINIX.  For modest levels of precision, use MPDIV.  NW should be
C   a power of two.  The last two words of the result are not reliable.  Debug
C   output starts with IDB = 7.
C
C   Max SP space for C: NW + 4 cells.  Max SP scratch space: 2 * NW + 8
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This subroutine employs the following Newton-Raphson iteration, which
C   converges to 1 / B:
C
C          X_{k+1} = X_k + X_k * (1 - B * X_k)
C
C   Multiplying the final approximation to 1 / B by A gives the quotient.
C   These iterations are performed with a maximum precision level NW that
C   is dynamically changed, doubling with each iteration.
C
C   One difficulty with this procedure is that errors often accumulate in the
C   trailing mantissa words.  This error can be controlled by repeating one of
C   the iterations.  The iteration that is repeated is controlled by setting
C   the parameter NIT below:  If NIT = 0, the last iteration is repeated (this
C   is most effective but most expensive).  If NIT = 1, then the next-to-last
C   iteration is repeated, etc.  An extra word of precision cannot be used in
C   this routine (since MPMULX prefers powers of two), so NIT = 0 or 1 is best
C   unless the user needs maximum speed.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1)
      DIMENSION A(NW+2), B(NW+2), C(NW+4), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPDIVX I'/(6F12.0))
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 1) (B(I), I = 1, NO)
      ENDIF
C
      IA = SIGN (1., A(1))
      IB = SIGN (1., B(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NB = MIN (INT (ABS (B(1))), NW)
      NCR = 2 ** MCR
C
C   Check if dividend is zero.
C
      IF (NA .EQ. 0) THEN
        C(1) = 0.
        C(2) = 0.
        GOTO 120
      ENDIF
C
C   Check if divisor is zero.
C
      IF (NB .EQ. 0)  THEN
        IF (KER(33) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPDIVX: Divisor is zero.')
          IER = 33
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if precision level of divisor is too low to justify the advanced
C   routine.
C
      IF (NB .LE. NCR) THEN
        CALL MPDIV (A, B, C)
        GOTO 120
      ENDIF
      N4 = NW + 4
      NS = 2 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      NWS = NW
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Compute the initial approximation of 1 / B to a precision of NCR words.
C
      NW = NCR
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
      CALL MPDIV (F, B, C)
      IQ = 0
C
C   Perform the Newton-Raphson iterations described above.
C
      DO 110 K = MCR + 1, MQ
        AN = NW
        NW = MIN (2 * NW, NWS)
 100    CONTINUE
        CALL MPMULX (B, C, S(K0))
        CALL MPSUB (F, S(K0), S(K1))
        S(K1) = SIGN (MIN (ABS (S(K1)), AN), S(K1))
        CALL MPMULX (C, S(K1), S(K0))
        CALL MPADD (C, S(K0), S(K1))
        CALL MPEQ (S(K1), C)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Multiply by A to give final result.
C
      CALL MPMULX (A, C, S(K1))
      CALL MPEQ (S(K1), C)
      ICS = ISS
C
 120  IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 3) (C(I), I = 1, NO)
 3      FORMAT ('MPDIVX O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPDMC (A, N, B)
C
C   This routine converts the DPE number (A, N) to MP form in B.  All bits of
C   A are recovered in B.  However, note for example that if A = 0.1D0 and N
C   is 0, then B will NOT be the multiprecision equivalent of 1/10.  Debug
C   output starts with IDB = 9.
C
C   Max SP space for B:  8 cells.
C
      DOUBLE PRECISION A, AA
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      DIMENSION B(NW+4)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) WRITE (LDB, 1) A, N
 1    FORMAT ('MPDMC I',1PD25.15,I10)
C
C   Check for zero.
C
      IF (A .EQ. 0.D0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 150
      ENDIF
      N1 = N / NBT
      N2 = N - NBT * N1
      AA = ABS (A) * 2.D0 ** N2
C
C   Reduce AA to within 1 and BDX.
C
      IF (AA .GE. BDX) THEN
C
        DO 100 K = 1, 100
          AA = RDX * AA
          IF (AA .LT. BDX) THEN
            N1 = N1 + K
            GOTO 120
          ENDIF
 100    CONTINUE
C
      ELSEIF (AA .LT. 1.D0) THEN
C
        DO 110 K = 1, 100
          AA = BDX * AA
          IF (AA .GE. 1.D0) THEN
            N1 = N1 - K
            GOTO 120
          ENDIF
 110    CONTINUE
C
      ENDIF
C
C   Store successive sections of AA into B.
C
 120  B(2) = N1
      B(3) = AINT (AA)
      AA = BDX * (AA - B(3))
      B(4) = AINT (AA)
      AA = BDX * (AA - B(4))
      B(5) = AINT (AA)
      AA = BDX * (AA - B(5))
      B(6) = AINT (AA)
      B(7) = 0.
      B(8) = 0.
C
      DO 130 I = 6, 3, -1
        IF (B(I) .NE. 0.) GOTO 140
 130  CONTINUE
C
 140  AA = I - 2
      B(1) = SIGN (AA, A)
C
 150  IF (IDB .GE. 9) THEN
        NO = ABS (B(1)) + 2.
        WRITE (LDB, 2) (B(I), I = 1, NO)
 2      FORMAT ('MPDMC O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPEQ (A, B)
C
C   This routine sets the MP number B equal to the MP number A.  Debug output
C   starts with IDB = 10.
C
C   Max SP space for B: NW + 2 cells.
C
C   The fact that only NW + 2 cells, and not NW + 4 cells, are copied is
C   important in some routines that increase the precision level by one.
C
      PARAMETER (NDB = 22)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      DIMENSION A(NW+2), B(NW+2)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 10) WRITE (LDB, 1)
 1    FORMAT ('MPEQ')
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      B(1) = SIGN (NA, IA)
C
      DO 100 I = 2, NA + 2
        B(I) = A(I)
 100  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPEXP (A, AL2, B)
C
C   This computes the exponential function of the MP number A and returns the
C   MP result in B.  AL2 is the MP value of Log(2) produced by a prior call
C   to MPLOG.  For extra high levels of precision, use MPEXPX.  The last
C   word of the result is not reliable.  Debug output starts with IDB = 7.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 5 * NW + 25
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   This routine uses a modification of the Taylor's series for Exp (t):
C
C   Exp (t) =  (1 + r + r^2 / 2! + r^3 / 3! + r^4 / 4! ...) ^ q * 2 ^ n
C
C   where q = 256, r = t' / q, t' = t - n Log(2) and where n is chosen so
C   that -0.5 Log(2) < t' <= 0.5 Log(2).  Reducing t mod Log(2) and
C   dividing by 256 insures that -0.001 < r <= 0.001, which accelerates
C   convergence in the above series.
C
      DOUBLE PRECISION ALT, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (ALT = 0.693147180559945309D0, NQ = 8)
      DIMENSION A(NW+2), B(NW+5), AL2(NW+2), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) CALL MPDEB ('MPEXP I', A)
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      CALL MPMDC (A, T1, N1)
      T1 = T1 * 2.D0 ** N1
C
C   Unless the argument is near Log (2), Log(2) must be precomputed.  This
C   exception is necessary because MPLOG calls MPEXP to initialize Log (2).
C
      IF (ABS (T1 - ALT) .GT. RDX) THEN
        CALL MPMDC (AL2, T2, N2)
        IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2)  
     $    THEN
          IF (KER(34) .NE. 0) THEN
            WRITE (LDB, 1)
 1          FORMAT ('*** MPEXP: LOG (2) must be precomputed.')
            IER = 34
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ENDIF
C
C   Check for overflows and underflows.
C
      IF (T1 .GE. 1D9) THEN
        IF (T1 .GT. 0.D0) THEN
          IF (KER(35) .NE. 0) THEN
            WRITE (LDB, 2) T1, N1
 2          FORMAT ('*** MPEXP: Argument is too large',F12.6,' x 10 ^', 
     $        I8)
            IER = 35
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ELSE
          B(1) = 0.
          B(2) = 0.
          L1 = 0
          GOTO 130
        ENDIF
      ENDIF
C
      N5 = NW + 5
      NS = 4 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      NWS = NW
      NW = NW + 1
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
C
C   Compute the reduced argument A' = A - Log(2) * Nint [A / Log(2)].  Save
C   NZ = Nint [A / Log(2)] for correcting the exponent of the final result.
C
      IF (ABS (T1 - ALT) .GT. RDX) THEN
        CALL MPDIV (A, AL2, S(K0))
        CALL MPNINT (S(K0), S(K1))
        CALL MPMDC (S(K1), T1, N1)
        NZ = T1 * 2.D0 ** N1 + SIGN (RXX, T1)
        CALL MPMUL (AL2, S(K1), S(K2))
        CALL MPSUB (A, S(K2), S(K0))
      ELSE
        CALL MPEQ (A, S(K0))
        NZ = 0
      ENDIF
      TL = S(K0+1) - NW
C
C   Check if the reduced argument is zero.
C
      IF (S(K0) .EQ. 0.D0) THEN
        S(K0) = 1.
        S(K0+1) = 0.
        S(K0+2) = 1.
        L1 = 0
        GOTO 120
      ENDIF
C
C   Divide the reduced argument by 2 ^ NQ.
C
      CALL MPDIVD (S(K0), 1.D0, NQ, S(K1))
C
C   Compute Exp using the usual Taylor series.
C
      CALL MPEQ (F, S(K2))
      CALL MPEQ (F, S(K3))
      L1 = 0
C
 100  L1 = L1 + 1
      IF (L1 .EQ. 10000) THEN
        IF (KER(36) .NE. 0) THEN
          WRITE (LDB, 3)
 3        FORMAT ('*** MPEXP: Iteration limit exceeded.')
          IER = 36
          IF (KER(IER) .EQ. 2) CALL MPABRT
          NW = NWS
          ICS = ISS
          RETURN
        ENDIF
      ENDIF
C
      T2 = L1
      CALL MPMUL (S(K2), S(K1), S(K0))
      CALL MPDIVD (S(K0), T2, 0, S(K2))
      CALL MPADD (S(K3), S(K2), S(K0))
      CALL MPEQ (S(K0), S(K3))
C
C   Check for convergence of the series.
C
      IF (S(K2) .NE. 0. .AND. S(K2+1) .GE. TL) GOTO 100
C
C   Raise to the (2 ^ NQ)-th power.
C
      DO 110 I = 1, NQ
        CALL MPMUL (S(K0), S(K0), S(K1))
        CALL MPEQ (S(K1), S(K0))
 110  CONTINUE
C
C  Multiply by 2 ^ NZ.
C
 120  CALL MPMULD (S(K0), 1.D0, NZ, S(K1))
      CALL MPEQ (S(K1), B)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (B)
C
 130  IF (IDB .GE. 7) THEN
        WRITE (LDB, 4) L1
 4      FORMAT ('Iteration count:',I5)
        CALL MPDEB ('MPEXP O', B)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPEXPX (A, PI, AL2, B)
C
C   This computes the exponential function of the MP number A and returns the
C   MP result in B.  PI is the MP value of Pi produced by a prior call to MPPI
C   or MPPIX.  AL2 is the MP value of Log(2) produced by a prior call to
C   MPLOG  or MPLOGX.  Before calling MPEXPX, the array in MPCOM5 must be
C   initialized by calling MPINIX.  NW should be a power of two.  For modest
C   levels of precision, use MPEXP.  The last four words of the result are
C   not reliable.  Debug output starts with IDB = 5.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 12 * NW + 54
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine uses the Newton iteration
C
C     b_{k+1} = b_k [a + 1 - log b_k]
C
C   with a dynamically changing level of precision.  Logs are performed using
C   MPLOGX.  See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION ALT, CL2, CPI, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (ALT = 0.693147180559945309D0,                          
     $  CL2 = 1.4426950408889633D0, CPI = 3.141592653589793238D0,       
     $  NIT = 1)
      DIMENSION A(NW+2), AL2(NW+2), B(NW+4), F1(8), PI(NW+2)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 5) CALL MPDEB ('MPEXPX I', A)
C
      NCR = 2 ** MCR
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      CALL MPMDC (A, T1, N1)
      T1 = T1 * 2.D0 ** N1
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPEXP (A, AL2, B)
        GOTO 120
      ENDIF
C
C   Check if Log(2) has been precomputed.
C
      CALL MPMDC (AL2, T2, N2)
      IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2)    
     $  THEN
        IF (KER(37) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPEXPX: LOG (2) must be precomputed.')
          IER = 37
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C     Check if Pi has been precomputed.
C
      CALL MPMDC (PI, T2, N2)
      IF (N2 .NE. 0 .OR. ABS (T2 - CPI) .GT. RX2) THEN
        IF (KER(38) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPEXPX: PI must be precomputed.')
          IER = 38
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check for overflows and underflows.
C
      IF (T1 .GE. 1D9) THEN
        IF (T1 .GT. 0.D0) THEN
          IF (KER(39) .NE. 0) THEN
            WRITE (LDB, 3) T1, N1
 3          FORMAT ('*** MPEXPX: Argument is too large',F12.6,' x 10 ^',
     $        I8)
            IER = 39
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ELSE
          B(1) = 0.
          B(2) = 0.
          GOTO 120
        ENDIF
      ENDIF
C
      N4 = NW + 4
      NS = 3 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      NWS = NW
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T2 = NWS
      MQ = CL2 * LOG (T2) + 1.D0 - RXX
      CALL MPADD (A, F1, S(K0))
C
C   Compute initial approximation to Exp (A).
C
      NW = NCR
      CALL MPEXP (A, AL2, B)
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW.
C
      DO 110 K = MCR + 1, MQ
        NW = MIN (2 * NW, NWS)
 100    CONTINUE
        CALL MPLOGX (B, PI, AL2, S(K1))
        CALL MPSUB (S(K0), S(K1), S(K2))
        CALL MPMULX (B, S(K2), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
      ICS = ISS
C
 120  IF (IDB .GE. 6) CALL MPDEB ('MPEXPX O', B)
      RETURN
      END
C
      SUBROUTINE MPFFT1 (IS, L, M, X, Y)
C
C   Performs the L-th iteration of the first variant of the Stockham FFT.
C   This routine is called by MPCFFT.  It is not intended to be called directly
C   by the user.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(*), Y(*)
      COMMON /MPCOM5/ U(1024)
C
C   Set initial parameters.
C
      N = 2 ** M
      K = U(1)
      NU = K / 64
      N1 = N / 2
      LK = 2 ** (L - 1)
      LI = 2 ** (M - L)
      LJ = 2 * LI
      KU = LI + 1
      KN = KU + NU
C
      DO 100 K = 0, LK - 1
        I11 = K * LJ + 1
        I12 = I11 + LI
        I21 = K * LI + 1
        I22 = I21 + N1
C
CDIR$ IVDEP
        DO 100 I = 0, LI - 1
          U1 = U(KU+I)
          U2 = IS * U(KN+I)
          X11 = X(I11+I)
          X12 = X(I11+I+N)
          X21 = X(I12+I)
          X22 = X(I12+I+N)
          T1 = X11 - X21
          T2 = X12 - X22
          Y(I21+I) = X11 + X21
          Y(I21+I+N) = X12 + X22
          Y(I22+I) = U1 * T1 - U2 * T2
          Y(I22+I+N) = U1 * T2 + U2 * T1
 100  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPFFT2 (IS, L, M, X, Y)
C
C   Performs the L-th iteration of the second variant of the Stockham FFT.
C   This routine is called by MPCFFT.  It is not intended to be called directly
C   by the user.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(*), Y(*)
      COMMON /MPCOM5/ U(1024)
C
C   Set initial parameters.
C
      N = 2 ** M
      K = U(1)
      NU = K / 64
      N1 = N / 2
      LK = 2 ** (L - 1)
      LI = 2 ** (M - L)
      LJ = 2 * LK
      KU = LI + 1
C
      DO 100 I = 0, LI - 1
        I11 = I * LK + 1
        I12 = I11 + N1
        I21 = I * LJ + 1
        I22 = I21 + LK
        U1 = U(KU+I)
        U2 = IS * U(KU+I+NU)
C
CDIR$ IVDEP
        DO 100 K = 0, LK - 1
          X11 = X(I11+K)
          X12 = X(I11+K+N)
          X21 = X(I12+K)
          X22 = X(I12+K+N)
          T1 = X11 - X21
          T2 = X12 - X22
          Y(I21+K) = X11 + X21
          Y(I21+K+N) = X12 + X22
          Y(I22+K) = U1 * T1 - U2 * T2
          Y(I22+K+N) = U1 * T2 + U2 * T1
 100  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPINFR (A, B, C)
C
C   Sets B to the integer part of the MP number A and sets C equal to the
C   fractional part of A.  Note that if A = -3.3, then B = -3 and C = -0.3.
C   Debug output starts with IDB = 9.
C
C   Max SP space for B and C: NW + 4 cells.
C
      PARAMETER (NDB = 22)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      DIMENSION A(NW+2), B(NW+2), C(NW+2)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPINFR I'/(6F12.0))
      ENDIF
C
C   Check if  A  is zero.
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      MA = A(2)
      IF (NA .EQ. 0)  THEN
        B(1) = 0.
        B(2) = 0.
        C(1) = 0.
        C(2) = 0.
        GOTO 120
      ENDIF
C
      IF (MA .GE. NW - 1) THEN
        IF (KER(40) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPINFR: Argument is too large.')
          IER = 40
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Place integer part in  B.
C
      NB = MIN (MAX (MA + 1, 0), NA)
      IF (NB .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
      ELSE
        B(1) = SIGN (NB, IA)
        B(2) = MA
        B(NB+3) = 0.
        B(NB+4) = 0.
C
        DO 100 I = 3, NB + 2
          B(I) = A(I)
 100    CONTINUE
C
      ENDIF
C
C   Place fractional part in C.
C
      NC = NA - NB
      IF (NC .LE. 0) THEN
        C(1) = 0.
        C(2) = 0.
      ELSE
        C(1) = SIGN (NC, IA)
        C(2) = MA - NB
        C(NC+3) = 0.
        C(NC+4) = 0.
C
        DO 110 I = 3, NC + 2
          C(I) = A(I+NB)
 110    CONTINUE
C
      ENDIF
C
C   Fix up results.  B may have trailing zeros and C may have leading zeros.
C
      CALL MPROUN (B)
      CALL MPROUN (C)
C
 120  IF (IDB .GE. 9)  THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPINFR O'/(6F12.0))
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 3) (C(I), I = 1, NO)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPINIX (M)
C
C   This initializes the double precision array U in common MPCOM5 with roots
C   of unity required by the FFT routines, which are called by MPMULX.  Before
C   calling any of the advanced MP routines (i.e. those whose names end in X),
C   this routine must be called with M set to MX, where MX is defined as the
C   integer such that 2 ^ MX = NX, and where NX is the largest precision level
C   NW that will be used in the subsequent application.  Before calling MPINIX,
C   the user must allocate at least 2^(M + 3) double precision cells in common
C   MPCOM5, which must be placed in the user's main program.  Also, at least
C   12 * NW + 6 double precision cells must be allocated in common MPCOM4.
C   Only one call to MPINIX is required, no matter how many advanced routines
C   are called.  It is not necessary for the user to call MPINIX, to allocate
C   space in MPCOM5 or to allocate more than NW + 6 cells in MPCOM4 if the
C   advanced routines are not called.
C
      DOUBLE PRECISION PI, T1, T2, U
      PARAMETER (PI = 3.141592653589793238D0)
      COMMON /MPCOM5/ U(1024)
C
C   Initialize the U array with sines and cosines in a manner that permits
C   stride one access at each FFT iteration.
C
      MM = M + 2
      N = 2 ** MM
      NU = N
      U(1) = 64 * N + MM
      KU = 2
      KN = KU + NU
      LN = 1
C
      DO 110 J = 1, MM
        T1 = PI / LN
C
CDIR$ IVDEP
        DO 100 I = 0, LN - 1
          T2 = I * T1
          U(I+KU) = COS (T2)
          U(I+KN) = SIN (T2)
 100    CONTINUE
C
        KU = KU + LN
        KN = KU + NU
        LN = 2 * LN
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPINP (IU, A, CS)
C
C   This routine reads the MP number A from logical unit IU.  CS is a scratch
C   array of type CHARACTER*1.  CS must be dimensioned at least 7.225*NW + 100.
C   The digits of A may span more than one line.  A comma at the end of the
C   last line denotes the end of the MP number.  The input lines may not
C   exceed 120 characters in length.  Embedded blanks are allowed anywhere.
C   However, if the input number contains more than 80 embedded blanks, then
C   the dimension of CS must be increased by a corresponding amount.  The
C   exponent is optional in the input number, but if present it must appear
C   first.  Two examples:
C
C   1073741824.,
C   10 ^  -4 x  3.14159 26535 89793 23846 26433 83279
C     50288 41971 69399 37510,
C
C   Max SP space for A: NW + 4 cells.  Max SP scratch space: 3 * NW + 16 cells.
C
      CHARACTER*120 LIN
      CHARACTER*1 CS(6*NW+100)
      DIMENSION A(NW+2)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        RETURN
      ENDIF
      L = 0
      ND = 7.225D0 * NW + 100.D0
C
 100  READ (IU, '(A)', END = 150) LIN
C
      DO 110 I = 120, 1, -1
        IF (LIN(I:I) .NE. ' ') GOTO 120
 110  CONTINUE
C
      GOTO 100
C
 120  K = I
      IF (L .GT. ND) GOTO 140
C
      DO 130 I = 1, K
        L = L + 1
        IF (L .GT. ND) GOTO 140
        CS(L)= LIN(I:I)
 130  CONTINUE
C
 140  IF (LIN(K:K) .NE. ',') GOTO 100
      L = L - 1
C
 150  CALL MPINPC (CS, L, A)
C
      RETURN
      END
C
      SUBROUTINE MPINPC (A, N, B)
C
C   Converts the CHARACTER*1 array A of length N into the MP number B.  The
C   string A must be in the format '10^s a x tb.c' where a, b and c are digit
C   strings; s and t are '-', '+' or blank; x is either 'x' or '*'.  Blanks may
C   be embedded anywhere.  The digit string a is limited to nine digits and
C   80 total characters, including blanks.  The exponent portion (i.e. the
C   portion up to and including x) and the period may optionally be omitted.
C   Debug output starts with IDB = 7.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 3 * NW + 16 cells.
C
C   The following example shows how this routine may be used to input a MP
C   number:
C
C      CHARACTER*1 CX(800)
C      READ (1, '(80A1)') (CX(I), I = 1, ND)
C      CALL MPINPC (CX, ND, B)
C
      DOUBLE PRECISION BI
      CHARACTER*1 A, AI
      CHARACTER*10 DIG
      CHARACTER*80 CA
      PARAMETER (NDB = 22, DIG = '0123456789')
      DIMENSION A(N), B(NW+4), F(8)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (N, INT (7.225 * NDB) + 20)
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPINPC I'/(78A1))
      ENDIF
C
      N5 = NW + 5
      NS = 2 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      NWS = NW
      NW = NW + 1
      I1 = 1
      NN = 0
C
C   Find the carat, period, plus or minus sign, whichever comes first.
C
      DO 100 I = 1, N
        AI = A(I)
        IF (AI .EQ. '^') GOTO 110
        IF (AI .EQ. '.' .OR. AI .EQ. '+' .OR. AI .EQ. '-') GOTO 160
 100  CONTINUE
C
      GOTO 160
C
C   Make sure number preceding the carat is 10.
C
 110  I2 = I - 1
      IF (I2 .GT. 80) GOTO 210
      CA = ' '
C
      DO 120 I = 1, I2
        AI = A(I)
        IF (AI .EQ. ' ') THEN
          GOTO 120
        ELSEIF (INDEX (DIG, AI) .EQ. 0) THEN
          GOTO 210
        ENDIF
        CA(I:I) = AI
 120  CONTINUE
C
      READ (CA, '(BN,I80)') NN
      IF (NN .NE. 10) GOTO 210
      I1 = I2 + 2
C
C   Find the x or *.
C
      DO 130 I = I1, N
        AI = A(I)
        IF (AI .EQ. 'x' .OR. AI .EQ. '*') GOTO 140
 130  CONTINUE
C
      GOTO 210
C
C   Convert the exponent.
C
 140  I2 = I - 1
      L1 = I2 - I1 + 1
      IF (L1 .GT. 80) GOTO 210
      CA = ' '
      ID = 0
      IS = 1
C
      DO 150 I = 1, L1
        AI = A(I+I1-1)
        IF (AI .EQ. ' ' .OR. AI .EQ. '+') THEN
          GOTO 150
        ELSEIF (AI .EQ. '-' .AND. ID .EQ. 0) THEN
          ID = 1
          IS = -1
          CA(I:I) = ' '
        ELSE
          IF (INDEX (DIG, AI) .EQ. 0) GOTO 210
          ID = 1
          CA(I:I) = AI
        ENDIF
 150  CONTINUE
C
      READ (CA, '(BN,I80)') NN
      NN = IS * NN
      I1 = I2 + 2
C
C   Find the next nonblank character.
C
 160  DO 170 I = I1, N
        IF (A(I) .NE. ' ') GOTO 180
 170  CONTINUE
C
      GOTO 210
C
C   Check if the nonblank character is a plus or minus sign.
C
 180  I1 = I
      IF (A(I1) .EQ. '+') THEN
        I1 = I1 + 1
        IS = 1
      ELSEIF (A(I1) .EQ. '-') THEN
        I1 = I1 + 1
        IS = -1
      ELSE
        IS = 1
      ENDIF
      NB = 0
      IB = 0
      ID = 0
      IP = 0
      B(1) = 0
      B(2) = 0
      F(1) = 1.
      F(2) = 0.
      IT = 0
C
 190  IP = 0
      CA(1:6) = '000000'
C
C   Scan for digits, looking for the period also.  On the first pass we just
C   count, so that on the second pass it will come out right.
C
      DO 200 I = I1, N
        AI = A(I)
        IF (AI .EQ. ' ') THEN
        ELSEIF (AI .EQ. '.') THEN
          IF (IP .NE. 0) GOTO 210
          IP = ID
        ELSEIF (INDEX (DIG, AI) .EQ. 0) THEN
          GOTO 210
        ELSE
          IB = IB + 1
          ID = ID + 1
          CA(IB:IB) = AI
        ENDIF
        IF (IB .EQ. 6 .OR. I .EQ. N .AND. IB .NE. 0) THEN
          IF (IT .NE. 0) THEN
            NB = NB + 1
            READ (CA(1:6), '(F6.0)') BI
            CALL MPMULD (B, 1.D6, 0, S(K0))
            IF (BI .NE. 0) THEN
              F(1) = 1.
              F(3) = BI
            ELSE
              F(1) = 0.
            ENDIF
            CALL MPADD (S(K0), F, B)
            CA(1:6) = '000000'
          ENDIF
          IF (I .NE. N) IB = 0
        ENDIF
 200  CONTINUE
C
      IF (IT .EQ. 0) THEN
        IB = 6 - IB
        IF (IB .EQ. 6) IB = 0
        IT = 1
        GOTO 190
      ENDIF
      IF (IS .EQ. -1) B(1) = - B(1)
      IF (IP .EQ. 0) IP = ID
      NN = NN + IP - ID
      F(1) = 1.
      F(3) = 10.
      CALL MPNPWR (F, NN, S(K0))
      CALL MPMUL (B, S(K0), S(K1))
      CALL MPEQ (S(K1), B)
      NW = NWS
      CALL MPROUN (B)
      ICS = ISS
C
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 2) (B(I), I = 1, NO)
 2      FORMAT ('MPINPC O'/(6F12.0))
      ENDIF
      GOTO 220
C
 210  IF (KER(41) .NE. 0) THEN
        WRITE (LDB, 3)
 3      FORMAT ('*** MPINPC: Syntax error in literal string.')
        IER = 41
        IF (KER(IER) .EQ. 2) CALL MPABRT
        NW = NWS
        ICS = ISS
      ENDIF
C
 220  RETURN
      END
C
      SUBROUTINE MPINQP (IA, IB)
C
C   This routine returns the value of the parameter whose name is IA in common
C   MPCOM1.  By using this routine instead of merely including the MPCOM1
C   block in the code, a user may eliminate the possibility of confusion with
C   a variable name in his or her program.  IA is of type CHARACTER and IB
C   is the value.
C
      CHARACTER*(*) IA
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IA .EQ. 'NW' .OR. IA .EQ. 'nw') THEN
        IB = NW
      ELSEIF (IA .EQ. 'IDB' .OR. IA .EQ. 'idb') THEN
        IB = IDB
      ELSEIF (IA .EQ. 'LDB' .OR. IA .EQ. 'ldb') THEN
        IB = LDB
      ELSEIF (IA .EQ. 'IER' .OR. IA .EQ. 'ier') THEN
        IB = IER
      ELSEIF (IA .EQ. 'MCR' .OR. IA .EQ. 'mcr') THEN
        IB = MCR
      ELSEIF (IA .EQ. 'IRD' .OR. IA .EQ. 'ird') THEN
        IB = IRD
      ELSEIF (IA .EQ. 'ICS' .OR. IA .EQ. 'ics') THEN
        IB = ICS
      ELSEIF (IA .EQ. 'IHS' .OR. IA .EQ. 'ihs') THEN
        IB = IHS
      ELSEIF (IA .EQ. 'IMS' .OR. IA .EQ. 'ims') THEN
        IB = IMS
      ELSE
        IB = 0
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE MPINRL (N, LX, X, MN, MT, LR, R, IQ)
C
C   This routine searches for integer relations among the entries of the
C   N-long MP vector X.  An integer relation is an n-long vector r such that
C   r_1 x_1 + r_2 x_2 + ... + r_n x_n = 0.  The entries of x are assumed to
C   start at X(1), X(LX+1), X(2*LX+1), etc.  MN is the Log_10 of the maximum
C   Euclidean norm of an acceptable relation.  IQ is set to 1 if the routine
C   succeeds in recovering a relation that (1) produces zero to within the
C   relative tolerance 10^MT and (2) has Euclidean norm less than 10^MN.  If
C   no relation is found that meets these standards, IQ is set to 0.  When a
C   valid relation vector is recovered, it is placed in R, beginning at R(1),
C   R(LR+1), R(2*LR+1), etc., where LR, like LX, is an input parameter.  LR
C   should be at least MN/6 + 3.  For extra-high levels of precision, call
C   MPINRX.  Debug output starts with IDB = 4.  When IDB = 5, norm bounds are
C   output within which no relation can exist.
C
C   Max SP space for R: LR * N cells.  Max SP scratch space:
C   (4 * N^2 + 5 * N + 13) * (NW + 4) cells.  Max DP scratch space: NW + 4
C   cells.
C
C   A typical application of this routine is to determine if a given computed
C   real number r is the root of any algebraic equation of degree n - 1 with
C   integer coefficients.  One merely sets x_k = r^(k-1) for k = 1 to n and
C   calls MPINRL.  If an integer relation is found, this relation is the vector
C   of coefficients of a polynomial satisfied by r.  If MPINRL outputs a norm
C   bound of B, then r is not the root of any polynomial of degree n or less
C   with integer coefficients, where the Euclidean norm of the vector of
C   coefficients is less than B.
C
C   It sometimes happens that the "precision exhausted" message is output
C   before finding a relation that is known to exist.  If this happens,
C   increase NW, the working precision level, as well as scratch space
C   allocations if necessary, and try again.  Typically MT is set to roughly
C   10 - 6 * NX, where NX is the precision level used to compute X.  Repeating
C   a run with somewhat higher precision is highly recommended to certify that
C   bounds results are valid.
C
C   This routine allocates the scratch space array S for arrays.  Otherwise the
C   indexing in MPINRQ is too complicated.
C
      CHARACTER*8 CX
      PARAMETER (IB = 6)
      DIMENSION R(LR,N), X(LX,N)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        IQ = 0
        RETURN
      ENDIF
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 1) N, LX, MN, LR
 1      FORMAT ('MPINRL I',4I6)
C
        DO 100 K = 1, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, X(1,K))
 100    CONTINUE
C
      ENDIF
C
C   Check if enough space is allowed for R.
C
      IF (LR .LT. MN / IB + 3) THEN
        IF (KER(42) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPINRL: Argument LR must be larger to match MN.')
          IER = 42
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      NS = (4 * N ** 2 + 5 * N + 7) * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      KBN = N * (N + 1)
      KBS = N + 1 + KBN
      KC = N * (N + 1) + KBS
      KU = N * N + KC
      CALL MPINRQ (N, LX, X, MN, MT, LR, R, IQ, S(K0), S(KBN*N4+K0),    
     $  S(KBS*N4+K0), S(KC*N4+K0), S(KU*N4+K0))
      ICS = ISS
C
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 3) IQ
 3      FORMAT ('MPINRL O',I2)
        IF (IQ .EQ. 1) THEN
C
          DO 110 K = 1, N
            WRITE (CX, '(I4)') K
            CALL MPDEB (CX, R(1,K))
 110      CONTINUE
C
        ENDIF
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPINRQ (N, LX, X, MN, MT, LR, R, IQ, B, BN, BS, C, U)
C
C   This routine implements the "Small Integer Relation Algorithm" described
C   in Hastad, Just, Lagarias, and Schnorr, "Polynomial Time Algorithms for
C   Finding Integer Relations Among Real Numbers", to appear in SIAM J. on
C   Computing.  This routine is called by MPINRL.  It is not intended to be
C   called directly by the user.
C
C   IMX = Number of iterations after which run is terminated.
C   ITP = Print interval.  Also the interval at which norm bounds are computed.
C   LB  = Reduction in log_10 (BN(N)) from previous iteration.  Used to detect
C         that a tentative relation has been found.
C
      DOUBLE PRECISION AB, BNN, BNS, BNZ, BX, BY, T1, T2, T3, T4, TB
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (IMX = 10000, ITP = 10, ITZ = 100, LB = 20)
      DIMENSION B(NW+4,N,0:N), BN(NW+4,0:N), BS(NW+4,N,0:N),            
     $  C(NW+4,N,N), R(LR,N), U(NW+4,0:N,0:N), X(LX,N)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
C   Step 1: Initialization.
C
      N4 = NW + 4
      NS = 5 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      K4 = K3 + N4
      NWS = NW
      TL = 2 - NW
      BNS = 0.D0
      BNZ = 0.D0
      IBS = 0
      IBZ = 0
      II = 0
      IQ = 0
C
      DO 100 I = 1, N
        CALL MPEQ (X(1,I), B(1,I,0))
 100  CONTINUE
C
      DO 120 J = 1, N
C
        DO 110 I = 1, N
          B(1,I,J) = 0.
          B(2,I,J) = 0.
          C(1,I,J) = 0.
          C(2,I,J) = 0.
 110    CONTINUE
C
        B(1,J,J) = 1.
        B(2,J,J) = 0.
        B(3,J,J) = 1.
        C(1,J,J) = 1.
        C(2,J,J) = 0.
        C(3,J,J) = 1.
 120  CONTINUE
C
      DO 180 I = 0, N
C
        DO 130 K = 1, N
          CALL MPEQ (B(1,K,I), BS(1,K,I))
 130    CONTINUE
C
        DO 160 J = 0, I - 1
          S(K0) = 0.
          S(K0+1) = 0.
C
          DO 140 K = 1, N
            CALL MPMUL (B(1,K,I), BS(1,K,J), S(K1))
            CALL MPADD (S(K0), S(K1), S(K2))
            CALL MPEQ (S(K2), S(K0))
 140      CONTINUE
C
          IF (BN(1,J) .EQ. 0. .OR. BN(2,J) .LT. TL) THEN
            U(1,I,J) = 0.
            U(2,I,J) = 0.
          ELSE
            CALL MPDIV (S(K0), BN(1,J), U(1,I,J))
          ENDIF
          U(1,J,I) = 0.
          U(2,J,I) = 0.
C
          DO 150 K = 1, N
            CALL MPMUL (U(1,I,J), BS(1,K,J), S(K0))
            CALL MPSUB (BS(1,K,I), S(K0), S(K1))
            CALL MPEQ (S(K1), BS(1,K,I))
 150      CONTINUE
 160    CONTINUE
C
        S(K0) = 0.
        S(K0+1) = 0.
C
        DO 170 K = 1, N
          CALL MPMUL (BS(1,K,I), BS(1,K,I), S(K1))
          CALL MPADD (S(K0), S(K1), S(K2))
          CALL MPEQ (S(K2), S(K0))
 170    CONTINUE
C
        CALL MPEQ (S(K0), BN(1,I))
        U(1,I,I) = 1.
        U(2,I,I) = 0.
        U(3,I,I) = 1.
 180  CONTINUE
C
C   Step 2: Termination test.
C
 190  II = II + 1
      IF (IER .NE. 0) RETURN
      IF (II .GT. IMX) THEN
        IF (KER(43) .NE. 0) THEN
          WRITE (LDB, 1) II
 1        FORMAT ('*** MPINRQ: Iteration limit exceeded',I6)
          IER = 43
          IF (KER(IER) .EQ. 2) CALL MPABRT
          ICS = ISS
          RETURN
        ENDIF
      ENDIF
      BX = 0.D0
      BY = 0.D0
      IX = -10000
      IY = -10000
C
      DO 200 I = 1, N - 1
        CALL MPMDC (BN(1,I), AB, IB)
        IF ((AB .GT. BX .AND. IB .EQ. IX) .OR. (AB .NE. 0.D0            
     $    .AND. IB .GT. IX)) THEN
          BX = AB
          IX = IB
        ENDIF
        CALL DPMUL (2.D0 ** I, 0, AB, IB, T1, N1)
        IF ((T1 .GT. BY .AND. N1 .EQ. IY) .OR. (T1 .NE. 0.D0            
     $    .AND. N1 .GT. IY)) THEN
          BY = T1
          IY = N1
          I1 = I
        ENDIF
 200  CONTINUE
C
      CALL DPSQRT (BX, IX, T1, N1)
      CALL DPDIV (1.D0, 0, T1, N1, T2, N2)
      CALL DPDEC (T2, N2, TB, NB)
      CALL MPMDC (BN(1,N), T2, N2)
      CALL DPDEC (T2, N2, BNN, IBN)
      IF ((IDB .GE. 5 .AND. MOD (II, ITP) .EQ. 0) .OR. IDB .GE. 6) THEN
        WRITE (LDB, 2) II, TB, NB, BNN, IBN
 2      FORMAT ('Iteration', I6/ 'Norm bound =', F10.6, ' x 10^', I6,   
     $    4X, 'BN(N) =', F10.6, ' x 10^', I6)
        IF (IDB .GE. 6) THEN
          WRITE (LDB, 3)
 3        FORMAT ('BSTAR square norms:')
          CALL MPMOUT (1, N, BN(1,1))
        ENDIF
        IF (IDB .GE. 7) THEN
          WRITE (LDB, 4)
 4        FORMAT ('B Matrix')
          CALL MPMOUT (N, N + 1, B)
          WRITE (LDB, 5)
 5        FORMAT ('U Matrix')
          CALL MPMOUT (N + 1, N + 1, U)
        ENDIF
      ENDIF
      IF (NB .GT. MN) GOTO 280
C
C   Test if current BN(N) is 10^LB times the previous BN(N).
C
      IF (BNN .NE. 0.D0 .AND. IBN .GT. IBS + LB) THEN
        IF (IDB .GE. 5) WRITE (LDB, 6) II, BNN, IBN
 6      FORMAT (/'Tentative relation, iteration', I6, 4X, 'BN(N) =',    
     $    F10.6, ' x 10^', I6)
C
C   Compute residual and norm of tentative relation.
C
        DO 220 K = N, 1, -1
          T2 = 0.D0
          N2 = 0
          S(K0) = 0.
          S(K0+1) = 0.
C
          DO 210 J = 1, N
            NW = LR - 2
            CALL MPEQ (C(1,J,K), R(1,J))
            NW = NWS
            CALL MPMDC (R(1,J), T1, N1)
            CALL DPMUL (T1, N1, T1, N1, T3, N3)
            CALL DPADD (T2, N2, T3, N3, T4, N4)
            T2 = T4
            N2 = N4
            CALL MPMUL (R(1,J), X(1,J), S(K1))
            CALL MPADD (S(K0), S(K1), S(K2))
            CALL MPEQ (S(K2), S(K0))
 210      CONTINUE
C
C   If the residual is zero or within tolerance 10^MT of zero, it is a real
C   relation.  Otherwise it was a false alarm.
C
          CALL MPMDC (S(K0), T3, N3)
          CALL DPDEC (T3, N3, T1, N1)
          IF (T1 .EQ. 0.D0 .OR. N1 .LE. MT) THEN
            IF (IDB .GE. 4) THEN
              CALL DPSQRT (T2, N2, T3, N3)
              CALL DPDEC (T3, N3, T1, N1)
              CALL MPMDC (S(K0), T4, N4)
              CALL DPDEC (T4, N4, T2, N2)
              WRITE (LDB, 7) K, T1, N1, T2, N2
 7            FORMAT ('Relation in column',I4,3X,'Norm =',F10.6,        
     $          ' x 10^',I6/'Residual =',F10.6,' x 10^',I6)
            ENDIF
            IQ = 1
            GOTO 280
          ENDIF
 220    CONTINUE
C
      ENDIF
C
C   Test if BN(N) is the same as ITZ iterations ago.
C
      IF (MOD (II, ITZ) .EQ. 0) THEN
        IF (BNN .EQ. BNZ .AND. IBN .EQ. IBZ) THEN
          IF (KER(44) .NE. 0) THEN
            WRITE (LDB, 8) INT (LOG10 (BDX) * (NW + 3))
 8          FORMAT ('*** MPINRQ: Numeric overflow has occurred.  Call ',
     $        'MPINRL with at least',I8/'digits precision.')
            IER = 44
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          ICS = ISS
          RETURN
        ENDIF
        BNZ = BNN
        IBZ = IBN
      ENDIF
      BNS = BNN
      IBS = IBN
C
C   Step 3: Update B and C for transformation and then exchange B and C.
C
      I2 = I1 + 1
C
C   Check if U(i2,i1) can be converted exactly to an integer.  The error
C   number and message are the same as the previous one.
C
      IF (ABS (U(2,I2,I1)) .GE. NW - 1) THEN
        IF (KER(45) .NE. 0) THEN
          WRITE (LDB, 8) INT (LOG10 (BDX) * ABS (U(2,I2,I1)))
          IER = 45
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        ICS = ISS
        RETURN
      ENDIF
      CALL MPNINT (U(1,I2,I1), S(K0))
C
      DO 230 K = 1, N
        CALL MPMUL (S(K0), B(1,K,I1), S(K1))
        CALL MPSUB (B(1,K,I2), S(K1), S(K2))
        CALL MPEQ (S(K2), B(1,K,I2))
        CALL MPMUL (S(K0), C(1,K,I2), S(K1))
        CALL MPADD (C(1,K,I1), S(K1), S(K2))
        CALL MPEQ (S(K2), C(1,K,I1))
 230  CONTINUE
C
      DO 240 K = 1, N
        CALL MPEQ (B(1,K,I1), S(K1))
        CALL MPEQ (B(1,K,I2), B(1,K,I1))
        CALL MPEQ (S(K1), B(1,K,I2))
        CALL MPEQ (C(1,K,I1), S(K1))
        CALL MPEQ (C(1,K,I2), C(1,K,I1))
        CALL MPEQ (S(K1), C(1,K,I2))
 240  CONTINUE
C
C   Update U for transformation.
C
      DO 250 J = 0, I1
        CALL MPMUL (S(K0), U(1,I1,J), S(K1))
        CALL MPSUB (U(1,I2,J), S(K1), S(K2))
        CALL MPEQ (S(K2), U(1,I2,J))
 250  CONTINUE
C
C   Update BN and U for exchange.
C
      CALL MPEQ (U(1,I2,I1), S(K0))
      CALL MPMUL (S(K0), S(K0), S(K1))
      CALL MPMUL (S(K1), BN(1,I1), S(K2))
      CALL MPADD (BN(1,I2), S(K2), S(K1))
      IF (S(K1) .NE. 0. .AND. S(K1+1) .GT. TL) THEN
        CALL MPDIV (BN(1,I1), S(K1), S(K2))
        CALL MPMUL (BN(1,I2), S(K2), S(K3))
        CALL MPEQ (S(K3), BN(1,I2))
        CALL MPMUL (S(K0), S(K2), S(K3))
        CALL MPEQ (S(K3), U(1,I2,I1))
      ELSE
        CALL MPEQ (BN(1,I1), BN(1,I2))
        U(1,I2,I1) = 0.
        U(2,I2,I1) = 0.
      ENDIF
      CALL MPEQ (S(K1), BN(1,I1))
C
      DO 260 J = 1, I1 - 1
        CALL MPEQ (U(1,I1,J), S(K1))
        CALL MPEQ (U(1,I2,J), U(1,I1,J))
        CALL MPEQ (S(K1), U(1,I2,J))
 260  CONTINUE
C
      S(K1) = 1.
      S(K1+1) = 0.
      S(K1+2) = 1.
C
      DO 270 J = I1 + 2, N
        CALL MPMUL (U(1,J,I1), U(1,I2,I1), S(K2))
        CALL MPMUL (S(K0), U(1,I2,I1), S(K3))
        CALL MPSUB (S(K1), S(K3), S(K4))
        CALL MPMUL (U(1,J,I2), S(K4), S(K3))
        CALL MPADD (S(K2), S(K3), S(K4))
        CALL MPMUL (S(K0), U(1,J,I2), S(K2))
        CALL MPSUB (U(1,J,I1), S(K2), U(1,J,I2))
        CALL MPEQ (S(K4), U(1,J,I1))
 270  CONTINUE
C
      GOTO 190
C
 280  IF (IDB .GE. 4) WRITE (6, 9) II, TB, NB
 9    FORMAT ('No. iterations =',I6/'Max. bound =',1PD15.6,             
     $  ' x 10^',I5)
      ICS = ISS
      RETURN
      END
C
      SUBROUTINE MPINRX (N, LX, X, MN, MT, LR, R, IQ)
C
C   This routine searches for integer relations among the entries of the
C   N-long MP vector X.  An integer relation is an n-long vector r such that
C   r_1 x_1 + r_2 x_2 + ... + r_n x_n = 0.  The entries of x are assumed to
C   start at X(1), X(LX+1), X(2*LX+1), etc.  MN is the Log_10 of the maximum
C   Euclidean norm of an acceptable relation.  IQ is set to 1 if the routine
C   succeeds in recovering a relation that (1) produces zero to within the
C   relative tolerance 10^MT and (2) has Euclidean norm less than 10^MN.  If
C   no relation is found that meets these standards, IQ is set to 0.  When a
C   valid relation vector is recovered, it is placed in R, beginning at R(1),
C   R(LR+1), R(2*LR+1), etc., where LR, like LX, is an input parameter.  LR
C   should be at least MN/6 + 3.  Before calling MPINRX, the array in MPCOM5
C   must be initialized by calling MPINIX.  For modest levels of precision,
C   call MPINRL.  Debug output starts with IDB = 4.  When IDB = 5, norm bounds
C   are output within which no relation can exist.
C
C   Max SP space for R: LR * N cells.  Max SP scratch space:
C   (4 * N^2 + 5 * N + 14) * (NW + 4) cells.  Max DP scratch space: 12 * NW + 6
C   cells.
C
C   See the comments in MPINRL about applying this routine.
C
C   This allocates the scratch space array S for arrays.  Otherwise the
C   indexing in MPINRZ is too complicated.
C
      CHARACTER*8 CX
      PARAMETER (IB = 6)
      DIMENSION R(LR,N), X(LX,N)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        IQ = 0
        RETURN
      ENDIF
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 1) N, LX, MN, LR
 1      FORMAT ('MPINRX I',4I6)
C
        DO 100 K = 1, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, X(1,K))
 100    CONTINUE
C
      ENDIF
C
C   Check if enough space is allowed for R.
C
      IF (LR .LE. MN / IB) THEN
        IF (KER(46) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPINRX: Argument LR must be larger to match MN.')
          IER = 46
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if the precision level is too low to justify the advanced routine.
C
      NCR = 2 ** MCR
      IF (NW .LE. NCR) THEN
        CALL MPINRL (N, LX, X, MN, MT, LR, R, IQ)
        GOTO 110
      ENDIF
C
C   Compute pointers for arrays.
C
      N4 = NW + 4
      NS = (4 * N ** 2 + 5 * N + 7) * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      KBN = N * (N + 1)
      KBS = N + 1 + KBN
      KC = N * (N + 1) + KBS
      KU = N * N + KC
      CALL MPINRZ (N, LX, X, MN, MT, LR, R, IQ, S(K0), S(KBN*N4+K0),    
     $  S(KBS*N4+K0), S(KC*N4+K0), S(KU*N4+K0))
      ICS = ISS
C
 110  IF (IDB .GE. 5) THEN
        WRITE (LDB, 3) IQ
 3      FORMAT ('MPINRX O',I2)
        IF (IQ .EQ. 1) THEN
C
          DO 120 K = 1, N
            WRITE (CX, '(I4)') K
            CALL MPDEB (CX, R(1,K))
 120      CONTINUE
C
        ENDIF
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPINRZ (N, LX, X, MN, MT, LR, R, IQ, B, BN, BS, C, U)
C
C   This is the extra-high precision version of MPINRQ.  See the comments
C   there for details.
C
      DOUBLE PRECISION AB, BNN, BNS, BNZ, BX, BY, T1, T2, T3, T4, TB
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (IMX = 10000, ITP = 25, ITZ = 250, LB = 20)
      DIMENSION B(NW+4,N,0:N), BN(NW+4,0:N), BS(NW+4,N,0:N),            
     $  C(NW+4,N,N), R(LR,N), U(NW+4,0:N,0:N), X(LX,N)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
C   Step 1: Initialization.
C
      N4 = NW + 4
      NS = 5 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      K4 = K3 + N4
      NWS = NW
      IF (NW .LE. 32) THEN
        TL = 2 - NW
      ELSEIF (NW .LE. 256) THEN
        TL = 3 - NW
      ELSE
        TL = 4 - NW
      ENDIF
      BNS = 0.D0
      BNZ = 0.D0
      IBS = 0
      IBZ = 0
      II = 0
      IQ = 0
C
      DO 100 I = 1, N
        CALL MPEQ (X(1,I), B(1,I,0))
 100  CONTINUE
C
      DO 120 J = 1, N
C
        DO 110 I = 1, N
          B(1,I,J) = 0.
          B(2,I,J) = 0.
          C(1,I,J) = 0.
          C(2,I,J) = 0.
 110    CONTINUE
C
        B(1,J,J) = 1.
        B(2,J,J) = 0.
        B(3,J,J) = 1.
        C(1,J,J) = 1.
        C(2,J,J) = 0.
        C(3,J,J) = 1.
 120  CONTINUE
C
      DO 180 I = 0, N
C
        DO 130 K = 1, N
          CALL MPEQ (B(1,K,I), BS(1,K,I))
 130    CONTINUE
C
        DO 160 J = 0, I - 1
          S(K0) = 0.
          S(K0+1) = 0.
C
          DO 140 K = 1, N
            CALL MPMULX (B(1,K,I), BS(1,K,J), S(K1))
            CALL MPADD (S(K0), S(K1), S(K2))
            CALL MPEQ (S(K2), S(K0))
 140      CONTINUE
C
          IF (BN(1,J) .EQ. 0. .OR. BN(2,J) .LT. TL) THEN
            U(1,I,J) = 0.
            U(2,I,J) = 0.
          ELSE
            CALL MPDIVX (S(K0), BN(1,J), U(1,I,J))
          ENDIF
          U(1,J,I) = 0.
          U(2,J,I) = 0.
C
          DO 150 K = 1, N
            CALL MPMULX (U(1,I,J), BS(1,K,J), S(K0))
            CALL MPSUB (BS(1,K,I), S(K0), S(K1))
            CALL MPEQ (S(K1), BS(1,K,I))
 150      CONTINUE
 160    CONTINUE
C
        S(K0) = 0.
        S(K0+1) = 0.
C
        DO 170 K = 1, N
          CALL MPMULX (BS(1,K,I), BS(1,K,I), S(K1))
          CALL MPADD (S(K0), S(K1), S(K2))
          CALL MPEQ (S(K2), S(K0))
 170    CONTINUE
C
        CALL MPEQ (S(K0), BN(1,I))
        U(1,I,I) = 1.
        U(2,I,I) = 0.
        U(3,I,I) = 1.
 180  CONTINUE
C
C   Step 2: Termination test.
C
 190  II = II + 1
      IF (IER .NE. 0) RETURN
      IF (II .GT. IMX) THEN
        IF (KER(47) .NE. 0) THEN
          WRITE (LDB, 1) II
 1        FORMAT ('*** MPINRZ: Iteration limit exceeded',I6)
          IER = 47
          IF (KER(IER) .EQ. 2) CALL MPABRT
          ICS = ISS
          RETURN
        ENDIF
      ENDIF
      BX = 0.D0
      BY = 0.D0
      IX = -10000
      IY = -10000
C
      DO 200 I = 1, N - 1
        CALL MPMDC (BN(1,I), AB, IB)
        IF ((AB .GT. BX .AND. IB .EQ. IX) .OR. (AB .NE. 0.D0            
     $    .AND. IB .GT. IX)) THEN
          BX = AB
          IX = IB
        ENDIF
        CALL DPMUL (2.D0 ** I, 0, AB, IB, T1, N1)
        IF ((T1 .GT. BY .AND. N1 .EQ. IY) .OR. (T1 .NE. 0.D0            
     $    .AND. N1 .GT. IY)) THEN
          BY = T1
          IY = N1
          I1 = I
        ENDIF
 200  CONTINUE
C
      CALL DPSQRT (BX, IX, T1, N1)
      CALL DPDIV (1.D0, 0, T1, N1, T2, N2)
      CALL DPDEC (T2, N2, TB, NB)
      CALL MPMDC (BN(1,N), T2, N2)
      CALL DPDEC (T2, N2, BNN, IBN)
      IF ((IDB .GE. 5 .AND. MOD (II, ITP) .EQ. 0) .OR. IDB .GE. 6) THEN
        WRITE (LDB, 2) II, TB, NB, BNN, IBN
 2      FORMAT ('Iteration', I6/ 'Norm bound =', F10.6, ' x 10^', I6,   
     $    4X, 'BN(N) =', F10.6, ' x 10^', I6)
        IF (IDB .GE. 6) THEN
          WRITE (LDB, 3)
 3        FORMAT ('BSTAR square norms:')
          CALL MPMOUT (1, N, BN(1,1))
        ENDIF
        IF (IDB .GE. 7) THEN
          WRITE (LDB, 4)
 4        FORMAT ('B Matrix')
          CALL MPMOUT (N, N + 1, B)
          WRITE (LDB, 5)
 5        FORMAT ('U Matrix')
          CALL MPMOUT (N + 1, N + 1, U)
        ENDIF
      ENDIF
      IF (NB .GT. MN) GOTO 280
C
C   Test if current BN(N) is 10^LB times the previous BN(N).
C
      IF (BNN .NE. 0.D0 .AND. IBN .GT. IBS + LB) THEN
        IF (IDB .GE. 5) WRITE (LDB, 6) II, BNN, IBN
 6      FORMAT (/'Tentative relation, iteration', I6, 4X, 'BN(N) =',    
     $    F10.6, ' x 10^', I6)
C
C   Compute residual and norm of tentative relation.
C
        DO 220 K = N, 1, -1
          T2 = 0.D0
          N2 = 0
          S(K0) = 0.
          S(K0+1) = 0.
C
          DO 210 J = 1, N
            NW = LR - 2
            CALL MPEQ (C(1,J,K), R(1,J))
            NW = NWS
            CALL MPMDC (R(1,J), T1, N1)
            CALL DPMUL (T1, N1, T1, N1, T3, N3)
            CALL DPADD (T2, N2, T3, N3, T4, N4)
            T2 = T4
            N2 = N4
            CALL MPMULX (R(1,J), X(1,J), S(K1))
            CALL MPADD (S(K0), S(K1), S(K2))
            CALL MPEQ (S(K2), S(K0))
 210      CONTINUE
C
C   If the residual is zero or within tolerance 10^MT of zero, it is a real
C   relation.  Otherwise it was a false alarm.
C
          CALL MPMDC (S(K0), T3, N3)
          CALL DPDEC (T3, N3, T1, N1)
          IF (T1 .EQ. 0.D0 .OR. N1 .LE. MT) THEN
            IF (IDB .GE. 4) THEN
              CALL DPSQRT (T2, N2, T3, N3)
              CALL DPDEC (T3, N3, T1, N1)
              CALL MPMDC (S(K0), T4, N4)
              CALL DPDEC (T4, N4, T2, N2)
              WRITE (LDB, 7) K, T1, N1, T2, N2
 7            FORMAT ('Relation in column',I4,3X,'Norm =',F10.6,        
     $          ' x 10^',I6/'Residual =',F10.6,' x 10^',I6)
            ENDIF
            IQ = 1
            GOTO 280
          ENDIF
 220    CONTINUE
C
      ENDIF
C
C   Test if BN(N) is the same as ITZ iterations ago.
C
      IF (MOD (II, ITZ) .EQ. 0) THEN
        IF (BNN .EQ. BNZ .AND. IBN .EQ. IBZ) THEN
          IF (KER(48) .NE. 0) THEN
            WRITE (LDB, 8) INT (LOG10 (BDX) * (NW + 3))
 8          FORMAT ('*** MPINRZ: Numeric overflow has occurred.  Call ',
     $        'MPINRX with at least',I8/'digits precision.')
            IER = 48
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          ICS = ISS
          RETURN
        ENDIF
        BNZ = BNN
        IBZ = IBN
      ENDIF
      BNS = BNN
      IBS = IBN
C
C   Step 3: Update B and C for transformation and then exchange B and C.
C
      I2 = I1 + 1
C
C   Check if U(i2,i1) can be converted exactly to an integer.  The error
C   number and message are the same as the previous one.
C
      IF (ABS (U(2,I2,I1)) .GE. NW - 1) THEN
        IF (KER(49) .NE. 0) THEN
          WRITE (LDB, 8) INT (LOG10 (BDX) * ABS (U(2,I2,I1)))
          IER = 49
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        ICS = ISS
        RETURN
      ENDIF
      CALL MPNINT (U(1,I2,I1), S(K0))
C
      DO 230 K = 1, N
        CALL MPMULX (S(K0), B(1,K,I1), S(K1))
        CALL MPSUB (B(1,K,I2), S(K1), S(K2))
        CALL MPEQ (S(K2), B(1,K,I2))
        CALL MPMULX (S(K0), C(1,K,I2), S(K1))
        CALL MPADD (C(1,K,I1), S(K1), S(K2))
        CALL MPEQ (S(K2), C(1,K,I1))
 230  CONTINUE
C
      DO 240 K = 1, N
        CALL MPEQ (B(1,K,I1), S(K1))
        CALL MPEQ (B(1,K,I2), B(1,K,I1))
        CALL MPEQ (S(K1), B(1,K,I2))
        CALL MPEQ (C(1,K,I1), S(K1))
        CALL MPEQ (C(1,K,I2), C(1,K,I1))
        CALL MPEQ (S(K1), C(1,K,I2))
 240  CONTINUE
C
C   Update U for transformation.
C
      DO 250 J = 0, I1
        CALL MPMULX (S(K0), U(1,I1,J), S(K1))
        CALL MPSUB (U(1,I2,J), S(K1), S(K2))
        CALL MPEQ (S(K2), U(1,I2,J))
 250  CONTINUE
C
C   Update BN and U for exchange.
C
      CALL MPEQ (U(1,I2,I1), S(K0))
      CALL MPMULX (S(K0), S(K0), S(K1))
      CALL MPMULX (S(K1), BN(1,I1), S(K2))
      CALL MPADD (BN(1,I2), S(K2), S(K1))
      IF (S(K1) .NE. 0. .AND. S(K1+1) .GT. TL) THEN
        CALL MPDIVX (BN(1,I1), S(K1), S(K2))
        CALL MPMULX (BN(1,I2), S(K2), S(K3))
        CALL MPEQ (S(K3), BN(1,I2))
        CALL MPMULX (S(K0), S(K2), S(K3))
        CALL MPEQ (S(K3), U(1,I2,I1))
      ELSE
        CALL MPEQ (BN(1,I1), BN(1,I2))
        U(1,I2,I1) = 0.
        U(2,I2,I1) = 0.
      ENDIF
      CALL MPEQ (S(K1), BN(1,I1))
C
      DO 260 J = 1, I1 - 1
        CALL MPEQ (U(1,I1,J), S(K1))
        CALL MPEQ (U(1,I2,J), U(1,I1,J))
        CALL MPEQ (S(K1), U(1,I2,J))
 260  CONTINUE
C
      S(K1) = 1.
      S(K1+1) = 0.
      S(K1+2) = 1.
C
      DO 270 J = I1 + 2, N
        CALL MPMULX (U(1,J,I1), U(1,I2,I1), S(K2))
        CALL MPMULX (S(K0), U(1,I2,I1), S(K3))
        CALL MPSUB (S(K1), S(K3), S(K4))
        CALL MPMULX (U(1,J,I2), S(K4), S(K3))
        CALL MPADD (S(K2), S(K3), S(K4))
        CALL MPMULX (S(K0), U(1,J,I2), S(K2))
        CALL MPSUB (U(1,J,I1), S(K2), U(1,J,I2))
        CALL MPEQ (S(K4), U(1,J,I1))
 270  CONTINUE
C
      GOTO 190
C
 280  IF (IDB .GE. 4) WRITE (6, 9) II, TB, NB
 9    FORMAT ('No. iterations =',I6/'Max. bound =',1PD15.6,             
     $  ' x 10^',I5)
      ICS = ISS
      RETURN
      END
C
      SUBROUTINE MPLOG (A, AL2, B)
C
C   This computes the natural logarithm of the MP number A and returns the MP
C   result in B.  AL2 is the MP value of Log(2) produced by a prior call to
C   MPLOG.  For extra high levels of precision, use MPLOGX.  The last word of
C   the result is not reliable.  Debug output starts with IDB = 6.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 8 * NW + 43
C   cells.  Max DP scratch space: NW + 6 cells.
C
C   The Taylor series for Log converges much more slowly than that of Exp.
C   Thus this routine does not employ Taylor series, but instead computes
C   logarithms by solving Exp (b) = a using the following Newton iteration,
C   which converges to b:
C
C           x_{k+1} = x_k + [a - Exp (x_k)] / Exp (x_k)
C
C   These iterations are performed with a maximum precision level NW that
C   is dynamically changed, approximately doubling with each iteration.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION ALT, CL2, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (ALT = 0.693147180559945309D0,                          
     $  CL2 = 1.4426950408889633D0, NIT = 3)
      DIMENSION A(NW+2), AL2(NW+2), B(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) CALL MPDEB ('MPLOG I', A)
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
C
      IF (IA .LT. 0 .OR. NA .EQ. 0) THEN
        IF (KER(50) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPLOG: Argument is less than or equal to zero.')
          IER = 50
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C  Unless the input is close to 2, Log (2) must have been precomputed.
C
      CALL MPMDC (A, T1, N1)
      IF (ABS (T1 - 2.D0) .GT. 1D-3 .OR. N1 .NE. 0) THEN
        CALL MPMDC (AL2, T2, N2)
        IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2)  
     $    THEN
          IF (KER(51) .NE. 0) THEN
            WRITE (LDB, 2)
 2          FORMAT ('*** MPLOG: LOG (2) must be precomputed.')
            IER = 51
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ENDIF
C
C   Check if input is exactly one.
C
      IF (A(1) .EQ. 1. .AND. A(2) .EQ. 0. .AND. A(3) .EQ. 1.) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 120
      ENDIF
C
      N5 = NW + 5
      NS = 3 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      NWS = NW
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T2 = NWS
      MQ = CL2 * LOG (T2) + 1.D0 - RXX
C
C   Compute initial approximation of Log (A).
C
      T1 = LOG (T1) + N1 * ALT
      CALL MPDMC (T1, 0, B)
      NW = 3
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (one greater than powers of two).
C
      DO 110 K = 2, MQ
        NW = MIN (2 * NW - 2, NWS) + 1
 100    CONTINUE
        CALL MPEXP (B, AL2, S(K0))
        CALL MPSUB (A, S(K0), S(K1))
        CALL MPDIV (S(K1), S(K0), S(K2))
        CALL MPADD (B, S(K2), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (B)
C
 120  IF (IDB .GE. 6) CALL MPDEB ('MPLOG O', B)
C
      RETURN
      END
C
      SUBROUTINE MPLOGX (A, PI, AL2, B)
C
C   This computes the natural logarithm of the MP number A and returns the MP
C   result in B.  PI is the MP value of Pi produced by a prior call to MPPI or
C   MPPIX.  AL2 is the MP value of Log(2) produced by a prior call to MPLOG
C   or MPLOGX.  Before calling MPLOGX, the array in MPCOM5 must be
C   initialized by calling MPINIX.  For modest levels of precision, use MPLOG.
C   NW should be a power of two.  The last three words of the result are not
C   reliable.  Debug output starts with IDB = 6.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 9 * NW + 42
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This uses the following algorithm, which is due to Salamin.  If a is
C   extremely close to 1, use a Taylor series.  Otherwise select n such that
C   z = x 2^n is at least 2^m, where m is the number of bits of desired
C   precision in the result.  Then
C
C   Log(x) = Pi / [2 AGM (1, 4/x)]
C
      DOUBLE PRECISION ALT, CPI, ST, T1, T2, TN
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (MZL = -5, ALT = 0.693147180559945309D0,                
     $  CPI = 3.141592653589793D0)
      DIMENSION AL2(NW+2), F1(8), F4(8), PI(NW+2), A(NW+4), B(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) CALL MPDEB ('MPLOGX I', A)
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NCR = 2 ** MCR
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPLOG (A, AL2, B)
        L1 = 0
        L2 = 0
        L3 = 0
        L4 = 0
        GOTO 110
      ENDIF
C
      IF (IA .LT. 0 .OR. NA .EQ. 0) THEN
C
C   Input is less than or equal to zero.
C
        IF (KER(52) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPLOGX: Argument is less than or equal to zero.')
          IER = 52
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if Pi has been precomputed.
C
      CALL MPMDC (PI, T1, N1)
      IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN
        IF (KER(53) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPLOGX: PI must be precomputed.')
          IER = 53
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C  Unless the input is 2, Log (2) must have been precomputed.
C
      IF (A(1) .NE. 1. .OR. A(2) .NE. 0. .OR. A(3) .NE. 2.) THEN
        IT2 = 0
        CALL MPMDC (AL2, T2, N2)
        IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2)  
     $    THEN
          IF (KER(54) .NE. 0) THEN
            WRITE (LDB, 3)
 3          FORMAT ('*** MPLOGX: Log (2) must be precomputed.')
            IER = 54
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ELSE
        IT2 = 1
      ENDIF
C
C   Define sections of the scratch array.
C
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      F4(1) = 1.
      F4(2) = 0.
      F4(3) = 4.
C
C   If argument is 1, the result is zero.  If the argument is extremely close
C   to 1.  If so, employ a Taylor's series instead.
C
      CALL MPSUB (A, F1, S(K0))
      IF (S(K0) .EQ. 0.) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 110
      ELSEIF (S(K0+1) .LE. MZL) THEN
        CALL MPEQ (S(K0), S(K1))
        CALL MPEQ (S(K1), S(K2))
        I1 = 1
        IS = 1
        TL = S(K0+1) - NW - 1
C
 100    I1 = I1 + 1
        IS = - IS
        ST = IS * I1
        CALL MPMULX (S(K1), S(K2), S(K3))
        CALL MPDIVD (S(K3), ST, 0, S(K2))
        CALL MPADD (S(K0), S(K2), S(K3))
        CALL MPEQ (S(K3), S(K0))
        IF (S(K2+1) .GE. TL) GOTO 100
C
        CALL MPEQ (S(K0), B)
        GOTO 110
      ENDIF
C
C   If input is exactly 2, set the exponent to a large value.  Otherwise
C   multiply the input by a large power of two.
C
      CALL MPMDC (A, T1, N1)
      N2 = NBT * (NW / 2 + 2) - N1
      TN = N2
      IF (IT2 .EQ. 1) THEN
        CALL MPDMC (1.D0, N2, S(K0))
      ELSE
        CALL MPMULD (A, 1.D0, N2, S(K0))
      ENDIF
C
C   Perform AGM iterations.
C
      CALL MPEQ (F1, S(K1))
      CALL MPDIVX (F4, S(K0), S(K2))
      CALL MPAGMX (S(K1), S(K2))
C
C   Compute B = Pi / (2 * A), where A is the limit of the AGM iterations.
C
      CALL MPMULD (S(K1), 2.D0, 0, S(K0))
      CALL MPDIVX (PI, S(K0), S(K1))
C
C  If the input was exactly 2, divide by TN.  Otherwise subtract TN * Log(2).
C
      IF (IT2 .EQ. 1) THEN
        CALL MPDIVD (S(K1), TN, 0, S(K0))
      ELSE
        CALL MPMULD (AL2, TN, 0, S(K2))
        CALL MPSUB (S(K1), S(K2), S(K0))
      ENDIF
      CALL MPEQ (S(K0), B)
C
 110  ICS = ISS
      IF (IDB .GE. 6) CALL MPDEB ('MPLOGX O', B)
      RETURN
      END
C
      SUBROUTINE MPMDC (A, B, N)
C
C   This converts the MP number A to the DPE form (B, N), accurate to between
C   14 and 17 digits, depending on system.  B will be between 1 and BDX.
C   Debug output starts with IDB = 9.
C
      DOUBLE PRECISION AA, B
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      DIMENSION A(NW+2)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        B = 0.D0
        N = 0
        RETURN
      ENDIF
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPMDC I'/(6F12.0))
      ENDIF
C
      IF (A(1) .EQ. 0.)  THEN
        B = 0.D0
        N = 0
        GOTO 100
      ENDIF
C
      NA = ABS (A(1))
      AA = A(3)
      IF (NA .GE. 2) AA = AA + RDX * A(4)
      IF (NA .GE. 3) AA = AA + RX2 * A(5)
      IF (NA .GE. 4) AA = AA + RDX * RX2 * A(6)
C
      N = NBT * A(2)
      B = SIGN (AA, DBLE (A(1)))
C
 100  IF (IDB .GE. 9) WRITE (LDB, 2) B, N
 2    FORMAT ('MPMDC O',F10.0,I10)
      RETURN
      END
C
      SUBROUTINE MPMMPC (A, B, L, C)
C
C   This converts MP numbers A and B to MPC form in C, i.e. C = A + B i.
C   L (an input parameter) is the offset between real and imaginary parts in
C   C.  Debug output starts with IDB = 10.
C
C   Max SP space for C: 2 * L cells.
C
      DIMENSION A(NW+2), B(NW+2), C(2*L)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        C(L+1) = 0.
        C(L+2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 10) WRITE (LDB, 1)
 1    FORMAT ('MPMMPC')
C
      I1 = SIGN (1., A(1))
      N1 = MIN (INT (ABS (A(1))), NW, L - 2)
      I2 = SIGN (1., B(1))
      N2 = MIN (INT (ABS (B(1))), NW, L - 2)
      C(1) = SIGN (N1, I1)
      C(L+1) = SIGN (N2, I2)
C
      DO 100 I = 2, N1 + 2
        C(I) = A(I)
 100  CONTINUE
C
      DO 110 I = 2, N2 + 2
        C(L+I) = B(I)
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPMOUT (N1, N2, A)
C
C   This produces a compact printout of the N1 x N1 MP array A.  It is called
C   MPINRQ and MPINRZ.  It is not indended to be called directly by the user.
C
      DOUBLE PRECISION T1, T2
      DIMENSION A(NW+4,N1,N2)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      DIMENSION T1(100), I1(100)
C
      IF (IER .NE. 0) RETURN
C
      DO 110 J = 1, N1
        WRITE (LDB, 1) J
 1      FORMAT ('Row', I3)
C
        DO 100 K = 1, N2
          CALL MPMDC (A(1,J,K), T2, M2)
          CALL DPDEC (T2, M2, T1(K), I1(K))
 100    CONTINUE
C
        WRITE (LDB, 2) (T1(K), I1(K), K = 1, N2)
 2      FORMAT (4(F10.6,I6))
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPMPCM (L, A, B, C)
C
C   This converts the MPC number A to its MP real and imaginary parts, i.e.
C   B = Real (A) and C = Imag (A).  L is the offset between real and
C   imaginary parts in A.  Debug output starts with IDB = 10.
C
C   Max SP space for B and C: NW + 2 cells.
C
      DIMENSION A(2*L), B(NW+2), C(NW+2)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 10) WRITE (LDB, 1)
 1    FORMAT ('MPMPCM')
C
      I1 = SIGN (1., A(1))
      N1 = MIN (INT (ABS (A(1))), NW, L - 2)
      I2 = SIGN (1., A(L+1))
      N2 = MIN (INT (ABS (A(L+1))), NW, L - 2)
      B(1) = SIGN (N1, I1)
      C(1) = SIGN (N2, I2)
C
      DO 100 I = 2, N1 + 2
        B(I) = A(I)
 100  CONTINUE
C
      DO 110 I = 2, N2 + 2
        C(I) = A(L+I)
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPMUL (A, B, C)
C
C   This routine multiplies MP numbers A and B to yield the MP product C.
C   When one of the arguments has a much higher level of precision than the
C   other, this routine is slightly more efficient if A has the lower level of
C   precision.  For extra high levels of precision, use MPMULX.  Debug output
C   starts with IDB = 8.
C
C   Max SP space for C: NW + 4 cells.  Max DP scratch space: NW + 4 cells.
C
C   This routine returns up to NW mantissa words of the product.  If the
C   complete double-long product of A and B is desired (for example in large
C   integer applications), then NW must be at least as large as the sum of the
C   mantissa lengths of A and B.  In other words, if the precision levels of A
C   and B are both 64 words, then NW must be at least 128 words to obtain the
C   complete double-long product in C.
C
      DOUBLE PRECISION D, T1, T2, T3
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM4/ D(1024)
      DIMENSION A(NW+2), B(NW+2), C(NW+4)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPMUL I'/(6F12.0))
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 1) (B(I), I = 1, NO)
      ENDIF
C
      IA = SIGN (1., A(1))
      IB = SIGN (1., B(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NB = MIN (INT (ABS (B(1))), NW)
      IF (NA .EQ. 0 .OR. NB .EQ. 0) THEN
C
C   One of the inputs is zero -- result is zero.
C
        C(1) = 0.
        C(2) = 0.
        GOTO 170
      ENDIF
      IF (NA .EQ. 1 .AND. A(3) .EQ. 1.) THEN
C
C   A is 1 or -1 -- result is B or -B.
C
        C(1) = SIGN (NB, IA * IB)
        C(2) = A(2) + B(2)
C
        DO 100 I = 3, NB + 2
          C(I) = B(I)
 100    CONTINUE
C
        GOTO 170
      ELSEIF (NB .EQ. 1 .AND. B(3) .EQ. 1.) THEN
C
C   B is 1 or -1 -- result is A or -A.
C
        C(1) = SIGN (NA, IA * IB)
        C(2) = A(2) + B(2)
C
        DO 110 I = 3, NA + 2
          C(I) = A(I)
 110    CONTINUE
C
        GOTO 170
      ENDIF
C
      NC = MIN (NA + NB, NW)
      D2 = A(2) + B(2)
C
      DO 120 I = 1, NC + 4
        D(I) = 0.D0
 120  CONTINUE
C
C   Perform ordinary long multiplication algorithm.  Accumulate at most NW + 4
C   mantissa words of the product.
C
      DO 150 J = 3, NA + 2
        T1 = A(J)
        J3 = J - 3
        N2 = MIN (NB + 2, NW + 4 - J3)
C
        DO 130 I = 3, N2
          D(I+J3) = D(I+J3) + T1 * B(I)
 130    CONTINUE
C
C   Release carries periodically to avoid overflowing the exact integer
C   capacity of double precision floating point words in D.
C
        IF (MOD (J - 2, NPR) .EQ. 0) THEN
          I1 = MAX (3, J - NPR)
          I2 = N2 + J3
C>
CDIR$ IVDEP
          DO 140 I = I1, I2
            T1 = D(I)
            T2 = INT (RDX * T1)
            T3 = INT (RDX * T2)
            D(I) = T1 - BDX * T2
            D(I-1) = D(I-1) + (T2 - BDX * T3)
            D(I-2) = D(I-2) + T3
 140      CONTINUE
C
        ENDIF
 150  CONTINUE
C
C   If D(2) is nonzero, shift the result one cell right.
C
      IF (D(2) .NE. 0.D0) THEN
        D2 = D2 + 1.
C
CDIR$ IVDEP
        DO 160 I = NC + 4, 3, -1
          D(I) = D(I-1)
 160    CONTINUE
C
      ENDIF
      D(1) = SIGN (NC, IA * IB)
      D(2) = D2
C
C   Fix up result, since some words may be negative or exceed BDX.
C
      CALL MPNORM (C)
C
 170  IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 2) (C(I), I = 1, NO)
 2      FORMAT ('MPMUL O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPMULD (A, B, N, C)
C
C   This routine multiplies the MP number A by the DPE number (B, N) to yield
C   the MP product C.  Debug output starts with IDB = 9.
C
C   Max SP space for C: NW + 4 cells.  Max DP space: NW + 4 cells.
C
      DOUBLE PRECISION B, BB, D
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM3/ S(1024)
      COMMON /MPCOM4/ D(1024)
      DIMENSION A(NW+2), C(NW+4), F(8)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPMULD I'/(6F12.0))
        WRITE (LDB, 2) B, N
 2      FORMAT ('MPMULD I',1PD25.15,I10)
      ENDIF
C
C   Check for zero inputs.
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      IB = SIGN (1.D0, B)
      IF (NA .EQ. 0 .OR. B .EQ. 0.D0) THEN
        C(1) = 0.
        C(2) = 0.
        GOTO 140
      ENDIF
      N1 = N / NBT
      N2 = N - NBT * N1
      BB = ABS (B) * 2.D0 ** N2
C
C   Reduce BB to within 1 and BDX.
C
      IF (BB .GE. BDX) THEN
C
        DO 100 K = 1, 100
          BB = RDX * BB
          IF (BB .LT. BDX) THEN
            N1 = N1 + K
            GOTO 120
          ENDIF
 100    CONTINUE
C
      ELSEIF (BB .LT. 1.D0) THEN
C
        DO 110 K = 1, 100
          BB = BDX * BB
          IF (BB .GE. 1.D0) THEN
            N1 = N1 - K
            GOTO 120
          ENDIF
 110    CONTINUE
C
      ENDIF
C
C   If B cannot be represented exactly in a single mantissa word, use MPMUL.
C
 120  IF (BB .NE. AINT (BB)) THEN
        BB = SIGN (BB, B)
        CALL MPDMC (BB, N1 * NBT, F)
        CALL MPMUL (F, A, C)
        GOTO 140
      ENDIF
C
C   Perform short multiply operation.
C
CDIR$ IVDEP
      DO 130 I = 3, NA + 2
        D(I) = BB * A(I)
 130  CONTINUE
C
C   Set the exponent and fix up the result.
C
      D(1) = SIGN (NA, IA * IB)
      D(2) = A(2) + N1
      D(NA+3) = 0.D0
      D(NA+4) = 0.D0
      CALL MPNORM (C)
C
 140  IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 3) (C(I), I = 1, NO)
 3      FORMAT ('MPMULD O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPMULX (A, B, C)
C
C   This routine multiplies MP numbers A and B to yield the MP product C.
C   Before calling MPMULX, the array in MPCOM5 must be initialized by calling
C   MPINIX.  For modest levels of precision, use MPMUL.  NW should be a power
C   of two.  Debug output starts with IDB = 8.
C
C   Max SP space for C: NW + 4 cells.  Max DP scratch space: 12 * NW + 6 cells.
C   The fact that all advanced routines require this amount of DP scratch
C   space derives from the requirement in this routine, which all of them call.
C
C   This routine returns up to NW mantissa words of the product.  If the
C   complete double-long product of A and B is desired (for example in large
C   integer applications), then NW must be at least as large as the sum of the
C   mantissa lengths of A and B.  In other words, if the precision levels of A
C   and B are both 256 words, then NW must be at least 512 words to obtain the
C   complete double-long product in C.
C
C   This subroutine uses an advanced technique involving the fast Fourier
C   transform (FFT).  For high precision it is significantly faster than the
C   conventional scheme used in MPMUL.
C>
C   Two machine-dependent parameters are set in this routine:
C
C     ERM   Maximum tolerated FFT roundoff error.  On IEEE systems ERM =
C           0.438D0.  It is not necessary to specify ERM for modest levels of
C           precision -- see comments below.
C     MBT   Number of mantissa bits in double precision data.  MBT = 53 on
C           IEEE systems, and MBT = 48 (i.e. single precision) on Crays.
C           It is not necessary to specify MBT for modest levels of precision.
C
      DOUBLE PRECISION AN, CL2, D, ERM, T1, T2, T3, T4
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, ERM = 0.438D0, MBT = 53,   
     $  NDB = 22)
      DIMENSION A(NW+2), B(NW+2), C(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM4/ D(1024)
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 8)  THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPMULX I'/(6F12.0))
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 1) (B(I), I = 1, NO)
      ENDIF
C
      IA = SIGN (1., A(1))
      IB = SIGN (1., B(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NB = MIN (INT (ABS (B(1))), NW)
      NCR = 2 ** MCR
C
      IF (NA .EQ. 0 .OR. NB .EQ. 0) THEN
C
C   One of the inputs is zero -- result is zero.
C
        C(1) = 0.
        C(2) = 0.
        GOTO 190
      ENDIF
C
C   Check if precision level of one of the arguments is too low to justify the
C   advanced routine.
C
      IF (NA .LE. NCR .OR. NB .LE. NCR) THEN
        CALL MPMUL (A, B, C)
        GOTO 190
      ENDIF
C
C   Determine N1, the smallest power of two at least as large as NA and NB.
C
      T1 = NA
      T2 = NB
      M1 = CL2 * LOG (T1) + 1.D0 - RXX
      M2 = CL2 * LOG (T2) + 1.D0 - RXX
      M1 = MAX (M1, M2)
      N1 = 2 ** M1
      M2 = M1 + 2
      N2 = 2 * N1
      N4 = 2 * N2
      N6 = 3 * N2
      N8 = 4 * N2
      N21 = N2 + 1
      N42 = N4 + 2
      N63 = N6 + 3
      N84 = N8 + 4
C
C   Place the input data in A and B into separate sections of the scratch
C   array D.  This code also splits the input data into half-sized words.
C>
CDIR$ IVDEP
      DO 100 I = 1, NA
        T1 = A(I+2)
        T2 = INT (RBX * T1)
        D(2*I-1) = T2
        D(2*I) = T1 - BBX * T2
 100  CONTINUE
C
      DO 110 I = 2 * NA + 1, N2
        D(I) = 0.D0
 110  CONTINUE
C>
CDIR$ IVDEP
      DO 120 I = 1, NB
        T1 = B(I+2)
        T2 = INT (RBX * T1)
        D(2*I-1+N42) = T2
        D(2*I+N42) = T1 - BBX * T2
 120  CONTINUE
C
      DO 130 I = 2 * NB + 1, N2
        D(I+N42) = 0.D0
 130  CONTINUE
C
C   Set the second half of each input vector in D to zero.
C
CDIR$ IVDEP
      DO 140 I = N2 + 1, N4
        D(I) = 0.D0
        D(I+N42) = 0.D0
 140  CONTINUE
C
C   Perform forward real-to-complex FFTs on the two vectors in D.  The complex
C   results are placed in (D(I), I = 1, N4+2) and (D(I), I = N4 + 3, N8 + 4).
C
      CALL MPRCFT (1, M2, D, D(N84+1))
      CALL MPRCFT (1, M2, D(N42+1), D(N84+1))
C
C   Multiply the resulting complex vectors.
C
CDIR$ IVDEP
      DO 150 I = 1, N21
        T1 = D(I)
        T2 = D(I+N21)
        T3 = D(I+N42)
        T4 = D(I+N63)
        D(I+N42) = T1 * T3 - T2 * T4
        D(I+N63) = T1 * T4 + T2 * T3
 150  CONTINUE
C
C   Perform an inverse complex-to-real FFT on the resulting data.
C
      CALL MPCRFT (-1, M2, D(N42+1), D(N84+1))
C
C   Divide by N8, recombine words and release carries.
C
      NC = MIN (NA + NB, NW)
      NC1 = MIN (NW + 1, NA + NB - 1)
      D(1) = SIGN (NC, IA * IB)
      D(2) = A(2) + B(2) + 1
      AN = 1.D0 / N8
      T1 = AN * D(N42+1)
      D(3) = AINT (T1 + 0.5D0)
      D(NC+3) = 0.D0
      D(NC+4) = 0.D0
      D(N42+1) = 0.D0
C>
CDIR$ IVDEP
      DO 160 I = 1, NC1
        T1 = AN * D(N42+2*I)
        T2 = AN * D(N42+2*I+1)
        T3 = AINT (T1 + 0.5D0)
        T4 = AINT (T2 + 0.5D0)
C        D(N42+2*I) = ABS (T3 - T1)
C        D(N42+2*I+1) = ABS (T4 - T2)
        T1 = INT (RDX * T3)
        T2 = T3 - BDX * T1
        T3 = INT (RDX * T4)
        T4 = T4 - BDX * T3
        D(I+3) = BBX * T2 + T4
        D(I+2) = D(I+2) + BBX * T1 + T3
 160  CONTINUE
C
C   Find the largest FFT roundoff error.  Roundoff error is minimal unless
C   exceedingly high precision (i.e. over one million digits) is used.  Thus
C   this test may be disabled in normal use.  To disable this test, uncomment
C   the next line of code.  Also, if this test is diabled, the two lines of
C   the previous loop that begin D(N42) may be commented out.
C
C   This code can be used as a rigorous system integrity test.  First set
C   MBT according to the system being used, and then set ERM to be fairly
C   small, say 0.001 or whatever is somewhat larger than the largest FFT
C   roundoff error typically encountered for a given precision level on the
C   computer being used.  Enable this test as explained in the previous
C   paragraph.  Then if an anomalously large roundoff error is detected, a
C   hardware or compiler error has likely occurred.
C
      GOTO 180
      T1 = 0.D0
C
      DO 170 I = 1, 2 * NC1 + 1
        IF (D(N42+I) .GT. T1) THEN
          I1 = I
          T1 = D(N42+I)
        ENDIF
 170  CONTINUE
C
C   Check if maximum roundoff error exceeds the limit ERM, which is set above.
C   Also determine the number of fractional bits and how large the error is in
C   terms of units in the last place (ulp).
C
      IF (T1 .GT. ERM)  THEN
        IF (KER(55) .NE. 0) THEN
          T2 = AN * D(I1)
          I2 = CL2 * LOG (T1) + 1.D0 + RXX
          I3 = CL2 * LOG (T2) + 1.D0 + RXX
          I4 = MBT + I2 - I3
          I5 = T1 * 2 ** I4 + RXX
          WRITE (LDB, 2) I1, T1, I4, I5
 2        FORMAT ('*** MPMULX: Excessive FFT roundoff error',I10,F10.6, 
     $      2I6)
          IER = 55
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
      ENDIF
C
C   Fix up the result.
C
 180  CALL MPNORM (C)
C
 190  IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (C(1))), NDB) + 2
        WRITE (LDB, 3) (C(I), I = 1, NO)
 3      FORMAT ('MPMULX O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPNINT (A, B)
C
C   This sets B equal to the integer nearest to the MP number A.  Debug output
C   starts with IDB = 8.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: NW + 4 cells.
C
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      DIMENSION A(NW+2), B(NW+2), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPNINT I'/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      MA = A(2)
      IF (NA .EQ. 0)  THEN
C
C   A is zero -- result is zero.
C
        B(1) = 0.
        B(2) = 0.
        GOTO 110
      ENDIF
      IF (MA .GE. NW) THEN
C
C   A cannot be represented exactly as an integer.
C
        IF (KER(56) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPNINT: Argument is too large.')
          IER = 56
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      NS = NW + 4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      F(1) = 1.
      F(2) = -1.
      F(3) = 0.5D0 * BDX
C
C   Add or subtract 1/2 from the input, depending on its sign.
C
      IF (IA .EQ. 1) THEN
        CALL MPADD (A, F, S(K0))
      ELSE
        CALL MPSUB (A, F, S(K0))
      ENDIF
      IC = SIGN (1., S(K0))
      NC = ABS (S(K0))
      MC = S(K0+1)
C
C   Place integer part of S in B.
C
      NB = MIN (MAX (MC + 1, 0), NC)
      IF (NB .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
      ELSE
        B(1) = SIGN (NB, IC)
        B(2) = MC
        B(NB+3) = 0.
        B(NB+4) = 0.
C
        DO 100 I = 3, NB + 2
          B(I) = S(I+K0-1)
 100    CONTINUE
C
      ENDIF
      ICS = ISS
C
 110  IF (IDB .GE. 8) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPNINT O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPNORM (A)
C
C   This converts the MP number in array D of MPCOM4 to the standard
C   normalized form in A.  The MP routines often leave negative numbers or
C   values exceeding the radix BDX in result arrays, and this fixes them.
C   MPNORM assumes that two extra mantissa words are input at the end of D.
C   This reduces precision loss when it is necessary to shift the result to
C   the left.  This routine is not intended to be called directly by the user.
C   The output is placed in the SP array A.  Debug output starts with IDB = 10.
C
C   Max SP space for A: NW + 4 cells.
C
      DOUBLE PRECISION D, R1, S1, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM4/ D(1024)
      DIMENSION A(NW+4)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 10) THEN
        NO = MIN (INT (ABS (D(1))), NDB) + 4
        WRITE (LDB, 1) (D(I), I = 1, NO)
 1      FORMAT ('MPNORM I'/(4F18.0))
      ENDIF
C
      IA = SIGN (1.D0, D(1))
      NA = MIN (INT (ABS (D(1))), NW)
      IF (NA .EQ. 0)  GOTO 170
      N4 = NA + 4
      A2 = D(2)
      D(2) = 0.D0
      R1 = 2.D0 + 0.125D0 * RDX
C>
C   Try a vectorized fixup loop three times, unless A is very short.  This
C   should handle 99% of the inputs.  On scalar computers, it is more
C   efficient to completely bypass this loop, by uncommenting the next line.
C
      GOTO 120
      IF (NA .LE. 8) GOTO 120
C
      DO 110 K = 1, 3
        S1 = 0.D0
C>
CDIR$ IVDEP
        DO 100 I = 3, N4
          T1 = INT (D(I) * RDX + R1) - 2.D0
          D(I) = D(I) - T1 * BDX
          D(I-1) = D(I-1) + T1
          S1 = S1 + ABS (T1)
 100    CONTINUE
C
        IF (S1 .EQ. 0.D0) GOTO 140
 110  CONTINUE
C
C   Still not fixed - use recursive loop.  This loop is not vectorizable,
C   but it is guaranteed to complete the job in one pass.
C
 120  T1 = 0.D0
C>
      DO 130 I = N4, 3, -1
        T2 = T1 + D(I)
        T1 = INT (T2 * RDX + R1) - 2.D0
        D(I) = T2 - T1 * BDX
 130  CONTINUE
C
      D(2) = D(2) + T1
C
 140  IF (D(2) .NE. 0.) THEN
C
C   The fixup loops above "spilled" a nonzero number into D(2).  Shift the
C   entire number right one cell.  The exponent and length of the result
C   are increased by one.
C
        DO 150 I = N4, 3, -1
          A(I) = D(I-1)
 150    CONTINUE
C
        NA = MIN (NA + 1, NW)
        A2 = A2 + 1.
      ELSE
C
        DO 160 I = 3, N4
          A(I) = D(I)
 160    CONTINUE
C
      ENDIF
C
C   Perform rounding and truncation.
C
      A(1) = SIGN (NA, IA)
      A(2) = A2
      CALL MPROUN (A)
C
 170  IF (IDB .GE. 10) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 2) (A(I), I = 1, NO)
 2      FORMAT ('MPNORM O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPNPWR (A, N, B)
C
C   This computes the N-th power of the MP number A and returns the MP result
C   in B.  When N is zero, 1 is returned.  When N is negative, the reciprocal
C   of A ^ |N| is returned.  For extra high levels of precision, use MPNPWX.
C   Debug output starts with IDB = 7.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 2 * NW + 10
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   This routine employs the binary method for exponentiation.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22)
      DIMENSION A(NW+2), B(NW+4), F1(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) N, (A(I), I = 1, NO)
 1      FORMAT ('MPNPWR I',I5/(6F12.0))
      ENDIF
C
      NA = MIN (INT (ABS (A(1))), NW)
      IF (NA .EQ. 0) THEN
        IF (N .GE. 0) THEN
          B(1) = 0.
          B(2) = 0.
          GOTO 120
        ELSE
          IF (KER(57) .NE. 0) THEN
            WRITE (LDB, 2)
 2          FORMAT ('*** MPNPWR: Argument is zero and N is negative or',
     $        ' zero.')
            IER = 57
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ENDIF
C
      N5 = NW + 5
      NS = 2 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      NWS = NW
      NW = NW + 1
      NN = ABS (N)
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      IF (NN .EQ. 0) THEN
        CALL MPEQ (F1, B)
        NW = NWS
        ICS = ISS
        GOTO 120
      ELSEIF (NN .EQ. 1) THEN
        CALL MPEQ (A, B)
        GOTO 110
      ELSEIF (NN .EQ. 2) THEN
        CALL MPMUL (A, A, S(K0))
        CALL MPEQ (S(K0), B)
        GOTO 110
      ENDIF
C
C   Determine the least integer MN such that 2 ^ MN .GT. NN.
C
      T1 = NN
      MN = CL2 * LOG (T1) + 1.D0 + RXX
      CALL MPEQ (F1, B)
      CALL MPEQ (A, S(K0))
      KN = NN
C
C   Compute B ^ N using the binary rule for exponentiation.
C
      DO 100 J = 1, MN
        KK = KN / 2
        IF (KN .NE. 2 * KK) THEN
          CALL MPMUL (B, S(K0), S(K1))
          CALL MPEQ (S(K1), B)
        ENDIF
        KN = KK
        IF (J .LT. MN) THEN
          CALL MPMUL (S(K0), S(K0), S(K1))
          CALL MPEQ (S(K1), S(K0))
        ENDIF
 100  CONTINUE
C
C   Compute reciprocal if N is negative.
C
 110  IF (N .LT. 0) THEN
        CALL MPDIV (F1, B, S(K0))
        CALL MPEQ (S(K0), B)
      ENDIF
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (B)
C
 120  IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPNPWR O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPNPWX (A, N, B)
C
C   This computes the N-th power of the MP number A and returns the MP result
C   in B.  When N is zero, 1 is returned.  When N is negative, the reciprocal
C   of A ^ |N| is returned.  Before calling MPNPWX, the array in MPCOM5 must
C   be initialized by calling MPINIX.  For modest levels of precision, use
C   MPNPWR.  NW should be a power of two.  The last two words of the result
C   are not reliable.  Debug output starts with IDB = 6.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 4 * NW + 16
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine employs the binary method for exponentiation.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22)
      DIMENSION A(NW+2), B(NW+4), F1(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) N, (A(I), I = 1, NO)
 1      FORMAT ('MPNPWX I',I5/(6F12.0))
      ENDIF
C
      NCR = 2 ** MCR
      NA = MIN (INT (ABS (A(1))), NW)
C
C   Check if precision level of A is too low to justify the advanced routine.
C
      IF (NA .LE. NCR) THEN
        CALL MPNPWR (A, N, B)
        GOTO 120
      ENDIF
      IF (NA .EQ. 0) THEN
        IF (N .GE. 0) THEN
          B(1) = 0.
          B(2) = 0.
          GOTO 120
        ELSE
          IF (KER(58) .NE. 0) THEN
            WRITE (LDB, 2)
 2          FORMAT ('*** MPNPWX: argument is zero and N is negative or',
     $        ' zero.')
            IER = 58
            IF (KER(IER) .EQ. 2) CALL MPABRT
          ENDIF
          RETURN
        ENDIF
      ENDIF
C
      N4 = NW + 4
      NS = 2 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      NN = ABS (N)
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      IF (NN .EQ. 0) THEN
        CALL MPEQ (F1, B)
        ICS = ISS
        GOTO 120
      ELSEIF (NN .EQ. 1) THEN
        CALL MPEQ (A, B)
        GOTO 110
      ELSEIF (NN .EQ. 2) THEN
        CALL MPMULX (A, A, B)
        GOTO 110
      ENDIF
C
C   Determine the least integer MN such that 2 ^ MN .GT. NN.
C
      T1 = NN
      MN = CL2 * LOG (T1) + 1.D0 + RXX
      CALL MPEQ (F1, B)
      CALL MPEQ (A, S(K0))
      KN = NN
C
C   Compute B ^ N using the binary rule for exponentiation.
C
      DO 100 J = 1, MN
        KK = KN / 2
        IF (KN .NE. 2 * KK) THEN
          CALL MPMULX (B, S(K0), S(K1))
          CALL MPEQ (S(K1), B)
        ENDIF
        KN = KK
        IF (J .LT. MN) THEN
          CALL MPMULX (S(K0), S(K0), S(K1))
          CALL MPEQ (S(K1), S(K0))
        ENDIF
 100  CONTINUE
C
C   Compute reciprocal if N is negative.
C
 110  IF (N .LT. 0) THEN
        CALL MPDIVX (F1, B, S(K0))
        CALL MPEQ (S(K0), B)
      ENDIF
      ICS = ISS
C
 120  IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPNPWX O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPNRT (A, N, B)
C
C   This computes the N-th root of the MP number A and returns the MP result
C   in B.  N must be at least one and must not exceed 2 ^ 30.  For extra high
C   levels of precision, use MPNRTX.  Debug output starts with IDB = 7.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 6 * NW + 32
C   cells.  Max DP scratch space: NW + 6 cells.
C
C   This subroutine employs the following Newton-Raphson iteration, which
C   converges to A ^ (-1/N):
C
C          X_{k+1} = X_k + (X_k / N) * (1 - A * X_k^N)
C
C   The reciprocal of the final approximation to A ^ (-1/N) is the N-th root.
C   These iterations are performed with a maximum precision level NW that
C   is dynamically changed, approximately doubling with each iteration.
C   See the comment about the parameter NIT in MPDIVX.
C
C   When N is large and A is very near one, the following binomial series is
C   employed instead of the Newton scheme:
C
C       (1 + x)^(1/N)  =  1  +  x / N  +  x^2 * (1 - N) / (2! N^2)  +  ...
C
      DOUBLE PRECISION CL2, T1, T2, TN
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 3,         
     $  N30 = 2 ** 30)
      DIMENSION A(NW+2), B(NW+4), F1(8), F2(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) N, (A(I), I = 1, NO)
 1      FORMAT ('MPNRT I',I5/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
C
      IF (NA .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 140
      ENDIF
      IF (IA .LT. 0) THEN
        IF (KER(59) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPNRT: Argument is negative.')
          IER = 59
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
      IF (N .LE. 0 .OR. N .GT. N30) THEN
        IF (KER(60) .NE. 0) THEN
          WRITE (LDB, 3) N
 3        FORMAT ('*** MPNRT: Improper value of N',I10)
          IER = 60
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   If N = 1, 2 or 3, call MPEQ, MPSQRT or MPCBRT.  These are faster.
C
      IF (N .EQ. 1) THEN
        CALL MPEQ (A, B)
        GOTO 140
      ELSEIF (N .EQ. 2) THEN
        CALL MPSQRT (A, B)
        GOTO 140
      ELSEIF (N .EQ. 3) THEN
        CALL MPCBRT (A, B)
        GOTO 140
      ENDIF
C
      N5 = NW + 5
      NS = 4 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      NWS = NW
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Check how close A is to 1.
C
      CALL MPSUB (A, F1, S(K0))
      IF (S(K0) .EQ. 0.) THEN
        CALL MPEQ (F1, B)
        ICS = ISS
        GOTO 140
      ENDIF
      CALL MPMDC (S(K0), T1, N1)
      N2 = CL2 * LOG (ABS (T1))
      T1 = T1 * 0.5D0 ** N2
      N1 = N1 + N2
      IF (N1 .LE. -30) THEN
        T2 = N
        N2 = CL2 * LOG (T2) + 1.D0 + RXX
        N3 = - NBT * NW / N1
        IF (N3 .LT. 1.25 * N2) THEN
C
C   A is so close to 1 that it is cheaper to use the binomial series.
C
          NW = NW + 1
          CALL MPDIVD (S(K0), T2, 0, S(K1))
          CALL MPADD (F1, S(K1), S(K2))
          K = 0
C
 100      K = K + 1
          T1 = 1 - K * N
          T2 = (K + 1) * N
          CALL MPMULD (S(K1), T1, 0, S(K3))
          CALL MPDIVD (S(K3), T2, 0, S(K1))
          CALL MPMUL (S(K0), S(K1), S(K3))
          CALL MPEQ (S(K3), S(K1))
          CALL MPADD (S(K1), S(K2), S(K3))
          CALL MPEQ (S(K3), S(K2))
          IF (S(K1) .NE. 0. .AND. S(K1+1) .GE. - NW) GOTO 100
C
          CALL MPEQ (S(K2), B)
          CALL MPDIV (F1, S(K2), S(K0))
          GOTO 130
        ENDIF
      ENDIF
C
C   Compute the initial approximation of A ^ (-1/N).
C
      TN = N
      CALL MPMDC (A, T1, N1)
      N2 = - N1 / TN
      T2 = (T1 * 2.D0 ** (N1 + TN * N2)) ** (- 1.D0 / TN)
      CALL MPDMC (T2, N2, B)
      CALL MPDMC (TN, 0, F2)
      NW = 3
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (one greater than powers of two).
C
      DO 120 K = 2, MQ
        NW = MIN (2 * NW - 2, NWS) + 1
 110    CONTINUE
        CALL MPNPWR (B, N, S(K0))
        CALL MPMUL (A, S(K0), S(K1))
        CALL MPSUB (F1, S(K1), S(K0))
        CALL MPMUL (B, S(K0), S(K1))
        CALL MPDIVD (S(K1), TN, 0, S(K0))
        CALL MPADD (B, S(K0), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 110
        ENDIF
 120  CONTINUE
C
C   Take the reciprocal to give final result.
C
      CALL MPDIV (F1, B, S(K1))
      CALL MPEQ (S(K1), B)
C
C   Restore original precision level.
C
 130  NW = NWS
      ICS = ISS
      CALL MPROUN (B)
C
 140  IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 4) (B(I), I = 1, NO)
 4      FORMAT ('MPNRT O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPNRTX (A, N, B)
C
C   This computes the N-th root of the MP number A and returns the MP result
C   in B.  N must be at least one and must not exceed 2 ^ 30.  Before calling
C   MPNRTX, the array in MPCOM5 must be initialized by calling MPINIX.  For
C   modest levels of precision, use MPNRT.  NW should be a power of two.  The
C   last three words of the result are not reliable.  Debug output starts with
C   IDB = 6.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 7 * NW + 48
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine uses basically the same Newton iteration algorithm as MPNRT.
C   In fact, this routine calls MPNRT to obtain an initial approximation.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION CL2, T1, T2, TN
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1,         
     $  N30 = 2 ** 30)
      DIMENSION A(NW+2), B(NW+4), F1(8), F2(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) N, (A(I), I = 1, NO)
 1      FORMAT ('MPNRTX I',I5/(6F12.0))
      ENDIF
C
      NCR = 2 ** MCR
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
C
      IF (NA .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 140
      ENDIF
      IF (IA .LT. 0) THEN
        IF (KER(61) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPNRTX: Argument is negative.')
          IER = 61
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
      IF (N .LE. 0 .OR. N .GT. N30) THEN
        IF (KER(62) .NE. 0) THEN
          WRITE (LDB, 3) N
 3        FORMAT ('*** MPNRTX: Improper value of N',I10)
          IER = 62
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPNRT (A, N, B)
        GOTO 140
      ENDIF
C
C   If N = 1, 2 or 3, call MPEQ, MPSQRX or MPCBRX.  These are faster.
C
      IF (N .EQ. 1) THEN
        CALL MPEQ (A, B)
        GOTO 140
      ELSEIF (N .EQ. 2) THEN
        CALL MPSQRX (A, B)
        GOTO 140
      ELSEIF (N .EQ. 3) THEN
        CALL MPCBRX (A, B)
        GOTO 140
      ENDIF
C
      N4 = NW + 4
      NS = 4 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      NWS = NW
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Check how close A is to 1.
C
      CALL MPSUB (A, F1, S(K0))
      IF (S(K0) .EQ. 0.) THEN
        CALL MPEQ (F1, B)
        GOTO 130
      ENDIF
      CALL MPMDC (S(K0), T1, N1)
      N2 = CL2 * LOG (ABS (T1))
      T1 = T1 * 0.5D0 ** N2
      N1 = N1 + N2
      IF (N1 .LE. -30) THEN
        T2 = N
        N2 = CL2 * LOG (T2) + 1.D0 + RXX
        N3 = - NBT * NW / N1
        IF (N3 .LT. 1.25 * N2) THEN
C
C   A is so close to 1 that it is cheaper to use the binomial series.
C
          CALL MPDIVD (S(K0), T2, 0, S(K1))
          CALL MPADD (F1, S(K1), S(K2))
          K = 0
C
 100      K = K + 1
          T1 = 1 - K * N
          T2 = (K + 1) * N
          CALL MPMULD (S(K1), T1, 0, S(K3))
          CALL MPDIVD (S(K3), T2, 0, S(K1))
          CALL MPMULX (S(K0), S(K1), S(K3))
          CALL MPEQ (S(K3), S(K1))
          CALL MPADD (S(K1), S(K2), S(K3))
          CALL MPEQ (S(K3), S(K2))
          IF (S(K1) .NE. 0. .AND. S(K1+1) .GE. - NW) GOTO 100
C
          CALL MPEQ (S(K2), B)
          GOTO 130
        ENDIF
      ENDIF
C
C   Compute the initial approximation of A ^ (-1/N).
C
      NW = NCR
      CALL MPNRT (A, N, S(K0))
      CALL MPDIV (F1, S(K0), B)
      TN = N
      CALL MPDMC (TN, 0, F2)
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (powers of two).
C
      DO 120 K = MCR + 1, MQ
        AN = NW
        NW = MIN (2 * NW, NWS)
 110    CONTINUE
        CALL MPNPWX (B, N, S(K0))
        CALL MPMULX (A, S(K0), S(K1))
        CALL MPSUB (F1, S(K1), S(K0))
        S(K1) = MIN (S(K1), AN)
        CALL MPMULX (B, S(K0), S(K1))
        CALL MPDIVD (S(K1), TN, 0, S(K0))
        CALL MPADD (B, S(K0), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 110
        ENDIF
 120  CONTINUE
C
C   Take the reciprocal to give final result.
C
      CALL MPDIVX (F1, B, S(K0))
      CALL MPEQ (S(K0), B)
C
 130  ICS = ISS
C
 140  IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 4) (B(I), I = 1, NO)
 4      FORMAT ('MPNRTX O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPOUT (IU, A, LA, CS)
C
C   This routine writes the exponent plus LA mantissa digits of the MP number
C   A to logical unit IU.  CS is a scratch array of type CHARACTER*1.  CS must
C   be dimensioned at least LA + 25.  The digits of A may span more than one
C   line.  A comma is placed at the end of the last line to denote the end of
C   the MP number.  Here is an example of the output:
C
C   10 ^        -4 x  3.14159265358979323846264338327950288419716939937510,
C
C   Max SP scratch space: 4 * NW + 22 cells.
C
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      CHARACTER*1 CS(LA+25)
      DIMENSION A(NW+2)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) RETURN
C
      NWS = NW
      LL = LA / LOG10 (BDX) + 1.D0
      NW = MIN (NW, LL)
      CALL MPOUTC (A, CS, L)
      NW = NWS
      L = MIN (L, LA + 20) + 1
      CS(L) = ','
      WRITE (IU, '(78A1)') (CS(I), I = 1, L)
C
      RETURN
      END
C
      SUBROUTINE MPOUTC (A, B, N)
C
C   Converts the MP number A into character form in the CHARACTER*1 array B.
C   N (an output parameter) is the length of the output.  In other words, B is
C   contained in B(1), ..., B(N).  The format is analogous to the Fortran
C   exponential format (E format), except that the exponent is placed first.
C   Debug output starts with IDB = 7.
C
C   Max CHARACTER*1 space for B: 7.225 * NW + 30 cells.  Max SP scratch space:
C   4 * NW + 22 cells.
C
C   This routine is called by MPOUT, but it may be directly called by the user
C   if desired for custom output.  Example:
C
C      CHARACTER*1 CX(800)
C      CALL MPOUTC (A, CX, ND)
C      WRITE (1, '(20A1/(72A1))') (CX(I), I = 1, ND)
C
      DOUBLE PRECISION AA, AL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      CHARACTER*1 B
      CHARACTER*16 CA
      PARAMETER (AL2 = 0.301029995663981195D0, CON = 0.8304820235D0,    
     $  NDB = 22)
      DIMENSION A(NW+2), B(6*NW+20), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = ' '
        N = 0
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPOUTC I'/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      N5 = NW + 5
      NS = 2 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      NWS = NW
      NW = NW + 1
      F(1) = 1.
      F(2) = 0.
      F(3) = 10.
C
C   Determine exact power of ten for exponent.
C
      IF (NA .NE. 0) THEN
        AA = A(3)
        IF (NA .GE. 2) AA = AA + RDX * A(4)
        IF (NA .GE. 3) AA = AA + RX2 * A(5)
        IF (NA .GE. 4) AA = AA + RDX * RX2 * A(6)
        T1 = AL2 * NBT * A(2) + LOG10 (AA)
        IF (T1 .GE. 0.D0) THEN
          NX = T1
        ELSE
          NX = T1 - 1.D0
        ENDIF
        CALL MPNPWR (F, NX, S(K0))
        CALL MPDIV (A, S(K0), S(K1))
C
C   If we didn't quite get it exactly right, multiply or divide by 10 to fix.
C
 100    IF (S(K1+1) .LT. 0.) THEN
          NX = NX - 1
          CALL MPMULD (S(K1), 10.D0, 0, S(K0))
          CALL MPEQ (S(K0), S(K1))
          GOTO 100
        ELSEIF (S(K1+2) .GE. 10.) THEN
          NX = NX + 1
          CALL MPDIVD (S(K1), 10.D0, 0, S(K0))
          CALL MPEQ (S(K0), S(K1))
          GOTO 100
        ENDIF
        S(K1) = ABS (S(K1))
      ELSE
        NX = 0
      ENDIF
C
C   Place exponent first instead of at the very end as in Fortran.
C
      B(1) = '1'
      B(2) = '0'
      B(3) = ' '
      B(4) = '^'
      WRITE (CA, '(I10)') NX
C
      DO 110 I = 1, 10
        B(I+4) = CA(I:I)
 110  CONTINUE
C
      B(15) = ' '
      B(16) = 'x'
      B(17) = ' '
C
C   Insert sign and first digit.
C
      IF (IA .EQ. -1) THEN
        B(18) = '-'
      ELSE
        B(18) = ' '
      ENDIF
      IF (NA .NE. 0) THEN
        NN = S(K1+2)
      ELSE
        NN = 0
      ENDIF
      WRITE (CA, '(I1)') NN
      B(19) = CA(1:1)
      B(20) = '.'
      IX = 20
      IF (NA .EQ. 0) GOTO 190
      F(3) = NN
      CALL MPSUB (S(K1), F, S(K0))
      IF (S(K0) .EQ. 0) GOTO 190
      CALL MPMULD (S(K0), 1.D6, 0, S(K1))
      NL = MAX (NW * LOG10 (BDX) / 6.D0 - 1.D0, 1.D0)
C
C   Insert the digits of the remaining words.
C
      DO 130 J = 1, NL
        IF (S(K1+1) .EQ. 0.) THEN
          NN = S(K1+2)
          F(1) = 1.
          F(3) = NN
        ELSE
          F(1) = 0.
          NN = 0
        ENDIF
        WRITE (CA, '(I6.6)') NN
C
        DO 120 I = 1, 6
          B(I+IX) = CA(I:I)
 120    CONTINUE
C
        IX = IX + 6
        CALL MPSUB (S(K1), F, S(K0))
        CALL MPMULD (S(K0), 1.D6, 0, S(K1))
        IF (S(K1) .EQ. 0.) GOTO 140
 130  CONTINUE
C
C   Check if trailing zeroes should be trimmed.
C
      J = NL + 1
C
 140  L = IX
      IF (B(L) .EQ. '0' .OR. (J .GT. NL .AND. B(L-1) .EQ. '0' .AND.     
     $  B(L-2) .EQ. '0' .AND. B(L-3) .EQ. '0' .AND. B(L-4) .EQ. '0'))   
     $  THEN
        B(L) = ' '
C
        DO 150 I = L - 1, 21, -1
          IF (B(I) .NE. '0') THEN
            IX = I
            GOTO 190
          ENDIF
          B(I) = ' '
 150    CONTINUE
C
        IX = 20
C
C   Check if trailing nines should be rounded up.
C
      ELSEIF (J .GT. NL .AND. B(L-1) .EQ. '9' .AND. B(L-2) .EQ. '9'     
     $    .AND. B(L-3) .EQ. '9' .AND. B(L-4) .EQ. '9') THEN
        B(L) = ' '
C
        DO 160 I = L - 1, 21, -1
          IF (B(I) .NE. '9') GOTO 180
          B(I) = ' '
 160    CONTINUE
C
C   We have rounded away all digits to the right of the decimal point, and the
C   digit to the left of the digit is a 9.  Set the digit to 1 and increase
C   the exponent by one.
C
        IX = 20
        IF (B(19) .EQ. '9') THEN
          B(19) = '1'
          WRITE (CA, '(I10)') NX + 1
C
          DO 170 I = 1, 10
            B(I+4) = CA(I:I)
 170      CONTINUE
C
        ELSE
          CA = B(19)
          READ (CA, '(I1)') NN
          WRITE (CA, '(I1)') NN + 1
          B(19) = CA(1:1)
        ENDIF
        GOTO 190
C
 180    CA = B(I)
        READ (CA, '(I1)') NN
        WRITE (CA, '(I1)') NN + 1
        B(I) = CA(1:1)
        IX = I
      ENDIF
C
 190  N = IX
      NW = NWS
      ICS = ISS
      IF (IDB .GE. 7) THEN
        NO = MIN (N, 6 * NDB + 20)
        WRITE (LDB, 2) (B(I), I = 1, NO)
 2      FORMAT ('MPOUTC O'/(78A1))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPPI (PI)
C
C   This computes Pi to available precision (NW mantissa words).  For extra
C   high levels of precision, use MPPIX.  Debug output starts with IDB = 7.
C
C   Max SP space for PI: NW + 4 cells.  Max SP scratch space: 7 * NW + 37
C   cells.  Max DP scratch space: NW + 6 cells.
C
C   The algorithm that is used for computing Pi, which is due to Salamin
C   and Brent, is as follows:
C
C   Set  A_0 = 1,  B_0 = 1/Sqrt(2)  and  D_0 = Sqrt(2) - 1/2.
C
C   Then from k = 1 iterate the following operations:
C
C      A_k = 0.5 * (A_{k-1} + B_{k-1})
C      B_k = Sqrt (A_{k-1} * B_{k-1})
C      D_k = D_{k-1} - 2^k * (A_k - B_k) ^ 2
C
C   Then  P_k = (A_k + B_k) ^ 2 / D_k  converges quadratically to Pi.
C   In other words, each iteration approximately doubles the number of correct
C   digits, providing all iterations are done with the maximum precision.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0)
      DIMENSION F(8), PI(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        PI(1) = 0.
        PI(2) = 0.
        RETURN
      ENDIF
C
C   Perform calculations to one extra word accuracy.
C
      N5 = NW + 5
      NS = 5 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      K4 = K3 + N5
      NWS = NW
      NW = NW + 1
C
C   Determine the number of iterations required for the given precision level.
C   This formula is good only for this Pi algorithm.
C
      T1 = NWS * LOG10 (BDX)
      MQ = CL2 * (LOG (T1) - 1.D0) + 1.D0
C
C  Initialize as above.
C
      S(K0) = 1.
      S(K0+1) = 0.
      S(K0+2) = 1.
      F(1) = 1.
      F(2) = 0.
      F(3) = 2.
      CALL MPSQRT (F, S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, S(K1))
      F(2) = -1.
      F(3) = 0.5D0 * BDX
      CALL MPSUB (S(K2), F, S(K4))
C
C   Perform iterations as described above.
C
      DO 100 K = 1, MQ
        CALL MPADD (S(K0), S(K1), S(K2))
        CALL MPMUL (S(K0), S(K1), S(K3))
        CALL MPSQRT (S(K3), S(K1))
        CALL MPMULD (S(K2), 0.5D0, 0, S(K0))
        CALL MPSUB (S(K0), S(K1), S(K2))
        CALL MPMUL (S(K2), S(K2), S(K3))
        T1 = 2.D0 ** K
        CALL MPMULD (S(K3), T1, 0, S(K2))
        CALL MPSUB (S(K4), S(K2), S(K3))
        CALL MPEQ (S(K3), S(K4))
 100  CONTINUE
C
C   Complete computation.
C
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPMUL (S(K2), S(K2), S(K3))
      CALL MPDIV (S(K3), S(K4), S(K2))
      CALL MPEQ (S(K2), PI)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (PI)
C
      IF (IDB .GE. 7) CALL MPDEB ('MPPI O', PI)
      RETURN
      END
C
      SUBROUTINE MPPIX (PI)
C
C   This computes Pi to available precision (NW mantissa words).  Before
C   calling MPPIX, the array in MPCOM5 must be initialized by calling MPINIX.
C   For modest levels of precision, use MPPI.  NW should be a power of two.
C   The last three words of the result are not reliable.  Debug output starts
C   with IDB = 7.
C
C   Max SP space for PI: NW + 4 cells.  Max SP scratch space: 8 * NW + 38
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine uses basically the same algorithm as MPPI.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0)
      DIMENSION F(8), PI(NW+4)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        PI(1) = 0.
        PI(2) = 0.
        RETURN
      ENDIF
      NCR = 2 ** MCR
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPPI (PI)
        GOTO 110
      ENDIF
      N4 = NW + 4
      NS = 5 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      K4 = K3 + N4
C
C   Determine the number of iterations required for the given precision level.
C   This formula is good only for this Pi algorithm.
C
      T1 = NW * LOG10 (BDX)
      MQ = CL2 * (LOG (T1) - 1.D0) + 1.D0
C
C  Initialize as above.
C
      S(K0) = 1.
      S(K0+1) = 0.
      S(K0+2) = 1.
      F(1) = 1.
      F(2) = 0.
      F(3) = 2.
      CALL MPSQRX (F, S(K2))
      CALL MPMULD (S(K2), 0.5D0, 0, S(K1))
      F(2) = -1.
      F(3) = 0.5D0 * BDX
      CALL MPSUB (S(K2), F, S(K4))
C
C   Perform iterations as described above.
C
      DO 100 K = 1, MQ
        CALL MPADD (S(K0), S(K1), S(K2))
        CALL MPMULX (S(K0), S(K1), S(K3))
        CALL MPSQRX (S(K3), S(K1))
        CALL MPMULD (S(K2), 0.5D0, 0, S(K0))
        CALL MPSUB (S(K0), S(K1), S(K2))
        CALL MPMULX (S(K2), S(K2), S(K3))
        T1 = 2.D0 ** K
        CALL MPMULD (S(K3), T1, 0, S(K2))
        CALL MPSUB (S(K4), S(K2), S(K3))
        CALL MPEQ (S(K3), S(K4))
 100  CONTINUE
C
C   Complete computation.
C
      CALL MPADD (S(K0), S(K1), S(K2))
      CALL MPMULX (S(K2), S(K2), S(K3))
      CALL MPDIVX (S(K3), S(K4), S(K2))
      CALL MPEQ (S(K2), PI)
      ICS = ISS
C
 110  IF (IDB .GE. 7) CALL MPDEB ('MPPIX O', PI)
      RETURN
      END
C
      SUBROUTINE MPPOL (N, L, A, X1, NX, X)
C
C   This finds a real root of the N-th degree polynomial whose MP coefficients
C   are in A by Newton-Raphson iterations, beginning at the DPE value (X1, NX)
C   and returns the MP root in X.  The N + 1 coefficients a_0, a_1, ..., a_N
C   are assumed to start in locations A(1), A(L+1), A(2*L+1), etc.  For extra
C   high levels of precision, use MPPOLX.  Debug output starts with IDB = 6.
C
C   Max SP space for X: NW + 4 cells.  Max SP scratch space: 5 * NW + 25
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   One requirement for this routine to work is that the desired root is not
C   a repeated root.  If one wishes to apply this routine to find a repeated
C   root, it is first necessary to reduce the polynomial to one that has only
C   simple roots.  This can be done by performing the Euclidean algorithm in
C   the ring of polynomials to determine the greatest common divisor Q(t) of
C   P(t) and P'(t).  Here P(t) is the polynomial a_0 + a_1 t + a_2 t^2 +
C   ... + a_n t^n, and P'(t) is the derivative of P(t).  Then R(t) = P(t)/Q(t)
C   is a polynomial that has only simple roots.
C
C   This routine employs the standard form of the Newton-Raphson iteration:
C
C   X_{k+1} = X_k - P(X_k) / P'(X_k)
C
C   These iterations are performed with a maximum precision level NW that is
C   dynamically changed, approximately doubling with each iteration.
C
      CHARACTER*8 CX
      DOUBLE PRECISION T1, X1
      DIMENSION A(L,N+1), X(NW+4)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 1) N
 1      FORMAT ('MPPOL I',I4)
C
        DO 100 K = 0, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, A(1,K+1))
 100    CONTINUE
C
        WRITE (LDB, 2) X1, NX
 2      FORMAT ('MPPOL I',F16.12,' x 10 ^',I6)
      ENDIF
C
C  Check if the polynomial is proper.
C
      IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN
        IF (KER(63) .NE. 0) THEN
          WRITE (LDB, 3)
 3        FORMAT ('*** MPPOL: Either the first or last input ',         
     $      'coefficient is zero.')
          IER = 63
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N5 = NW + 5
      NS = 5 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      K2 = K1 + N5
      K3 = K2 + N5
      K4 = K3 + N5
      NWS = NW
      NW = NW + 1
C
C   Set the initial value.
C
      CALL MPDMC (X1, NX, S(K0))
      NW = 5
      TL = -4.
      L1 = 0
      LS = -10
C
C   Perform MP Newton-Raphson iterations to solve P(x) = 0.
C
 110  L1 = L1 + 1
      IF (L1 .EQ. 50) THEN
        IF (KER(64) .NE. 0) THEN
          WRITE (LDB, 4)
 4        FORMAT ('*** MPPOL: Iteration limit exceeded.')
          IER = 64
          IF (KER(IER) .EQ. 2) CALL MPABRT
          NW = NWS
          ICS = ISS
          RETURN
        ENDIF
      ENDIF
C
C   Compute P(x).
C
      CALL MPEQ (A(1,N+1), S(K1))
C
      DO 120 K = N - 1, 0, -1
        CALL MPMUL (S(K0), S(K1), S(K2))
        CALL MPADD (S(K2), A(1,K+1), S(K1))
 120  CONTINUE
C
C   Compute P'(x).
C
      T1 = N
      CALL MPMULD (A(1,N+1), T1, 0, S(K2))
C
      DO 130 K = N - 1, 1, -1
        CALL MPMUL (S(K0), S(K2), S(K3))
        T1 = K
        CALL MPMULD (A(1,K+1), T1, 0, S(K4))
        CALL MPADD (S(K3), S(K4), S(K2))
 130  CONTINUE
C
C   Compute P(x) / P'(x) and update x.
C
      CALL MPDIV (S(K1), S(K2), S(K3))
      CALL MPSUB (S(K0), S(K3), S(K4))
C
      IF (IDB .GE. 7) THEN
        WRITE (LDB, 5) L1
 5      FORMAT ('Iteration',I4)
        CALL MPDEB ('X', S(K0))
        CALL MPDEB ('P(X)', S(K1))
        CALL MPDEB ('P''(X)', S(K2))
        CALL MPDEB ('CORR', S(K3))
      ENDIF
      CALL MPEQ (S(K4), S(K0))
C
C   If this was the second iteration at full precision, there is no need to
C   continue (the adjusted value of x is correct); otherwise repeat.
C
      IF (L1 .EQ. LS + 1) GOTO 140
      IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL) GOTO 110
C
C   Newton iterations have converged to current precision.  Increase precision
C   and continue.
C
      IF (NW .EQ. NWS + 1) GOTO 140
      NW = MIN (2 * NW - 2, NWS) + 1
      IF (NW .EQ. NWS + 1) LS = L1
      TL = 1 - NW
      IF (IDB .GE. 7) THEN
        WRITE (LDB, 6) NW
 6      FORMAT (6X,'New NW =', I8)
      ENDIF
      GOTO 110
C
 140  CALL MPEQ (S(K0), X)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (X)
C
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 7) L1
 7      FORMAT ('Iteration count:',I5)
        CALL MPDEB ('MPPOL O', X)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPPOLX (N, L, A, X1, NX, X)
C
C   This finds a real root of the N-th degree polynomial whose MP coefficients
C   are in A by Newton-Raphson iterations, beginning at the DP value (X1, NX)
C   and returns the MP root in X.  The N + 1 coefficients a_0, a_1, ..., a_N
C   are assumed to start in locations A(1), A(L+1), A(2*L+1), etc.  Before
C   calling MPPOLX, the array in MPCOM5 must be initialized by calling MPINIX.
C   For modest levels of precision, use MPPOL.  NW should be a power of two.
C   The last three words of the result are not reliable.  Debug output starts
C   with IDB = 5.
C
C   Max SP space for X: NW + 4 cells.  Max SP scratch space: 7.5 * NW + 45
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   For a discussion of the algorithm and usage, see MPPOL.  This routine uses
C   basically the same Newton iteration algorithm as MPPOL.  In fact, this
C   routine calls MPPOL to obtain an initial approximation.
C
      CHARACTER*8 CX
      DOUBLE PRECISION T1, X1
      DIMENSION A(L,N+1), X(NW+4)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        X(1) = 0.
        X(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 5) THEN
        WRITE (LDB, 1) N
 1      FORMAT ('MPPOLX I',I4)
C
        DO 100 K = 0, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, A(1,K+1))
 100    CONTINUE
C
        WRITE (LDB, 2) X1, NX
 2      FORMAT ('MPPOLX I',F16.12,' x 10 ^',I6)
      ENDIF
C
C   Check if precision level is too low to justify the advanced routine.
C
      NCR = 2 ** MCR
      IF (NW .LE. NCR) THEN
        CALL MPPOL (N, L, A, X1, NX, X)
        L1 = 0
        GOTO 150
      ENDIF
C
C  Check if the polynomial is proper.
C
      IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN
        IF (KER(65) .NE. 0) THEN
          WRITE (LDB, 3)
 3        FORMAT ('*** MPPOLX: Either the first or last input ',        
     $      'coefficient is zero.')
          IER = 65
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N4 = NW + 4
      NS = 5 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      K2 = K1 + N4
      K3 = K2 + N4
      K4 = K3 + N4
      NWS = NW
C
C   Compute the initial approximation.
C
      NW = NCR
      CALL MPPOL (N, L, A, X1, NX, X)
      CALL MPEQ (X, S(K0))
      TL = 2 - NW
      L1 = 0
      LS = -10
C
C   Perform MP Newton-Raphson iterations to solve P(x) = 0.
C
 110  L1 = L1 + 1
      IF (L1 .EQ. 50) THEN
        IF (KER(66) .NE. 0) THEN
          WRITE (LDB, 4)
 4        FORMAT ('*** MPPOLX: Iteration limit exceeded.')
          IER = 66
          IF (KER(IER) .EQ. 2) CALL MPABRT
          NW = NWS
          ICS = ISS
          RETURN
        ENDIF
      ENDIF
C
C   Compute P(x).
C
      CALL MPEQ (A(1,N+1), S(K1))
C
      DO 120 K = N - 1, 0, -1
        CALL MPMULX (S(K0), S(K1), S(K2))
        CALL MPADD (S(K2), A(1,K+1), S(K1))
 120  CONTINUE
C
C   Compute P'(x).
C
      T1 = N
      CALL MPMULD (A(1,N+1), T1, 0, S(K2))
C
      DO 130 K = N - 1, 1, -1
        CALL MPMULX (S(K0), S(K2), S(K3))
        T1 = K
        CALL MPMULD (A(1,K+1), T1, 0, S(K4))
        CALL MPADD (S(K3), S(K4), S(K2))
 130  CONTINUE
C
C   Compute P(x) / P'(x) and update x.
C
      CALL MPDIVX (S(K1), S(K2), S(K3))
      CALL MPSUB (S(K0), S(K3), S(K4))
C
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 5) L1
 5      FORMAT ('Iteration',I4)
        CALL MPDEB ('X', S(K0))
        CALL MPDEB ('P(X)', S(K1))
        CALL MPDEB ('P''(X)', S(K2))
        CALL MPDEB ('CORR', S(K3))
      ENDIF
      CALL MPEQ (S(K4), S(K0))
C
C   If this was the second iteration at full precision, there is no need to
C   continue (the adjusted value of x is correct); otherwise repeat.
C
      IF (L1 .EQ. LS + 1) GOTO 140
      IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL) GOTO 110
C
C   Newton iterations have converged to current precision.  Increase precision
C   and continue.
C
      IF (NW .EQ. NWS) GOTO 140
      NW = MIN (2 * NW, NWS)
      IF (NW .EQ. NWS) LS = L1
      IF (NW .LE. 32) THEN
        TL = 2 - NW
      ELSEIF (NW .LE. 256) THEN
        TL = 3 - NW
      ELSE
        TL = 4 - NW
      ENDIF
      IF (IDB .GE. 6) THEN
        WRITE (LDB, 6) NW
 6      FORMAT (6X,'New NW =', I8)
      ENDIF
      GOTO 110
C
 140  CALL MPEQ (S(K0), X)
      ICS = ISS
C
 150  IF (IDB .GE. 5) THEN
        WRITE (LDB, 7) L1
 7      FORMAT ('Iteration count:',I5)
        CALL MPDEB ('MPPOLX O', X)
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPRAND (A)
C>
C   This returns a pseudo-random MP number A between 0 and 1.  This routine
C   calls the pseudo-random number generator routine MPRANQ in the file below.
C   Better routines than MPRANQ are available for this purpose on some
C   computer systems.  If so, it is suggested that the call to MPRANQ here be
C   replaced by a call to its equivalent on the host system.  Note, however,
C   that test no. 55 of the TESTMP test suite will fail if another generator
C   is used.  Debug output starts with IDB = 9.
C
C   Max SP space for A: NW + 4 cells.
C
      DOUBLE PRECISION MPRANQ, SD, S0
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (NDB = 22, S0 = 314159265.D0)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      DIMENSION A(NW+4)
      SAVE SD
      DATA SD/S0/
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        RETURN
      ENDIF
      A(1) = NW
      A(2) = -1.
C
      DO 100 I = 3, NW + 4
        A(I) = AINT (BDX * MPRANQ (SD))
 100  CONTINUE
C
      CALL MPROUN (A)
C
      IF (IDB .GE. 9) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPRAND O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      FUNCTION MPRANQ (SD)
C
C   This routine returns a pseudorandom DP floating number uniformly
C   distributed between 0 and 1, computed from the seed SD, which is updated
C   after each reference.  The initial value of SD should be an odd whole
C   number in the range (1, 2 ^ 30).  2 ^ 28 pseudorandom numbers with 30 bits
C   each are returned before repeating.  The same sequence is generated on any
C   computer system.
C
      DOUBLE PRECISION F7, R30, SD, T1, T2, T30, MPRANQ
      PARAMETER (F7 = 78125.D0)
      SAVE R30, T30
      DATA R30/0.D0/
C
C   If this is the first time MPRANQ has been called, compute R30 = 2^(-30)
C   and T30 = 2^30.  This must be done in a loop rather than by merely using
C   ** in order to insure the results are exact on all systems.
C
      IF (R30 .EQ. 0.D0) THEN
        R30 = 1.D0
        T30 = 1.D0
C
        DO 100 I = 1, 30
          R30 = 0.5D0 * R30
          T30 = 2.D0 * T30
 100    CONTINUE
C
      ENDIF
C
C   Generate a pseudorandom number using a linear congruential scheme.
C
      T1 = F7 * SD
      T2 = AINT (R30 * T1)
      SD = T1 - T30 * T2
      MPRANQ = R30 * SD
C
      RETURN
      END
C
      SUBROUTINE MPRCFT (IS, M, X, Y)
C
C   This performs an N-point real-to-complex FFT, where N = 2^M.  X and Y
C   are double precision arrays.  X is both the input and the output data
C   array, and Y is a scratch array.  N real values are input and N/2 + 1
C   complex pairs are output, with real and imaginary parts separated by
C   N/2 + 1 locations.  A call to MPRCFT with IS = 1 (or -1) indicates a call
C   to perform a complex-to-real FFT with positive (or negative) exponentials.
C   M must be at least three.  The arrays X and Y must be dimensioned with
C   N + 2 cells.  Before calling MPRCFT, the U array in MPCOM5 must be
C   initialized by calling MPINIX.
C
C   In this application, MPRCFT is called by MPMULX.  This routine is not
C   intended to be called directly by the user.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(*), Y(*)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM5/ U(1024)
C
C   Set initial parameters.
C
      K = U(1)
      MX = MOD (K, 64)
      NU = K / 64
      N = 2 ** M
      N2 = N / 2
      N21 = N2 + 1
      N4 = N / 4
      KU = N / 2
      KN = KU + NU
C
C   Check if input parameters are invalid.
C
      IF ((IS .NE. 1 .AND. IS .NE. -1) .OR. M .LT. 3 .OR. M .GT. MX)    
     $  THEN
        IF (KER(67) .NE. 0) THEN
          WRITE (LDB, 1)  IS, M, MX
 1        FORMAT ('*** MPRCFT: either U has not been initialized'/      
     $      'or else one of the input parameters is invalid',3I5)
          IER = 67
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Copy X to Y such that Y(k) = X(2k-1) + i X(2k).
C
CDIR$ IVDEP
      DO 100 K = 1, N2
        Y(K) = X(2*K-1)
        Y(K+N2) = X(2*K)
 100  CONTINUE
C
C   Perform a normal N/2-point FFT on Y.
C
      CALL MPCFFT (IS, M - 1, Y, X)
C
C   Reconstruct the FFT of X.
C
      X(1) = 2.D0 * (Y(1) + Y(N21))
      X(N21+1) = 0.D0
      X(N4+1) = 2.D0 * Y(N4+1)
      X(N4+1+N21) = 2.D0 * IS * Y(N4+N2+1)
      X(N21) = 2.D0 * (Y(1) - Y(N21))
      X(N+2) = 0.D0
C
CDIR$ IVDEP
      DO 110 K = 2, N4
        Y11 = Y(K)
        Y12 = Y(K+N2)
        Y21 = Y(N2+2-K)
        Y22 = Y(N+2-K)
        A1 = Y11 + Y21
        A2 = Y11 - Y21
        B1 = Y12 + Y22
        B2 = Y12 - Y22
        U1 = U(K+KU)
        U2 = IS * U(K+KN)
        T1 = U1 * B1 + U2 * A2
        T2 = - U1 * A2 + U2 * B1
        X(K) = A1 + T1
        X(K+N21) = B2 + T2
        X(N2+2-K) = A1 - T1
        X(N+3-K) = -B2 + T2
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPROUN (A)
C
C   This performs rounding and truncation of the MP number A.  It is called
C   by MPNORM, and also by other subroutines when the precision level is
C   reduced by one.  It is not intended to be directly called by the user.
C
C   Maximum SP space for A:  NW + 4 cells.
C
C   The parameter AMX is the absolute value of the largest exponent word
C   allowed for MP numbers.
C
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (AMX = 2.E6)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      DIMENSION A(NW+4)
C
      IF (IER .NE. 0) THEN
        A(1) = 0.
        A(2) = 0.
        RETURN
      ENDIF
C
C   Check for initial zeroes.
C
      A2 = A(2)
      A(2) = 0.
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      N4 = NA + 4
      IF (A(3) .EQ. 0.) THEN
C
C   Find the first nonzero word and shift the entire number left.  The length
C   of the result is reduced by the length of the shift.
C
        DO 100 I = 4, N4
          IF (A(I) .NE. 0.)  GOTO 110
 100    CONTINUE
C
        A(1) = 0.
        A(2) = 0.
        GOTO 170
C
 110    K = I - 3
C
CDIR$ IVDEP
        DO 120 I = 3, N4 - K
          A(I) = A(I+K)
 120    CONTINUE
C
        A2 = A2 - K
        NA = NA - MAX (K - 2, 0)
      ENDIF
C
C   Perform rounding depending on IRD.
C
      IF (NA .EQ. NW .AND. IRD .GE. 1) THEN
        IF (IRD .EQ. 1 .AND. A(NA+3) .GE. 0.5D0 * BDX .OR. IRD .EQ. 2   
     $    .AND. A(NA+3) .GE. 1.) A(NA+2) = A(NA+2) + 1.
C
C   Release carries as far as necessary due to rounding.
C
        DO 130 I = NA + 2, 3, -1
          IF (A(I) .LT. BDX) GOTO 140
          A(I) = A(I) - BDX
          A(I-1) = A(I-1) + 1.
 130    CONTINUE
C
C   Release of carries due to rounding continued all the way to the start --
C   i.e. number was entirely 9's.
C
        A(3) = A(2)
        NA = 1
        A2 = A2 + 1.
      ENDIF
C
 140  IF (A(NA+2) .EQ. 0.) THEN
C
C   At least the last mantissa word is zero.  Find the last nonzero word
C   and adjust the length of the result accordingly.
C
        DO 150 I = NA + 2, 3, -1
          IF (A(I) .NE. 0.) GOTO 160
 150    CONTINUE
C
        A(1) = 0.
        A(2) = 0.
        GOTO 170
C
 160    NA = I - 2
      ENDIF
C
C   Check for overflow and underflow.
C
      IF (A2 .LT. - AMX) THEN
        IF (KER(68) .NE. 0) THEN
          WRITE (LDB, 1)
 1        FORMAT ('*** MPROUN: Exponent underflow.')
          IER = 68
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
      ELSEIF (A2 .GT. AMX) THEN
        IF (KER(69) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPROUN: Exponent overflow.')
          IER = 69
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
      ENDIF
C
C   Check for zero.
C
      IF (A(3) .EQ. 0.) THEN
        A(1) = 0.
        A(2) = 0.
      ELSE
        A(1) = SIGN (NA, IA)
        A(2) = A2
        A(NA+3) = 0.
        A(NA+4) = 0.
      ENDIF
C
 170  RETURN
      END
C
      SUBROUTINE MPSETP (IA, IB)
C
C   This routine sets the parameter whose name is IA in common MPCOM1 to the
C   value IB.  By using this routine instead of merely including the MPCOM1
C   block in the code, a user may eliminate the possibility of confusion with
C   a variable name in his or her program.  IA is of type CHARACTER and IB
C   is the integer value.
C
      CHARACTER*(*) IA
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IA .EQ. 'NW' .OR. IA .EQ. 'nw') THEN
        NW = IB
      ELSEIF (IA .EQ. 'IDB' .OR. IA .EQ. 'idb') THEN
        IDB = IB
      ELSEIF (IA .EQ. 'LDB' .OR. IA .EQ. 'ldb') THEN
        LDB = IB
      ELSEIF (IA .EQ. 'IER' .OR. IA .EQ. 'ier') THEN
        IER = IB
      ELSEIF (IA .EQ. 'MCR' .OR. IA .EQ. 'mcr') THEN
        MCR = IB
      ELSEIF (IA .EQ. 'IRD' .OR. IA .EQ. 'ird') THEN
        IRD = IB
      ELSEIF (IA .EQ. 'ICS' .OR. IA .EQ. 'ics') THEN
        ICS = IB
      ELSEIF (IA .EQ. 'IHS' .OR. IA .EQ. 'ihs') THEN
        IHS = IB
      ELSEIF (IA .EQ. 'IMS' .OR. IA .EQ. 'ims') THEN
        IMS = IB
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE MPSORT (N, LA, A, IP)
C
C   This routine sorts the entries of the N-long MP vector A into ascending
C   order using the quicksort algorithm.  The entries of A are assumed to
C   start at A(1), A(LA+1), A(2*LA+1), etc. The permutation vector that would
C   sort the vector is returned in IP.  Debug output starts with IDB = 7.
C
C   Max integer space for IP: N cells.  Max SP scratch space: 2 * NW + 8 cells.
C
      CHARACTER*8 CX
      DIMENSION A(LA,N), IP(N), IK(50), JK(50)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
C
        DO 100 I = 1, N
          IP(I) = I
 100    CONTINUE
C
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        WRITE (LDB, 1) N, LA
 1      FORMAT ('MPSORT I',2I6)
C
        DO 110 K = 1, N
          WRITE (CX, '(I4)') K
          CALL MPDEB (CX, A(1,K))
 110    CONTINUE
C
      ENDIF
C
      N4 = NW + 4
      NS = 2 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
C
      DO 120 I = 1, N
        IP(I) = I
 120  CONTINUE
C
      K = 1
      IK(1) = 1
      JK(1) = N
C
 130  I = IK(K)
      J = JK(K)
      IQ = I
      JQ = J
      IT = (I + J + 1) / 2
      L = IP(J)
      IP(J) = IP(IT)
      IP(IT) = L
      CALL MPEQ (A(1,IP(J)), S(K0))
      J = J - 1
C
 140  DO 150 L = I, J
        CALL MPCPR (S(K0), A(1,IP(L)), IC)
        IF (IC .LT. 0) GOTO 160
 150  CONTINUE
C
      I = J
      GOTO 190
C
 160  I = L
C
      DO 170 L = J, I, -1
        CALL MPCPR (S(K0), A(1,IP(L)), IC)
        IF (IC .GT. 0) GOTO 180
 170  CONTINUE
C
      J = I
      GOTO 190
C
 180  J = L
      IF (I .GE. J)  GOTO 190
      L = IP(I)
      IP(I) = IP(J)
      IP(J) = L
      GOTO 140
C
 190  CALL MPCPR (S(K0), A(1,IP(I)), IC)
      IF (IC .GE. 0) GOTO 200
      L = IP(JQ)
      IP(JQ) = IP(I)
      IP(I) = L
C
 200  K = K - 1
      JZ = 0
      IF (J .EQ. IQ)  GOTO 210
      K = K + 1
      JK(K) = J
      JZ = 1
C
 210  I = I + 1
      IF (I .EQ. JQ)  GOTO 220
      K = K + 1
      IK(K) = I
      JK(K) = JQ
      IF (JZ .EQ. 0)  GOTO 220
      IF (J - IQ .GE. JQ - I)  GOTO 220
      IK(K-1) = I
      JK(K-1) = JQ
      IK(K) = IQ
      JK(K) = J
C
 220  IF (K .GT. 0)  GOTO 130
C
      ICS = ISS
      IF (IDB .GE. 7) WRITE (6, 2) IP
 2    FORMAT ('MPSORT O'/(8I9))
      RETURN
      END
C
      SUBROUTINE MPSQRT (A, B)
C
C   This computes the square root of the MP number A and returns the MP result
C   in B.  For extra high levels of precision, use MPSQRX.  Debug output
C   starts with IDB = 7.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 2 * NW + 10
C   cells.  Max DP scratch space: NW + 5 cells.
C
C   This subroutine employs the following Newton-Raphson iteration, which
C   converges to 1 / Sqrt(A):
C
C          X_{k+1} = X_k + (X_k / 2) * (1 - A * X_k^2)
C
C   Multiplying the final approximation to 1 / Sqrt(A) by A gives the square
C   root. These iterations are performed with a maximum precision level NW that
C   is dynamically changed, approximately doubling with each iteration.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION CL2, T1, T2
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 3)
      DIMENSION A(NW+2), B(NW+4), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPSQRT I'/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
C
      IF (NA .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 120
      ENDIF
      IF (IA .LT. 0.D0) THEN
        IF (KER(70) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPSQRT: Argument is negative.')
          IER = 70
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
      N5 = NW + 5
      NS = 2 * N5
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N5
      NWS = NW
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Compute the initial approximation of 1 / Sqrt(A).
C
      CALL MPMDC (A, T1, N)
      N2 = - N / 2
      T2 = SQRT (T1 * 2.D0 ** (N + 2 * N2))
      T1 = 1.D0 / T2
      CALL MPDMC (T1, N2, B)
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
      NW = 3
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (one greater than powers of two).
C
      DO 110 K = 2, MQ
        NW = MIN (2 * NW - 2, NWS) + 1
 100    CONTINUE
        CALL MPMUL (B, B, S(K0))
        CALL MPMUL (A, S(K0), S(K1))
        CALL MPSUB (F, S(K1), S(K0))
        CALL MPMUL (B, S(K0), S(K1))
        CALL MPMULD (S(K1), 0.5D0, 0, S(K0))
        CALL MPADD (B, S(K0), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Multiply by A to give final result.
C
      CALL MPMUL (A, B, S(K1))
      CALL MPEQ (S(K1), B)
C
C   Restore original precision level.
C
      NW = NWS
      ICS = ISS
      CALL MPROUN (B)
C
 120  IF (IDB .GE. 7) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPSQRT O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPSQRX (A, B)
C
C   This computes the cube root of the MP number A and returns the MP result
C   in B.  Before calling MPSQRX, the array in MPCOM5 must be initialized by
C   calling MPINIX.  For modest levels of precision, use MPSQRT.  NW should be
C   a power of two.  The last three words of the result are not reliable.
C   Debug output starts with IDB = 6.
C
C   Max SP space for B: NW + 4 cells.  Max SP scratch space: 3 * NW + 18
C   cells.  Max DP scratch space: 12 * NW + 6 cells.
C
C   This routine uses basically the same Newton iteration algorithm as MPSQRT.
C   In fact, this routine calls MPSQRT to obtain an initial approximation.
C   See the comment about the parameter NIT in MPDIVX.
C
      DOUBLE PRECISION CL2, T1
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1)
      DIMENSION A(NW+2), B(NW+4), F(8)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM2/ KER(72)
      COMMON /MPCOM3/ S(1024)
C
      IF (IER .NE. 0) THEN
        B(1) = 0.
        B(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (A(1))), NDB) + 2
        WRITE (LDB, 1) (A(I), I = 1, NO)
 1      FORMAT ('MPSQRX I'/(6F12.0))
      ENDIF
C
      IA = SIGN (1., A(1))
      NA = MIN (INT (ABS (A(1))), NW)
      NCR = 2 ** MCR
C
      IF (NA .EQ. 0) THEN
        B(1) = 0.
        B(2) = 0.
        GOTO 120
      ENDIF
      IF (IA .LT. 0.D0) THEN
        IF (KER(71) .NE. 0) THEN
          WRITE (LDB, 2)
 2        FORMAT ('*** MPSQRX: Argument is negative.')
          IER = 71
          IF (KER(IER) .EQ. 2) CALL MPABRT
        ENDIF
        RETURN
      ENDIF
C
C   Check if precision level is too low to justify the advanced routine.
C
      IF (NW .LE. NCR) THEN
        CALL MPSQRT (A, B)
        GOTO 120
      ENDIF
      N4 = NW + 4
      NS = 2 * N4
      ISS = ICS
      ICS = ICS + NS
      IHS = MAX (ICS, IHS)
      IF (ICS - 1 .GT. IMS) CALL MPALER
      K0 = ISS
      K1 = K0 + N4
      NWS = NW
C
C   Determine the least integer MQ such that 2 ^ MQ .GE. NW.
C
      T1 = NW
      MQ = CL2 * LOG (T1) + 1.D0 - RXX
C
C   Compute the initial approximation of 1 / Sqrt(A).
C
      NW = NCR
      CALL MPSQRT (A, S(K0))
      CALL MPDIV (S(K0), A, B)
      F(1) = 1.
      F(2) = 0.
      F(3) = 1.
      IQ = 0
C
C   Perform the Newton-Raphson iteration described above with a dynamically
C   changing precision level NW (powers of two).
C
      DO 110 K = MCR + 1, MQ
        AN = NW
        NW = MIN (2 * NW, NWS)
 100    CONTINUE
        CALL MPMULX (B, B, S(K0))
        CALL MPMULX (A, S(K0), S(K1))
        CALL MPSUB (F, S(K1), S(K0))
        S(K0) = MIN (S(K0), AN)
        CALL MPMULX (B, S(K0), S(K1))
        CALL MPMULD (S(K1), 0.5D0, 0, S(K0))
        CALL MPADD (B, S(K0), S(K1))
        CALL MPEQ (S(K1), B)
        IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN
          IQ = 1
          GOTO 100
        ENDIF
 110  CONTINUE
C
C   Multiply by A to give final result.
C
      CALL MPMULX (A, B, S(K1))
      CALL MPEQ (S(K1), B)
      ICS = ISS
C
 120  IF (IDB .GE. 6) THEN
        NO = MIN (INT (ABS (B(1))), NDB) + 2
        WRITE (LDB, 3) (B(I), I = 1, NO)
 3      FORMAT ('MPSQRX O'/(6F12.0))
      ENDIF
      RETURN
      END
C
      SUBROUTINE MPSUB (A, B, C)
C
C   This routine subtracts MP numbers A and B to yield the MP difference C,
C   by negating B and adding.  Debug output starts with IDB = 9.
C
C   Max SP space for C: NW + 4 cells.
C
      DIMENSION A(NW+2), B(NW+2), C(NW+2)
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
C
      IF (IER .NE. 0) THEN
        C(1) = 0.
        C(2) = 0.
        RETURN
      ENDIF
      IF (IDB .GE. 9) WRITE (LDB, 1)
 1    FORMAT ('MPSUB')
C
C   Check if A = B.  This is necessary because A and B might be same array,
C   in which case negating B below won't work.
C
      IF (A(1) .NE. B(1)) GOTO 110
C
      DO 100 I = 2, INT (ABS (A(1))) + 2
        IF (A(I) .NE. B(I)) GOTO 110
 100  CONTINUE
C
C   A = B.  Result is zero.
C
      C(1) = 0.
      C(2) = 0.
      IF (IDB .GE. 9) WRITE (LDB, 2) (C(I), I = 1, 2)
 2    FORMAT ('MPSUB O'/2F9.0)
      GOTO 120
C
C   Save the sign of B, and then negate B.
C
 110  B1 = B(1)
      B(1) = - B1
C
C   Perform addition and restore the sign of B.
C
      CALL MPADD (A, B, C)
      B(1) = B1
C
 120  RETURN
      END
C
      SUBROUTINE MPTRAN (N1, N2, X, Y)
C
C   Performs a transpose of the vector X, returning the result in Y.  X is
C   treated as a N1 x N2 complex matrix, and Y is treated as a N2 x N1 complex
C   matrix.  The complex data is assumed stored with real and imaginary parts
C   separated by N1 x N2 locations.
C
C   This routine is called by MPCFFT.  It is not intended to be called directly
C   by the user.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (NA = 32, NC = 32)
      DIMENSION X(2*N1*N2), Y(2*N1*N2), Z(NC,2*NC)
C
      N = N1 * N2
C>
C   Use different techniques, depending on the system, N1 and N2.  For Cray
C   systems, uncomment the next line.
C
C      GOTO 100
C
C   This strategy is good for many scalar cache memory computers.  The
C   value of NC (i.e. the size of Z) may have to be changed depending on
C   how large the cache is.
C
      IF (N1 .LE. NC .OR. N2 .LE. NC) THEN
        IF (N1 .GE. N2) THEN
          GOTO 110
        ELSE
          GOTO 130
        ENDIF
      ELSE
        GOTO 150
      ENDIF
C
C   This strategy is best for Cray systems.
C
 100  IF (N1 .LT. NA .OR. N2 .LT. NA) THEN
        IF (N1 .GE. N2) THEN
          GOTO 110
        ELSE
          GOTO 130
        ENDIF
      ELSE
        GOTO 220
      ENDIF
C
C   Scheme 1:  Perform a simple transpose in the usual way.
C
 110  DO 120 J = 0, N2 - 1
        J1 = J + 1
        J2 = J * N1 + 1
C
CDIR$ IVDEP
        DO 120 I = 0, N1 - 1
          Y(I*N2+J1) = X(I+J2)
          Y(I*N2+J1+N) = X(I+J2+N)
 120  CONTINUE
C
      GOTO 260
C
C   Scheme 2:  Perform a simple transpose with the loops reversed.
C
 130  DO 140 I = 0, N1 - 1
        I1 = I * N2 + 1
        I2 = I + 1
C
CDIR$ IVDEP
        DO 140 J = 0, N2 - 1
          Y(J+I1) = X(J*N1+I2)
          Y(J+I1+N) = X(J*N1+I2+N)
 140  CONTINUE
C
      GOTO 260
C
C   Scheme 3:  Perform a transpose using the intermediate array Z.  This gives
C   better performance than schemes 1 and 2 on certain cache memory systems.
C   The size of the array Z (i.e. the parameter NC above) may have to be
C   adjusted for optimal performance.
C
 150  DO 210 JJ = 0, N2 - 1, NC
        DO 200 II = 0, N1 - 1, NC
C
          DO 170 J = 1, NC
            J1 = II + (J - 1 + JJ) * N1
C
CDIR$ IVDEP
            DO 160 I = 1, NC
              Z(J,I) = X(I+J1)
              Z(J,I+NC) = X(I+J1+N)
 160        CONTINUE
C
 170      CONTINUE
C
          DO 190 I = 1, NC
            I1 = JJ + (I - 1 + II) * N2
C
CDIR$ IVDEP
            DO 180 J = 1, NC
              Y(J+I1) = Z(J,I)
              Y(J+I1+N) = Z(J,I+NC)
 180        CONTINUE
C
 190      CONTINUE
C
 200    CONTINUE
 210  CONTINUE
C
      GOTO 260
C
C   Scheme 4:  Perform the transpose along diagonals to insure odd strides.
C   This works well on moderate vector, variable stride computers, when both
C   N1 and N2 are divisible by reasonably large powers of two (32 or larger on
C   Cray computers).
C
 220  N11 = N1 + 1
      N21 = N2 + 1
      IF (N1 .GE. N2) THEN
        K1 = N1
        K2 = N2
        I11 = N1
        I12 = 1
        I21 = 1
        I22 = N2
      ELSE
        K1 = N2
        K2 = N1
        I11 = 1
        I12 = N2
        I21 = N1
        I22 = 1
      ENDIF
C
      DO 230 J = 0, K2 - 1
        J1 = J * I11 + 1
        J2 = J * I12 + 1
C
CDIR$ IVDEP
        DO 230 I = 0, K2 - 1 - J
          Y(N21*I+J2) = X(N11*I+J1)
          Y(N21*I+J2+N) = X(N11*I+J1+N)
 230  CONTINUE
C
      DO 240 J = 1, K1 - K2 - 1
        J1 = J * I21 + 1
        J2 = J * I22 + 1
C
CDIR$ IVDEP
        DO 240 I = 0, K2 - 1
          Y(N21*I+J2) = X(N11*I+J1)
          Y(N21*I+J2+N) = X(N11*I+J1+N)
 240  CONTINUE
C
      DO 250 J = K1 - K2, K1 - 1
        J1 = J * I21 + 1
        J2 = J * I22 + 1
C
CDIR$ IVDEP
        DO 250 I = 0, K1 - 1 - J
          Y(N21*I+J2) = X(N11*I+J1)
          Y(N21*I+J2+N) = X(N11*I+J1+N)
 250  CONTINUE
C
 260  RETURN
      END
      PROGRAM TESTMP
C
C   This is the test program for DHB's multiprecision computation package
C   MPFUN (binary version).  It exercises most routines and verifies that they
C   are working properly.  If any of these tests fail, it cannot possibly be
C   due to a bug in DHB's MPFUN package, so it must therefore be due to some
C   local hardware or compiler problem (smile).
C
C     David H. Bailey     May 27, 1992
C
      DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX
      DOUBLE PRECISION DS, DSUM, T1, X1
      CHARACTER*1 Z
      CHARACTER*80 ZA
      PARAMETER (MX = 6, NX = 2 ** MX, L = 5, N = 8, N4 = NX + 4,       
     $  LN = L * N, MT = 10 - 6 * NX, NP = 20,                          
     $  NS = N4 * (4 * N**2 + 5 * N + 14), NT = 64)
      DIMENSION AA(L,N), AC(2*L,N), A(N4), AL2(N4), B(N4), DS(NT),      
     $  F1(5), F2(5), IP(NP), IS1(NP), IS2(9), NX1(2), PI(N4), X(2*N4), 
     $  XX(N4,NP), X1(2), Y(2*N4), Z(600)
      COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR
      COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS
      COMMON /MPCOM3/ S(NS)
      DATA AA /                                                         
     $   1., 0., 40., 0., 0., 1., 0., 24., 0., 0., -1., 0., 15., 0., 0.,
     $  -1., 0.,  8., 0., 0., 1., 0.,  5., 0., 0.,  1., 0.,  2., 0., 0.,
     $   0., 0.,  0., 0., 0., 1., 0.,  1., 0., 0./
      DATA AC /                                                         
     $   1., 0., 40., 0., 0., 5 * 0.,  1., 0., 24., 0., 0., 5 * 0.,     
     $  -1., 0., 15., 0., 0., 5 * 0., -1., 0.,  8., 0., 0., 5 * 0.,     
     $   1., 0.,  5., 0., 0., 5 * 0.,  1., 0.,  2., 0., 0., 5 * 0.,     
     $   0., 0.,  0., 0., 0., 5 * 0.,  1., 0.,  1., 0., 0., 5 * 0./
      DATA DS /                                                         
     $   71647124.D0,          0.D0,  532002022.D0,  520881213.D0,      
     $  535684389.D0,  466695539.D0,  525576020.D0,  448479226.D0,      
     $  598587746.D0,  577629931.D0,  544393923.D0,  527030594.D0,      
     $  550529242.D0,  523320411.D0,  536143302.D0,  516904795.D0,      
     $  522577789.D0,  501964666.D0,  564046428.D0,  533883779.D0,      
     $  560037982.D0,  539041558.D0,  485070596.D0,  465190050.D0,      
     $  534435267.D0,  521869037.D0,  535883606.D0,  516544718.D0,      
     $  501186251.D0,  490005323.D0,  471471731.D0,  457042260.D0,      
     $  531664183.D0,  531664183.D0,  525224768.D0,  525224767.D0,      
     $  573727184.D0,  512972074.D0,  549225360.D0,  497418453.D0,      
     $  510801511.D0,  520623984.D0,  501266282.D0,  502986625.D0,      
     $  526887598.D0,  515152633.D0,  470800624.D0,  448276146.D0,      
     $  501444259.D0,  483347713.D0,  515452421.D0,  585480619.D0,      
     $  479413814.D0,  549866295.D0,  561015607.D0,  603898762.D0,      
     $  550269122.D0,  550269122.D0,  529966523.D0,  503319486.D0,      
     $         92.D0,         92.D0,   2 * 0.D0/
      DATA IS1 /                                                        
     $  20,   1,  11,  10,  16,   5,  17,  12,  15,  13,   9,   4,      
     $   2,  18,   6,   3,   7,  19,   8,  14/
      DATA IS2 /                                                        
     $  64,   0,   6,   0,   5,   1,   1, 21081, 21080/
C
C   Initialize.  MCR is set to 5 so that the advanced routines can be tested
C   with reasonably short run times.
C
      NW = NX
      MCR = 5
      IMS = NS
      CALL MPINIX (MX)
C
C   Test the input/output conversion routines.
C
      KT = 1
      ZA = '10 ^ - 50 x - 3. 14159 26535 89793 23846 26433 83279 50288'
      READ (ZA, '(80A1)') (Z(I), I = 1, 80)
      CALL MPINPC (Z, 80, A)
      LS = 9
      IF (DSUM (LS, A) .NE. DS(KT)) CALL DERR (KT, LS, A)
      WRITE (6, 1) KT
 1    FORMAT ('COMPLETED TEST',I3)
C
      KT = 2
      ZA ='10 ^       -50 x -3.14159265358979323846264338327950288'
      CALL MPOUTC (A, Z, NN)
      NN = MIN (NN, 55)
C
      DO 100 J = 1, NN
        IF (Z(J) .NE. ZA(J:J)) THEN
          WRITE (6, 2) KT, (Z(I), I = 1, NN)
 2        FORMAT ('TESTMP FAILED ON TEST NO.',I4/'RESULT: ',60A1)
          GOTO 110
        ENDIF
 100  CONTINUE
C
 110  WRITE (6, 1) KT
C
C   Compute 3. ^ (-13).
C
      KT = 3
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 3.
      NN = -13
      LS = NW + 2
      CALL MPNPWR (F1, NN, A)
      IF (DSUM (LS, A) .NE. DS(KT)) CALL DERR (KT, LS, A)
      WRITE (6, 1) KT
C
      KT = 4
      LS = NW
      CALL MPNPWX (F1, NN, A)
      IF (DSUM (LS, A) .NE. DS(KT)) CALL DERR (KT, LS, A)
      WRITE (6, 1) KT
C
C   Compute (4 - i) ^ (-25).
C
      KT = 5
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 4.
      F2(1) = -1.
      F2(2) = 0.
      F2(3) = 1.
      CALL MPMMPC (F1, F2, N4, X)
      NN = -25
      LS = NW + 2
      CALL MPCPWR (N4, X, NN, Y)
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
      KT = 6
      IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1))
      WRITE (6, 1) KT
C
      KT = 7
      LS = NW
      CALL MPCPWX (N4, X, NN, Y)
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
      KT = 8
      IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1))
      WRITE (6, 1) KT
C
C   Compute Sqrt (Sqrt (10)).
C
      KT = 9
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 10.
      CALL MPSQRT (F1, A)
      CALL MPSQRT (A, B)
      LS = NW + 2
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 10
      LS = NW
      CALL MPSQRX (A, B)
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Cbrt (Sqrt (10)).
C
      KT = 11
      CALL MPCBRT (A, B)
      LS = NW + 2
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 12
      LS = NW
      CALL MPCBRX (A, B)
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute the 10th root of 10.
C
      KT = 13
      CALL MPNRT (F1, 10, B)
      LS = NW + 2
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 14
      LS = NW
      CALL MPNRTX (F1, 10, B)
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute the complex square root of (2., 1.).
C
      KT = 15
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 2.
      F2(1) = 1.
      F2(2) = 0.
      F2(3) = 1.
      CALL MPMMPC (F1, F2, N4, X)
      CALL MPCSQR (N4, X, Y)
      LS = NW + 1
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
      KT = 16
      IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1))
      WRITE (6, 1) KT
C
      KT = 17
      CALL MPCSQX (N4, X, Y)
      LS = NW
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
      KT = 18
      IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1))
      WRITE (6, 1) KT
C
C   Compute Pi.
C
      KT = 19
      CALL MPPI (B)
      LS = NW + 2
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
      CALL MPEQ (B, PI)
C
      KT = 20
      LS = NW
      CALL MPPIX (B)
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Log (2).
C
      KT = 21
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 2.
      CALL MPLOG (F1, AL2, B)
      LS = NW + 2
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
      CALL MPEQ (B, AL2)
C
      KT = 22
      CALL MPLOGX (F1, PI, AL2, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Log (10).
C
      KT = 23
      F1(3) = 10.
      CALL MPLOG (F1, AL2, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 24
      CALL MPLOGX (F1, PI, AL2, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Log (1/4).
C
      KT = 25
      F1(2) = -1
      F1(3) = 0.25D0 * BDX
      CALL MPLOG (F1, AL2, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 26
      CALL MPLOGX (F1, PI, AL2, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Exp (1).
C
      KT = 27
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      CALL MPEXP (F1, AL2, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 28
      CALL MPEXPX (F1, PI, AL2, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Exp (2).
C
      KT = 29
      F1(3) = 2.
      CALL MPEXP (F1, AL2, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 30
      CALL MPEXPX (F1, PI, AL2, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Exp (-5).
C
      KT = 31
      F1(1) = -1.
      F1(3) = 5.
      CALL MPEXP (F1, AL2, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 32
      CALL MPEXPX (F1, PI, AL2, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Cos and Sin of Pi/4.
C
      KT = 33
      CALL MPMULD (PI, 0.25D0, 0, A)
      CALL MPCSSN (A, PI, X, Y)
      LS = NW + 1
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 34
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
      KT = 35
      CALL MPCSSX (A, PI, X, Y)
      LS = NW
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 36
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
C   Compute Cos and Sin of 39/64 Pi.
C
      KT = 37
      CALL MPMULD (PI, 0.609375D0, 0, A)
      CALL MPCSSN (A, PI, X, Y)
      LS = NW + 1
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 38
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
      KT = 39
      CALL MPCSSX (A, PI, X, Y)
      LS = NW - 1
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 40
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
C   Compute Cos and Sin of -19/64 Pi.
C
      KT = 41
      CALL MPMULD (PI, -0.296875D0, 0, A)
      CALL MPCSSN (A, PI, X, Y)
      LS = NW + 1
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 42
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
      KT = 43
      CALL MPCSSX (A, PI, X, Y)
      LS = NW - 1
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 44
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
C   Compute inverse Cos and Sin of (1, 1).
C
      KT = 45
      F1(1) = 1.
      F1(2) = 0.
      F1(3) = 1.
      F2(1) = 1.
      F2(2) = 0.
      F2(3) = 1.
      CALL MPANG (F1, F2, PI, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 46
      CALL MPANGX (F1, F2, PI, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute inverse Cos and Sin of (1, 5).
C
      KT = 47
      F2(3) = 5.
      CALL MPANG (F1, F2, PI, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 48
      CALL MPANGX (F1, F2, PI, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute inverse Cos and Sin of (-1, 3).
C
      KT = 49
      F1(1) = -1.
      F2(3) = 3.
      CALL MPANG (F1, F2, PI, B)
      LS = NW + 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
      KT = 50
      CALL MPANGX (F1, F2, PI, B)
      LS = NW - 1
      IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B)
      WRITE (6, 1) KT
C
C   Compute Cosh and Sinh of 0.5.
C
      KT = 51
      F1(1) = 1.
      F1(2) = -1.
      F1(3) = 0.5D0 * BDX
      CALL MPCSSH (F1, AL2, X, Y)
      LS = NW + 1
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 52
      IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
      KT = 53
      CALL MPCSHX (F1, PI, AL2, X, Y)
      LS = NW - 2
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
      KT = 54
      IF (ABS (DSUM (LS, Y) - DS(KT)) .GT. 1) CALL DERR (KT, LS, Y)
      WRITE (6, 1) KT
C
C   Compute the root near x = 1.42 + 0.69i of the polynomial
C   x^7 + 2 x^5 + 5 x^4 - 8 x^3 - 15 x^2 + 24 x + 40 = 0.
C
      KT = 55
      X1(1) = 1.42D0
      NX1(1) = 0
      X1(2) = 0.69D0
      NX1(2) = 0
      CALL MPCPOL (N - 1, L, AC, X1, NX1, N4, X)
      LS = NW + 2
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
      KT = 56
      IF (DSUM (LS, X(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, X(N4+1))
      WRITE (6, 1) KT
C
      KT = 57
      CALL MPCPLX (N - 1, L, AC, X1, NX1, N4, X)
      LS = NW
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
      KT = 58
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
C   Compute the real root of the above polynomial near x = -1.34.
C
      KT = 59
      T1 = -1.34D0
      N1 = 0
      CALL MPPOL (N - 1, L, AA, T1, N1, X)
      LS = NW + 2
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      CALL MPEQ (X, Y)
      WRITE (6, 1) KT
C
      KT = 60
      CALL MPPOLX (N - 1, L, AA, T1, N1, X)
      LS = NW
      IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X)
      WRITE (6, 1) KT
C
C   Recover the above polynomial from the computed value of the root.
C
      KT = 61
      CALL MPEQ (Y, XX)
C
      DO 120 K = 2, N
        CALL MPMUL (Y, XX(1,K-1), XX(1,K))
 120  CONTINUE
C
      DO 140 K = 1, N
        DO 130 J = 1, L
          AA(J,K) = 0.
 130    CONTINUE
 140  CONTINUE
C
      CALL MPINRL (N, NX + 4, XX, 5, MT, L, AA, IQ)
      IF (DSUM (LN, AA) .NE. DS(KT)) CALL DERR (KT, LN, AA)
      WRITE (6, 1) KT
C
      KT = 62
C
      DO 160 K = 1, N
        DO 150 J = 1, L
          AA(J,K) = 0.
 150    CONTINUE
 160  CONTINUE
C
      CALL MPINRX (N, NX + 4, XX, 5, MT, L, AA, IQ)
      IF (DSUM (LN, AA) .NE. DS(KT)) CALL DERR (KT, LN, AA)
      WRITE (6, 1) KT
C
C   Sort a pseudo-randomly generated vector.
C
      KT = 63
C
      DO 170 J = 1, NP
        CALL MPRAND (XX(1,J))
 170  CONTINUE
C
      CALL MPSORT (NP, N4, XX, IP)
      IF (ICHK (NP, IP, IS1) .NE. 0) CALL IERR (KT, NP, IP)
      WRITE (6, 1) KT
C
C   Check if parameters in MPCOM1 are correct.
C
      KT = 64
      IF (ICHK (9, NW, IS2) .NE. 0) CALL IERR (KT, 9, NW)
      WRITE (6, 1) KT
C
      STOP
      END
C
      FUNCTION DSUM (N, A)
      DOUBLE PRECISION DSUM, S
      DIMENSION A(N)
C
      S = 0.D0
C
      DO 100 I = 1, N
        S = S + A(I)
 100  CONTINUE
C
      DSUM = S
      RETURN
      END
C
      SUBROUTINE DERR (N, L, A)
      DOUBLE PRECISION DSUM
      DIMENSION A(L)
      CHARACTER*1 CX(1000)
C
      WRITE (6, 1) N
 1    FORMAT ('TESTMP FAILED ON TEST NO.',I4)
      WRITE (6, 2) (A(I), I = 1, L)
 2    FORMAT ('RESULT:'/(6F12.0))
      CALL MPOUT (6, A, INT (7.225 * (L - 2)), CX)
      WRITE (6, 3) DSUM (L, A)
 3    FORMAT ('CHECKSUM:', F20.0)
      RETURN
      END
C
      FUNCTION ICHK (N, IA, IB)
      DIMENSION IA(N), IB(N)
C
      IS = 0
C
      DO 100 I = 1, N
        IS = IS + ABS (IA(I) - IB(I))
 100  CONTINUE
C
      ICHK = IS
      RETURN
      END
C
      SUBROUTINE IERR (N, L, IA)
      DIMENSION IA(L)
C
      WRITE (6, 1) N
 1    FORMAT ('TESTMP FAILED ON TEST NO.',I4)
      WRITE (6, 2) (IA(I), I = 1, L)
 2    FORMAT ('RESULT:'/(8I9))
      RETURN
      END
C   This is the test program 'testran.f' for TRANSMP.
C
C   David H. Bailey     June 10, 1992
C
CMP+ PRECISION LEVEL 100
CMP+ MIXED MODE FAST
CMP+ OUTPUT PRECISION 56
CMP+ EPSILON 1E-110
C
      PROGRAM TESTRAN
CMP+ IMPLICIT MULTIP REAL (A-H, O-Z)
CMP+ MULTIP INTEGER IA, IB, IC
CMP+ MULTIP REAL A, B
CMP+ MULTIP COMPLEX C, D, E
      PARAMETER (N = 25)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION A(N), B(N)
      DOUBLE COMPLEX C, D, E, DPCMPL
C
C   MP parameter definitions.
C
      PARAMETER (DPEPS = 1D-15, DPPIC = 3.141592653589793D0)
C
      EE = EXP (1.D0+0)
      WRITE (6, *) DPPIC, EE
      S = 0.D0
C
C   Loop with subscripted MP variables.
C
      DO 100 I = 1, N
        A(I) = 2 * I + 1
        B(I) = 2.D0 * A(I) * (A(I) + 1.D0)
        S = S + B(I) ** 2
 100  CONTINUE
C
      WRITE (6, *) S
C
C   An expression with mixed MPI and MPR entities.
C
      IA = S
      IB = 262144
      S = (S + 327.25D0) * MOD (IA, 4 * IB)
      WRITE (6, *) S
C
C   A complex square root reference.
C
      E = SQRT (DPCMPL (2.D0 * S, S))
      WRITE (6, *) E
C
C   External and intrinsic MP function references in expressions.
C
      S = DOT (N, A, B)
      T = 2.D0 * SQRT (S) ** 2
      WRITE (6, *) S, T
      S = S / 1048576.D0
      T = S + 2.D0 * LOG (S)
      X = 3 + NINT (T) * 5
      WRITE (6, *) S, T, X
C
C   Deeply nested expressions and function references.
C
      X = (S + (2 * (S - 5) + 3 * (T - 5))) * EXP (COS (LOG (S)))
      WRITE (6, *) X
C
C   A "special" subroutine call (computes both cos and sin of S).
C
      CALL DPCSSN (S, X, Y)
      T = 1.D0 - (X ** 2 + Y ** 2)
C
C   IF-THEN-ELSE construct involving MP variables.
C
      IF (S .GT. 0. .AND. T .LT. DPEPS) THEN
        WRITE (6, *) T
      ELSE
        WRITE (6, *) DPEPS
      ENDIF
C
      STOP
      END
C
C   MP function subprogram.
C
CMP+ MULTIP REAL A, B, DOT, S
      FUNCTION DOT (N, A, B)
      DOUBLE PRECISION A(N), B(N), DOT, S
C
      S = 0.D0
C
      DO 100 I = 1, N
        S = S + A(I) * B(I)
 100  CONTINUE
C
      DOT = S
      RETURN
      END
C
C   DP equivalent of special subroutine DPCSSN.
C
      SUBROUTINE DPCSSN (A, X, Y)
      DOUBLE PRECISION A, X, Y
      X = COS (A)
      Y = SIN (A)
      RETURN
      END
C
C   DP equivalent is special function DPCMPL.
C
      FUNCTION DPCMPL (A, B)
      DOUBLE COMPLEX DPCMPL
      DOUBLE PRECISION A, B
      DPCMPL = DCMPLX (A, B)
      RETURN
      END
      PROGRAM TRANSMP
C
C   This translates a standard Fortran-77 code input on standard input (unit 5)
C   to a code that calls DHB's MPFUN multiprecision routines, which is output
C   on standard output (unit 6).  This output program may then be compiled and
C   linked with the MPFUN library file.
C
C   Version Date:   June 30, 1992
C
C   Author:
C
C      David H. Bailey                 Telephone:   415-604-4410
C      NASA Ames Research Center       Facsimile:   415-604-3957
C      Mail Stop T045-1                Internet:    dbailey@nas.nasa.gov
C      Moffett Field, CA 94035
C
C   Restrictions:
C
C   This software has now been approved by NASA for unrestricted distribution.
C   However, usage of this software is subject to the following:
C
C   1. This software is offered without warranty of any kind, either expressed
C      or implied.  The author would appreciate, however, any reports of bugs
C      or other difficulties that may be encountered.
C   2. If modifications or enhancements to this software are made to this
C      software by others, NASA Ames reserves the right to obtain this enhanced
C      software at no cost and with no restrictions on its usage.
C   3. The author and NASA Ames are to be acknowledged in any published paper
C      based on computations using this software.  Accounts of practical
C      applications or other benefits resulting from this software are of
C      particular interest.  Please send a copy of such papers to the author.
C
C******************************************************************************
C
C   The following information is a brief description of this program.  For
C   full details and instructions for usage, see the paper "Automatic
C   Translation of Fortran to Multiprecision", available from the author.
C   This program works in conjunction with MPFUN, the author's package of
C   multiprecision functions.
C
C   This translation program allows one to extend the Fortran-77 language
C   with the data types MULTIP INTEGER, MULTIP REAL and MULTIP COMPLEX.
C   These data types can be used for integer, floating point or complex
C   numbers of an arbitrarily high but pre-specified level of precision.
C   Variables in the input program may be declared to have one of these
C   multiprecision types in the output program by placing directives
C   (special comments) in the input file.  In this way, the input file
C   remains an ANSI Fortran-77 compatible program and can be run at any
C   time using ordinary arithmetic on any Fortran system for comparison
C   with the multiprecision equivalent.
C
C   This translator program should run on any Fortran-77 system that supports
C   recursive subroutine references.  On some systems, including Sun and IBM
C   workstations, two non-standard IMPLICIT AUTOMATIC statements must be
C   uncommented in this file to permit recursion.  These and other instances
C   of machine-dependent code are marked below with C>.
C
C   Instructions for compiling and testing this program are included in the
C   readme file that accompanies this code.
C
C******************************************************************************
C
C   This is the start of the main program of the translator.  In each
C   subprogram below, C+ delimits common data specifications.  Specifications
C   following the second C+ are for local variables.  C* comments delimit
C   debug printout code.  C> comments indicate machine-dependent code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 LIN, ARG(MAR)
      CHARACTER*16 LINQ, NAMQ, NUMX, UCASE
      DIMENSION ITAR(MAR), LAR(MAR)
C
C   Start of input program file -- initialize and read first line.
C
      IMM = 1
      ITE = 1
      MPP = 0
      MSS = 0
      MXP = 0
      IEOF = 0
C*
C   Uncomment one of the next two lines -- the first for normal use, the
C   second for debug.
C
      OPEN (11, STATUS = 'SCRATCH')
C      open (11, file = 'scratch')
C*
      OPEN (12, STATUS = 'SCRATCH')
      REWIND 11
      REWIND 12
      READ (5, '(A)', END = 150) LIN
      LC = 1
      L1 = 1
      L2 = LNBLK (LIN)
      LS = L2
      NVAR = MINT
      NAMQ = 'TANH'
      IQTANH = ITAB (0, 0, NAMQ)
C
C   Start processing a new subprogram.
C
 100  ISTP = 0
      NVAR = MINT
      IEX = 0
      IFL = 0
      KDO = 0
      LSM = 0
      MPA = 0
      MPF = 0
      MPT = 0
      IEND = 0
      LINE = ' '
C
C   Initialize the implicit type table and the special constant usage table.
C
      DO 110 I = 1, 26
        IMPL(I) = IMPS(I)
 110  CONTINUE
C
      DO 120 I = 1, 5
        KCON(I) = 0
 120  CONTINUE
C
C   Start reading a new statement.
C
 130  LN = 0
      LCT = LC
C
 140  CONTINUE
      LL = L2 - L1 + 1
      LINE(LN+1:LN+LL) = LIN(L1:L2)
      LN = LN + LL
      READ (5, '(A)', END = 150) LIN
      LC = LC + 1
      L1 = 1
      L2 = LNBLK (LIN)
      IF (LIN(1:1) .EQ. 'C' .OR. LIN(1:1) .EQ. 'c' .OR. L2 .EQ. 0)      
     $  GOTO 160
      IF (L2 .GT. 72) THEN
        WRITE (11, 1) LC
 1      FORMAT ('CMP*'/'CMP* Characters past column 72 in line',I6,     
     $    ' are ignored.'/'CMP*')
        L2 = 72
      ENDIF
      IF (LIN(6:6) .NE. ' ') THEN
        K1 = 72 - LS
        IF (K1 .GE. 1) LINE(LN+1:LN+K1) = ' '
        LN = LN + K1
        L1 = 7
        LS = L2
        GOTO 140
      ENDIF
      LS = L2
      GOTO 160
C
C   The end of file has been encountered.
C
 150  IEOF = 1
C
C   A complete multiline statement has been read.  Check if it is a comment.
C
 160  CONTINUE
C
C   Optionally print out current statement.
C*
C      write (6, *) '%'//line(1:ln)//'%'
C*
      LQ = MIN (16, LN)
      LINQ = UCASE (LINE(1:LQ))
      IF (LN .EQ. 0 .OR. LINQ(1:1) .EQ. 'C') THEN
C
C   Check if this comment is a MP directive.
C
        CALL OUTLIN (0, LN, LINE)
        IF (LN .GE. 4 .AND. LINQ(1:4) .EQ. 'CMP+') CALL MPDEC (LN)
        GOTO 240
      ENDIF
      K1 = NBLK (7, LN, LINE)
      LQ = MIN (K1 + 15, LN)
      LINQ = UCASE (LINE(K1:LQ))
C
C   Check if this is an end statement.
C
      IF (LINQ(1:5) .EQ. 'END  ') THEN
        IEND = 1
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   If the executable portion of this subprogram has already been encountered,
C   and if this subprogram contains no MP variables, there is no need to check
C   the line any further.
C
      IF (IEX .NE. 0 .AND. MPT .EQ. 0) THEN
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Check if this line is a program, subroutine, function or block data
C   statement.
C
      IF (IPFSB (K1, LN) .NE. 0) GOTO 240
C
C   At the beginning of a subprogram, one of the above should have been noted.
C
      IF (ISTP .EQ. 0) THEN
        CALL ERRMES (1, 0)
        WRITE (6, 2)
 2      FORMAT ('PROGRAM, SUBROUTINE, FUNCTION, or BLOCK DATA',         
     $    ' statement is missing.')
        CALL ABRT
      ENDIF
C
C   Check if it is an implicit statement.
C
      IF (LINQ(1:8) .EQ. 'IMPLICIT') THEN
        IF (IEX .NE. 0) GOTO 250
        K1 = NBLK (K1 + 8, LN, LINE)
        CALL IMPLIC (K1, LN)
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Check if it is a type statement.
C
 170  IT = NTYPE (K1, LN)
      IF (IT .NE. 0) THEN
        IF (IEX .NE. 0) GOTO 250
        CALL TYPE (IT, K1, LN)
        GOTO 240
      ENDIF
C
C   Check if it is a parameter statement.
C
      IF (LINQ(1:9) .EQ. 'PARAMETER') THEN
        IF (IEX .NE. 0) GOTO 250
        I1 = ISCAN (K1 + 9, LN, LINE)
        IF (I1 .GE. 1) THEN
          K1 = K1 + 9
          CALL OUTLIN (2, LN, LINE)
          CALL PARAM (K1, LN)
        ELSE
          CALL OUTLIN (1, LN, LINE)
        ENDIF
        GOTO 240
      ENDIF
C
C   Check if it is a dimension statement.
C
      IF (LINQ(1:9) .EQ. 'DIMENSION') THEN
        IF (IEX .NE. 0) GOTO 250
        CALL DIMEN (K1 + 9, LN)
        GOTO 240
      ENDIF
C
C   Check if it is a common statement.
C
      IF (LINQ(1:6) .EQ. 'COMMON') THEN
        IF (IEX .NE. 0) GOTO 250
        K1 = K1 + 6
        I1 = INDX (K1, LN, '/', LINE)
        IF (I1 .NE. 0) THEN
          I2 = INDX (I1 + 1, LN, '/', LINE)
          IF (I2 .EQ. 0) CALL ERRMES (2, 1)
          K1 = I2 + 1
        ENDIF
        CALL DIMEN (K1, LN)
        GOTO 240
      ENDIF
C
C   Check if it is an equivalence statement.
C
      IF (LINQ(1:11) .EQ. 'EQUIVALENCE') THEN
        IF (IEX .NE. 0) GOTO 250
        CALL OUTLIN (2, LN, LINE)
C
C   Append '1,' to subscripted MP variables.
C
        K2 = LN
        CALL FIXSUB (K1 + 11, K2, LN)
        CALL OUTLIN (1, LN, LINE)
        WRITE (11, 3)
 3      FORMAT ('CMP<')
        GOTO 240
      ENDIF
C
C   Check if it is an external, intrinsic or save statement.  No processing is
C   done for these, except to enter names into the symbol table.
C
      IF (LINQ(1:8) .EQ. 'EXTERNAL' .OR. LINQ(1:9) .EQ. 'INTRINSIC' .OR.
     $  LINQ(1:5) .EQ. 'SAVE ') THEN
        IF (IEX .NE. 0) GOTO 250
        K2 = K1 - 1 + INDEX (LINE(K1:LN), ' ')
        I1 = ISCAN (K2 + 1, LN, LINE)
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Check if this is the start of the executable part of the subprogram.
C
      IF (IEX .EQ. 0) THEN
        IEX = 1
C
C   Check if the subprogram name is valid and set its type.  The type of a
C   program or subroutine name is set to 0 (undefined), whereas the type of
C   a function name is set according to previous implicit or type statements.
C
        IX = ITAB (1, 0, FNAM)
        IF (IX .LE. IQTANH) THEN
          CALL ERRMES (3, 0)
          WRITE (6, 4)
 4        FORMAT ('This name may not be used as a subroutine or',       
     $      ' function name.')
          CALL ABRT
        ELSEIF (IX .GT. MINT .AND. ISTP .EQ. 3 .AND. KTYP(IX) .GE. 8    
     $      .AND. KDIM(IX) .NE. -2) THEN
          CALL ERRMES (4, 0)
          WRITE (6, 5)
 5        FORMAT ('MP function names must be declared with an explicit' 
     $      ' MP type directive'/'immediately preceding the function',  
     $      ' statement.')
          CALL ABRT
        ENDIF
        KDEC(IX) = 1
        IF (ISTP .NE. 3) KTYP(IX) = 0
C
C   Parse the argument list of this subprogram, compare with the subprogram
C   table, and add it if it is not there.
C
        CALL ARLIST (11, LSAR, SARG, NAR, ITAR, LAR, ARG)
        CALL CHKARG (11, FNAM, NAR, ITAR, LAR, ARG)
C
C   If any MP variables have been defined, or if this is the main program,
C   Insert a marker in the temporary file to mark the location of the MP
C   declarations for INIMP.
C
        IF (MPT .NE. 0 .OR. ISTP .EQ. 1) THEN
          WRITE (11, 6)
 6        FORMAT ('CMP>>>')
        ENDIF
C
C   If no MP variables have been identified, there is no need to further
C   analyze the statement.
C
        IF (MPT .EQ. 0) THEN
          CALL OUTLIN (1, LN, LINE)
          GOTO 240
        ENDIF
      ENDIF
C
C   Check if this is a data statement.
C
      IF (LINQ(1:5) .EQ. 'DATA ') THEN
        I1 = ISCAN (K1 + 5, LN, LINE)
        IF (I1 .NE. 0) GOTO 260
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Check if this is an endif statement.  If so, previous if blocks
C   generated as translations of elseif statements must be closed.
C
      IF (LINQ(1:5) .EQ. 'ENDIF' .OR. LINQ(1:6) .EQ. 'END IF') THEN
        IF (IFL .GT. 0) THEN
C
          DO 180 I = 1, IFL
            WRITE (11, 7)
 7          FORMAT (6X,'ENDIF')
 180      CONTINUE
C
          IFL = 0
        ENDIF
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Nothing needs to be processed for these non-executable statements.
C
      IF (LINQ(1:6) .EQ. 'ELSE  ' .OR. LINQ(1:6) .EQ. 'ENDDO ' .OR.     
     $  LINQ(1:7) .EQ. 'END DO ' .OR. LINQ(1:8) .EQ. 'CONTINUE' .OR.    
     $  LINQ(1:6) .EQ. 'FORMAT') THEN
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Nothing needs to be processed for these executable statements.
C
      IF (LINQ(1:5) .EQ. 'CLOSE' .OR. LINQ(1:5) .EQ. 'GOTO ' .OR.       
     $  LINQ(1:4) .EQ. 'OPEN' .OR. LINQ(1:5) .EQ. 'STOP ' .OR.          
     $  LINQ(1:9) .EQ. 'BACKSPACE' .OR. LINQ(1:7) .EQ. 'ENDFILE' .OR.   
     $  LINQ(1:7) .EQ. 'INQUIRE' .OR. LINQ(1:6) .EQ. 'RETURN' .OR.      
     $  LINQ(1:6) .EQ. 'REWIND') THEN
      CALL OUTLIN (1, LN, LINE)
      GOTO 240
      ENDIF
C
C   Check if the statement is a DO statement.  If so, place the DO terminal
C   number in the IDON table.
C
      IF (LINQ(1:3) .EQ. 'DO ') THEN
        K1 = NBLK (K1 + 3, LN, LINE)
        I1 = ISCAN (K1, LN, LINE)
        IF (I1 .NE. 0) GOTO 260
        IF (INDEX (DIG, LINE(K1:K1)) .NE. 0) THEN
          K2 = INDEX (LINE(K1:LN), ' ')
          IF (K2 .EQ. 0) CALL ERRMES (5, 1)
          K2 = K1 - 1 + K2
          NUMX = LINE(K1:K2)
          READ (NUMX, '(BN,I16)', ERR = 270) K
          KDO = KDO + 1
          IF (KDO .GT. NDO) THEN
            CALL ERRMES (6, 0)
            WRITE (6, 8)
 8          FORMAT ('Too many DO statements in this subprogram.')
            CALL ABRT
          ENDIF
          IDON(KDO) = K
        ENDIF
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Check if statement has any MP variables.  If not, there is no need for
C   any further analysis.
C
      I1 = ISCAN (K1, LN, LINE)
      IF (I1 .EQ. 0) THEN
        CALL OUTLIN (1, LN, LINE)
        GOTO 240
      ENDIF
C
C   Output original statement as a comment.
C
      CALL OUTLIN (2, LN, LINE)
C
C   Check if a line number is presesnt.  If so, output as a continue statement.
C
      READ (LINE(1:5), '(BN,I5)', ERR = 270) K
      IF (K .LT. 0 .OR. K .GE. 10000) GOTO 270
      IF (K .NE. 0) THEN
C
        DO 190 I = 1, KDO
          IF (K .EQ. IDON(I)) THEN
            CALL ERRMES (7, 0)
            WRITE (6, 9)
 9          FORMAT ('MP variables may not appear in the terminal line', 
     $        ' of a DO loop.')
            CALL ABRT
          ENDIF
 190    CONTINUE
C
        WRITE (11, 10) K
 10     FORMAT (I5,' CONTINUE')
      ENDIF
C
C   Check if this is a logical if or elseif statement with MP variables.
C
      IF (LINQ(1:2) .EQ. 'IF') THEN
        K3 = NBLK (K1 + 2, LN, LINE)
        IF (LINE(K3:K3) .NE. '(') GOTO 200
        CALL IFST (IFL, 1, K3, LN)
        GOTO 210
      ELSEIF (LINQ(1:6) .EQ. 'ELSEIF') THEN
        K3 = NBLK (K1 + 6, LN, LINE)
        CALL IFST (IFL, 2, K3, LN)
        GOTO 210
      ELSEIF (LINQ(1:7) .EQ. 'ELSE IF') THEN
        K3 = NBLK (K1 + 7, LN, LINE)
        CALL IFST (IFL, 2, K3, LN)
        GOTO 210
      ENDIF
C
C   Fix subscripts of MP variables and change names of special constants.
C
 200  K2 = LN
      CALL FIXSUB (K1, K2, LN)
C
C   Process other kinds of MP executable statements.
C
      CALL EXEC (K1, LN)
C
C   Insert a comment to mark the end of the translation of the MP executable
C   statement.
C
 210  WRITE (11, 3)
C
C   Check if the itmp table is properly zeroed.  If not, one of the routines
C   dealing with MP statements erred.
C
      DO 230 J = 1, NTYP
        DO 220 I = 1, 9
          IF (ITMP(I,J) .NE. 0) THEN
            CALL ERRMES (8, 0)
            WRITE (6, 11) CTM(J), I
 11         FORMAT ('Translator error: active temporary: MP',A1,I1/     
     $        'Please contact the author.')
            CALL ABRT
          ENDIF
 220    CONTINUE
 230  CONTINUE
C
C   If this is an end statement, copy the scratch file to the output file,
C   inserting MP declarations at the marker.
C
 240  IF (IEND .EQ. 1) THEN
        CALL COPY
        IF (IEOF .EQ. 1) STOP
        GOTO 100
      ELSE
        IF (IEOF .EQ. 1) THEN
          IF (ISTP .EQ. 0) STOP
          CALL ERRMES (9, 0)
          WRITE (6, 12)
 12       FORMAT ('The last line of the file was not an END statement.')
          CALL ABRT
        ENDIF
        GOTO 130
      ENDIF
C
 250  CALL ERRMES (10, 0)
      WRITE (6, 13)
 13   FORMAT ('A declarative statement may not appear after an',        
     $  ' executable statement.')
      CALL ABRT
C
 260  CALL ERRMES (11, 0)
      WRITE (6, 14)
 14   FORMAT ('MP variables may not appear in this statement.')
      CALL ABRT
C
 270  CALL ERRMES (12, 0)
      WRITE (6, 15)
 15   FORMAT ('Syntax error in line number.')
      CALL ABRT
C
      STOP
      END
C
      BLOCK DATA
C
C   This sets all data in common.  Here is a brief description of these
C   variables and arrays, in alphabetical order.
C
C   ALPL   Lower case alphabet.
C   ALPU   Upper case alphabet.
C   CTM    Table of one-character type abbreviations.
C   CTP    Table of two-character type abbreviations.
C   DEL    Standard Fortran delimiters.
C   DIG    The ten digits.
C   EPS    The mantissa and exponent of the current epsilon, in character form.
C   FNAM   The function name, in function subprograms.
C   IDON   DO line number table.
C   IEX    1 if the executable portion of the subprogram has been encountered.
C   IMM    Mixed mode option (0:FAST, 1:SAFE).
C   IMPL   Implicit type definition table.
C   IMPS   Default implicit type definitions.
C   ISTP   Type of subprogram (1:PROGRAM, 2:SUBROUTINE, 3:FUNCTION, 4: BLOCK D)
C   ITE    Type error option (0:OFF, 1:ON).
C   ITMP   MP temporary usage table.
C   KCON   Special constant usage table.
C   KDEC   MP variable declaration table.
C   KDIM   Dimension and misc. information for names in VAR:
C          -3   Special constant or parameter.
C          -2   MP function name (within its defining subprogram).
C          -1   Function name.
C           0   Scalar variable.
C           1   Dimensioned variable.
C           2-10   Indicates number of dimensions (not yet implemented).
C   KDO    Number of entries in DO number table.
C   KEYW   Table of Fortran keywords.
C   KOP    Operator precedence table.
C   KSTP   Table of types of subroutine argument lists.
C   KTYP   Types of variables in VAR:
C          -1   Dependent on argument (for intrinsic function names)
C           0   Undefined
C           1   Integer
C           2   Real
C           3   Double Precision
C           4   Complex
C           5   Double Complex
C           6   Character
C           7   Logical
C           8   MP Integer
C           9   MP Real
C          10   MP Complex
C   LCT    Current line count.
C   LEP    Lengths of epsilon strings.
C   LINE   Current extended working line read from file.
C   LOP    Lengths of operators in LOPR and UOPR.
C   LOPR   Lower case operators.
C   LSAR   Length of subroutine argument list.
C   LSM    Longest numeric string in current subprogram.
C   LVAR   Lengths of the names in VAR.
C   MPA    Number of MP parameters in current subprogram.
C   MPLC   Table of implicit/explicit status of names in VAR.
C   MPP    Current output precision level.
C   MPT    Set to 1 if an MP variable has been encountered in subprogram.
C   MSS    Scratch space.
C   MXP    Maximum precision level in words.
C   NARS   Table of number of arguments in argument list array KSTP.
C   NSUB   Number of subprograms encountered.
C   NVAR   Number of variables defined in current subprogram (including
C          standard and MP intrinsic names).
C   SARG   Argument list of current subprogram.
C   SNAM   Table of subroutine names.
C   UOPR   Upper case operators.
C   VAR    Table of variable names for current subprogram.
C
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      PARAMETER (NP1 = MVAR - MINT, NPC = 5, NPI = 36, NPF = 6, NPS = 2)
      DATA IDON /NDO * 0/
      DATA IMPL /26 * 0/
      DATA IMPS /8 * 2, 6 * 1, 12 * 2/
      DATA KDEC /MINT * 1, NP1 * 0/
      DATA KDIM /10 * -3, 44 * -1, NP1 * 0/
      DATA KTYP /1, 4 * 3, 1, 4 * 9, 3 * -1, 4, 4 * -1, 6, 4, 3 * -1, 3,
     $  5, -1, 5, 5, -1, 4 * 1, 6 * -1, 2, 6 * -1, 8, 10, 4 * 9, 2 * 9, 
     $  NP1 * 0/
      DATA LVAR /10 * 5, 3, 4, 4, 5, 5, 4, 4, 5, 4, 5, 5, 3, 4, 4, 6, 3,
     $  5, 5, 3, 5, 5, 3, 3, 3, 5, 3, 3, 3, 4, 4, 4, 3, 4, 4, 3, 4, 5,  
     $  6, 6, 6, 5, 6, 6, 6, NP1 * 0/
      DATA KOP /1, 6, 6, 8, 7, 7, 5, 5, 5, 5, 5, 5, 3, 4/
      DATA LOP /1, 1, 1, 2, 1, 1, 4, 4, 4, 4, 4, 4, 4, 5/
      DATA LEP /2 * 0/
      DATA MPLC /NPC * 0, NPC * 1, NPI * 1, NPF * 0, NPS * 1, NP1 * 1/
      DATA ALPL /'abcdefghijklmnopqrstuvwxyz'/
      DATA ALPU /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      DATA DEL /' ,().=+-*/'/
      DATA DIG /'0123456789'/
      DATA CTM /'I', 'R', 'D', 'C', 'X', 'A', 'L', 'J', 'M', 'Z'/
      DATA CTP /'IN', 'SP', 'DP', 'CO', 'DC', 'CH', 'LO', 'MPI', 'MPR', 
     $  'MPC'/
      DATA EPS /2 * ' '/
      DATA KEYW/                                                        
     $  'BACKSPACE', 'BLOCK', 'CALL', 'CHARACTER', 'CLOSE', 'COMMON',   
     $  'COMPLEX', 'CONTINUE', 'DATA', 'DIMENSION', 'DO', 'DOUBLE',     
     $  'ELSE', 'ELSEIF', 'END', 'ENDFILE', 'ENDIF', 'ENTRY',           
     $  'EQUIVALENCE', 'EXTERNAL', 'FORMAT', 'FUNCTION', 'GO', 'GOTO',  
     $  'IF', 'IMPLICIT', 'INQUIRE', 'INTEGER', 'INTRINSIC', 'LOGICAL', 
     $  'OPEN', 'PARAMETER', 'PRECISION', 'PRINT', 'PROGRAM', 'READ',   
     $  'REAL', 'RETURN', 'REWIND', 'SAVE', 'STOP', 'SUBROUTINE',       
     $  'THEN', 'TO', 'WRITE'/
      DATA LOPR /'=', '+', '-', '**', '*', '/', '.eq.', '.ne.', '.gt.', 
     $  '.lt.', '.ge.', '.le.', '.or.', '.and.'/
      DATA SFUN/                                                        
     $  'ALOG', 'ALOG10', 'AMAX0', 'AMAX1', 'AMIN0', 'AMIN1', 'AMOD',   
     $  'CABS', 'CCOS', 'CEXP', 'CLOG', 'CSIN', 'CSQRT', 'DABS',        
     $  'DACOS', 'DASIN', 'DATAN', 'DATAN2', 'DCOS', 'DCOSH', 'DCOSH',  
     $  'DDIM', 'DEXP', 'DIM', 'DINT', 'DLOG', 'DLOG10', 'DMAX1',       
     $  'DMIN1', 'DMOD', 'DNINT', 'DPROD', 'DSIGN', 'DSIN', 'DSINH',    
     $  'DSQRT', 'DTAN', 'DTANH', 'FLOAT', 'IABS', 'IDIM', 'IDINT',     
     $  'IDNINT','IFIX', 'ISIGN', 'MAX0', 'MAX1', 'MIN0', 'MIN1',       
     $  'SNGL'/
      DATA VAR /                                                        
     $  'MPNWP', 'DPEPS', 'DPL02', 'DPL10', 'DPPIC', 'MPNWQ', 'MPEPS',  
     $  'MPL02', 'MPL10', 'MPPIC',                                      
     $  'ABS', 'ACOS', 'AINT', 'AIMAG', 'ANINT', 'ASIN', 'ATAN',        
     $  'ATAN2', 'CHAR', 'CMPLX', 'CONJG', 'COS', 'COSH', 'DBLE',       
     $  'DCMPLX', 'DIM', 'DIMAG', 'DREAL', 'EXP', 'ICHAR', 'INDEX',     
     $  'INT', 'LEN', 'LOG', 'LOG10', 'MAX', 'MIN', 'MOD', 'NINT',      
     $  'REAL', 'SIGN', 'SIN', 'SINH', 'SQRT', 'TAN', 'TANH',           
     $  'MPINT', 'DPCMPL', 'DPIMAG', 'DPREAL', 'DPNRT', 'DPRAND',       
     $  'DPCSSN', 'DPCSSH', NP1 * ' '/
      DATA UOPR /'=', '+', '-', '**', '*', '/', '.EQ.', '.NE.', '.GT.', 
     $  '.LT.', '.GE.', '.LE.', '.OR.', '.AND.'/
      END
C
      SUBROUTINE ABRT
C>
C   This terminates execution.  For debug purposes it may be preferable to
C   replace the standard STOP with a call to a system routine that produces
C   a traceback.
C
C   TRACBK is a traceback routine for SGI workstations.  The C code for this
C   routine is available from the author.
C
C      CALL TRACBK
C
      STOP
      END
C
      SUBROUTINE ARLIST (LU, LA, LINA, NAR, ITAR, LAR, ARG)
C
C   This processes an argument list in LINA, which has length LA.  Any
C   expressions in any argument are first processed with subroutine EXPRES.
C   The resulting argument list (NAR elements) is placed in ARG, with types
C   in ITAR and lengths in ARG.  LU is the logical unit number of output code.
C
C>  Uncomment this line on Sun and IBM worksations.
C
C     IMPLICIT AUTOMATIC (A-Z)
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA, LINB
      CHARACTER*80 ARG(MAR), ARGX
      DIMENSION ITAR(MAR), LAR(MAR)
C*
C      write (lu, *) 'enter arlist'
C      write (lu, *) '%'//lina(1:la)//'%'
C*
      K1 = 1
      NAR = 0
      IEND = 0
      IF (LA .EQ. 0) GOTO 120
C
 100  IF (K1 .GT. LA) CALL ERRMES (13, 1)
      K1 = NBLK (K1, LA, LINA)
      IF (K1 .EQ. 0) CALL ERRMES (14, 1)
      K2 = MATCH (1, K1, LA, LINA)
      IF (K2 .EQ. 0) THEN
        K2 = LA + 1
        IEND = 1
      ENDIF
      K2 = K2 - 1
      LB = K2 - K1 + 1
      LINB(1:LB) = LINA(K1:K2)
C
C   Evaluate the expression with EXPRES after setting the mixed mode option
C   to FAST, except if this is a parameter statement or an intrinsic function
C   reference.
C
      IMS = IMM
      IF (LU .NE. 12 .AND. IMM .NE. 2) IMM = 0
      CALL EXPRES (LU, LB, LINB, ITPX, LX, ARGX)
      IMM = IMS
C
C   Add this argument to the list.
C
 110  NAR = NAR + 1
      IF (NAR .GT. MAR) THEN
        CALL ERRMES (15, 0)
        WRITE (6, 1)
 1      FORMAT ('List has too many arguments.')
        CALL ABRT
      ENDIF
      ITAR(NAR) = ITPX
      LAR(NAR) = LX
      ARG(NAR)(1:LX) = ARGX(1:LX)
      K1 = K2 + 2
      IF (IEND .EQ. 0) GOTO 100
C
 120  CONTINUE
C*
C      write (lu, *) 'exit arlist  args:'
C      do 111 i = 1, nar
C        write (lu, *) '%'//arg(i)(1:lar(i))//'%'
C 111    continue
C*
      RETURN
      END
C
      SUBROUTINE ASST (K1, LN)
C
C   This processes MP assignment statements.  K1 and LN are the indices of the
C   first and last non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*80 ARGX
C
C   Evaluate the entire statement as an expression.
C
      LA = LN - K1 + 1
      LINA(1:LA) = LINE(K1:LN)
      CALL EXPRES (11, LA, LINA, ITPX, LX, ARGX)
C
C   Check if the final result of evaluation of the expression is non-empty.
C   If so, then the last operation was not an equal operation, and thus the
C   statement is not a valid assignment statement.
C
      IF (LX .NE. 0) THEN
        CALL ERRMES (16, 0)
        WRITE (6, 1)
 1      FORMAT ('This is not a valid MP assignment statement.')
        CALL ABRT
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE CALLST (K1, LN)
C
C   This processes MP call statements.  K1 and LN are the indices of the
C   first (after 'call') and last non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA, LINB
      CHARACTER*80 ARG(MAR)
      CHARACTER*16 NAMQ, NAMX
      DIMENSION ITAR(MAR), LAR(MAR)
      CHARACTER*4 TMP1
C
C   Identify subroutine name.
C
      I1 = INDX (K1, LN, '(', LINE)
      L1 = MIN (I1 - K1, 16)
      NAMX = LINE(K1:K1+L1-1)
      IX = ITAB (0, 0, NAMX)
      IF (IX .EQ. 0) THEN
        CALL ERRMES (17, 0)
        WRITE (6, 1) NAMX
 1      FORMAT ('This Fortran keyword may not CALLed: ',A)
        CALL ABRT
      ENDIF
      IF (IX .GT. MINT) KTYP(IX) = 0
      LINA(1:11) = '      CALL '
      ISS = 0
C
C   Determine if this is one of the special DP subroutine names.
C
      NAMQ = 'DPCSSN'
      IQ1 = ITAB (0, 0, NAMQ)
      NAMQ = 'DPCSSH'
      IQ2 = ITAB (0, 0, NAMQ)
      IF (IX .EQ. IQ1) THEN
        KCON(5) = 1
        LINA(12:17) = 'MPCSSN'
        LA = 17
        ISS = 1
      ELSEIF (IX .EQ. IQ2) THEN
        KCON(3) = 1
        LINA(12:17) = 'MPCSSH'
        LA = 17
        ISS = 2
      ELSE
        LINA(12:L1+11) = NAMX(1:L1)
        LA = L1 + 11
      ENDIF
C
      LINA(LA+1:LA+1) = '('
      LA = LA + 1
C
C   Identify and process list of arguments.
C
      I2 = MATCH (0, I1 + 1, LN, LINE)
      IF (I2 .NE. LN) CALL ERRMES (18, 1)
      LB = LN - I1 - 1
      IF (LB .EQ. 0) THEN
        LA = LA + 2
      ELSE
        LINB(1:LB) = LINE(I1+1:LN-1)
      ENDIF
      CALL ARLIST (11, LB, LINB, NAR, ITAR, LAR, ARG)
C
C   Check the argument list with the subprogram table.
C
      IF (ISS .EQ. 0) CALL CHKARG (11, NAMX, NAR, ITAR, LAR, ARG)
C
C   Change the argument list if this is a special DP subroutine.
C
      IF (ISS .EQ. 1) THEN
        IF (NAR .NE. 3) GOTO 120
        NAR = 4
        ITAR(4) = ITAR(3)
        LAR(4) = LAR(3)
        ARG(4) = ARG(3)
        ITAR(3) = ITAR(2)
        LAR(3) = LAR(2)
        ARG(3) = ARG(2)
        ITAR(2) = 9
        LAR(2) = 5
        ARG(2) = 'MPPIC'
      ELSEIF (ISS .EQ. 2) THEN
        IF (NAR .NE. 3) GOTO 120
        NAR = 4
        ITAR(4) = ITAR(3)
        LAR(4) = LAR(3)
        ARG(4) = ARG(3)
        ITAR(3) = ITAR(2)
        LAR(3) = LAR(2)
        ARG(3) = ARG(2)
        ITAR(2) = 9
        LAR(2) = 5
        ARG(2) = 'MPL02'
      ENDIF
C
C   Append the argument list.
C
      DO 100 J = 1, NAR
        L1 = LAR(J)
        LINA(LA+1:LA+L1) = ARG(J)(1:L1)
        LINA(LA+L1+1:LA+LA+2) = ', '
        LA = LA + L1 + 2
 100  CONTINUE
C
      LINA(LA-1:LA-1) = ')'
      LA = LA - 1
      CALL OUTLIN (1, LA, LINA)
C
C   Release any temporaries among the arguments.
C
      DO 110 I = 1, NAR
        LI = LAR(I)
        IF (LI .EQ. 4) THEN
          IF (ARG(I)(1:2) .EQ. 'MP') THEN
            TMP1 = ARG(I)(1:4)
            CALL RLTMP (TMP1)
          ENDIF
        ENDIF
 110  CONTINUE
C
      GOTO 130
C
 120  CALL ERRMES (19, 0)
      WRITE (6, 2) NAMX
 2    FORMAT ('Improper number of arguments for this special',          
     $  ' subroutine: ',A)
      CALL ABRT
C
 130  RETURN
      END
C
      SUBROUTINE CHKARG (LU, NAM, NAR, ITAR, LAR, ARG)
C
C   This routine checks to see if a subroutine or function name is in the
C   subprogram table.  If it is, the calling sequence is compared with that
C   in the table.  If not, it is added to the table.  LU is the unit number
C   for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG(MAR)
      CHARACTER*16 NAM, NAMX
      DIMENSION ITAR(MAR), LAR(MAR)
C
      IX = ITAB (0, 0, NAM)
      IF (IX .EQ. 0) CALL ERRMES (20, 1)
      NAMX = VAR(IX)
C
C   Check if the function name is in the subprogram table.
C
      DO 100 I = 1, NSUB
        IF (SNAM(I) .EQ. NAMX) GOTO 120
 100  CONTINUE
C
C   Insert this function and its calling sequence in the subprogram table.
C
      NSUB = NSUB + 1
      IF (NSUB .GT. MSUB) THEN
        CALL ERRMES (21, 0)
        WRITE (6, 1)
 1      FORMAT ('Too many program units in this file.')
        CALL ABRT
      ENDIF
      SNAM(NSUB) = NAMX
      NARS(NSUB) = NAR
      KSTP(0,NSUB) = KTYP(IX)
C
      DO 110 I = 1, NAR
        KSTP(I,NSUB) = ITAR(I)
 110  CONTINUE
C
      GOTO 150
C
C   The function name is in the subprogram table.  Check if the types of the
C   result and the arguments are the same as in the table.
C
 120  KS = I
      IF (NAR .NE. NARS(KS)) GOTO 140
      IF (KTYP(IX) .NE. KSTP(0,KS)) GOTO 140
C
      DO 130 I = 1, NAR
        IF (ITAR(I) .NE. KSTP(I,KS)) GOTO 140
 130  CONTINUE
C
      GOTO 150
C
C   A warning message or a fatal error is generated, depending on the type
C   error flag ITE.
C
 140  IF (ITE .EQ. 0) THEN
        WRITE (LU, 2) NAM
 2      FORMAT ('CMP*'/'CMP*  The result type or argument list of this',
     $    ' function or subroutine is'/'CMP*  incompatible with a',     
     $    ' previous definition or reference: ',A/'CMP*')
      ELSE
        CALL ERRMES (22, 0)
        WRITE (6, 3) NAM
 3      FORMAT ('The result type or argument list of this function or', 
     $    ' subroutine is'/'incompatible with a previous definition or',
     $    ' reference: ',A)
        CALL ABRT
      ENDIF
C
 150  RETURN
      END
C
      SUBROUTINE COPY
C
C   This reads the generated code for one subprogram and copies it to the
C   output file, inserting MP declaration code at the marker if required.
C
      CHARACTER*80 LIN
C
      ENDFILE 11
      REWIND 11
      ENDFILE 12
      REWIND 12
C
 100  READ (11, '(A)', END = 110) LIN
      LN = LNBLK (LIN)
      IF (LN .EQ. 6 .AND. LIN(1:6) .EQ. 'CMP>>>') THEN
        CALL INIMP
      ELSE
        WRITE (6, '(A)') LIN(1:LN)
      ENDIF
      GOTO 100
C
 110  REWIND 11
      REWIND 12
      RETURN
      END
C
      SUBROUTINE DIMEN (K1, LN)
C
C   This processes dimension and common statements by delimiting variable
C   names, inserting in table if required and correcting dimensions of MP
C   variables.  K1 and LN are the indices of the first (after 'dimension' or
C   'common') and last non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*16 NAM
      CHARACTER*1 CJ
      CHARACTER*8 DIM1, DIM2, DIMY
C
C   Place the MP dimension into the character variable DIMX.
C
      WRITE (DIMY, '(I8)') MXP + 4
      I1 = NBLK (1, 8, DIMY)
      LD1 = 9 - I1
      DIM1 = DIMY(I1:8)
      WRITE (DIMY, '(I8)') 2 * MXP + 8
      I1 = NBLK (1, 8, DIMY)
      LD2 = 9 - I1
      DIM2 = DIMY(I1:8)
      J1 = K1
C
C   Output statement as a comment.
C
      CALL OUTLIN (2, LN, LINE)
C
C   Extract the next character from the line.
C
 100  IF (J1 .GT. LN) GOTO 130
      J1 = NBLK (J1, LN, LINE)
      CJ = LINE(J1:J1)
C
C   Check if it the start of a name.
C
      IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN
C
        DO 110 J = J1, LN
          CJ = LINE(J:J)
          IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) GOTO 110
          IF (INDEX (DIG, CJ) .NE. 0) GOTO 110
          IF (INDEX (DEL, CJ) .NE. 0) GOTO 120
          CALL ERRMES (23, 1)
 110    CONTINUE
C
        J = LN + 1
 120    J2 = J - 1
        NAM = LINE(J1:J2)
        IX = ITAB (1, 0, NAM)
        IF (IX .EQ. 0) THEN
          CALL ERRMES (24, 0)
          WRITE (6, 1) NAM
 1        FORMAT ('This Fortran keyword may not appear in a dimension', 
     $      ' or common statement: '/A)
          CALL ABRT
        ENDIF
        KTP = KTYP(IX)
        IF (KTP .LT. 8) KDEC(IX) = 1
        IF (J2 .GE. LN) GOTO 130
        K3 = NBLK (J2 + 1, LN, LINE)
        CJ = LINE(K3:K3)
C
C   Check if this variable has a dimension declaration.
C
        IF (CJ .EQ. '(') THEN
          KDIM(IX) = 1
C
C   If this is a MP variable, correct the dimension.
C
          IF (KTP .GE. 8) THEN
            LINA(1:K3) = LINE(1:K3)
            IF (KTP .LT. 10) THEN
              LINA(K3+1:K3+LD1) = DIM1(1:LD1)
              LDX = LD1
            ELSE
              LINA(K3+1:K3+LD2) = DIM2(1:LD2)
              LDX = LD2
            ENDIF
            LINA(K3+LDX+1:K3+LDX+1) = ','
            LINA(K3+LDX+2:LN+LDX+1) = LINE(K3+1:LN)
            LN = LN + LDX + 1
            LINE(1:LN) = LINA(1:LN)
          ENDIF
          J2 = MATCH (0, K3 + 1, LN, LINE)
          IF (J2 .EQ. 0) CALL ERRMES (25, 1)
          I1 = ISCAN (K3, J2, LINE)
          IF (I1 .NE. 0) THEN
            CALL ERRMES (26, 0)
            WRITE (6, 2) NAM
 2          FORMAT ('The MP dimension on this variable is not',         
     $        ' allowed: ',A)
            CALL ABRT
          ENDIF
        ENDIF
        J1 = J2 + 1
        GOTO 100
C
C   The only other character that should appear here is a comma.
C
      ELSEIF (CJ .EQ. ',') THEN
        J1 = J1 + 1
        GOTO 100
      ELSE
        CALL ERRMES (27, 1)
      ENDIF
C
 130  CALL OUTLIN (1, LN, LINE)
      WRITE (11, 3)
 3    FORMAT ('CMP<')
C
      RETURN
      END
C
      SUBROUTINE ERRMES (IA, IB)
C
C   This outputs a syntax error message with the line number.  If IB is
C   nonzero, ABRT is also called.  IA is the message code, which currently
C   is in the range 1 - 96.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      IF (IB .EQ. 0) THEN
        WRITE (6, 1) LCT, IA
 1      FORMAT ('*** Error in statement starting at line',I6,3X,'Code', 
     $    I6)
      ELSE
        WRITE (6, 2) LCT, IA
 2      FORMAT ('*** Syntax error in statement starting at line',I6,    
     $    3X,'Code',I6)
        CALL ABRT
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE EXEC (K1, LN)
C
C   This handles MP executable statements.  K1 and LN are the indices of the
C   first and last non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*16 LINQ, UCASE
C
C   Check if this is a call statement.
C
      J1 = K1
      LQ = MIN (J1 + 15, LN)
      LINQ = UCASE (LINE(J1:LQ))
      IF (LINQ(1:5) .EQ. 'CALL ') THEN
        J1 = NBLK (J1 + 5, LN, LINE)
        I1 = INDX (J1, LN, '(', LINE)
        IF (I1 .NE. 0) THEN
          CALL CALLST (J1, LN)
          GOTO 110
        ENDIF
      ENDIF
C
C   Check if this is a read or write statement.
C
      IRW = 0
      IF (LINQ(1:4) .EQ. 'READ') THEN
        IRW = 1
        K3 = J1 + 4
      ELSEIF (LINQ(1:5) .EQ. 'WRITE') THEN
        IRW = 2
        K3 = J1 + 5
      ENDIF
      IF (IRW .NE. 0) THEN
        K3 = NBLK (K3, LN, LINE)
        IF (LINE(K3:K3) .NE. '(') GOTO 100
        J1 = K3
        J2 = MATCH (0, J1 + 1, LN, LINE)
        IF (J2 .EQ. 0) CALL ERRMES (28, 1)
        CALL RDWR (IRW, J1, J2, LN)
        GOTO 110
      ENDIF
C
C   Check if this is an assignment statement.
C
 100  CALL ASST (J1, LN)
C
 110  RETURN
      END
C
      SUBROUTINE EXPRES (LU, LA, LINA, ITPX, LX, ARGX)
C
C   This processes the arithmetic and/or logical expression in LINA, of length
C   = LA.  The result, after evaluation, is placed in ARGX, with type = ITPX,
C   and length = LX.  If the last result was =, then the ARGX is set to blanks,
C   and ITPX and LX are set to zero.  LU is the unit number for output code.
C>
C   Uncomment this line on Sun and IBM workstations.
C
C     IMPLICIT AUTOMATIC (A-Z)
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA, LINB, LINC
      CHARACTER*80 AR(2), ARG(MAR), ARG1, ARGX, ARGY
      CHARACTER*16 NAM
      DIMENSION ITAR(MAR), LAR(MAR), ITA(2), LNA(2), ID1(2), ID2(2),    
     $  IOP(2)
      CHARACTER*1 CJ
C*
C      write (lu, *) 'enter expres'
C*
C   Search for an executable operation (one that is not dependent on the
C   results of operations with higher precedence) in the statement.  The two
C   arguments of the operation, their types and lengths, are identified.
C
      LB = LA
      LINB(1:LB) = LINA(1:LA)
C
 100  I1 = 1
C*
C      write (lu, *) 'expres lb =', lb
C      write (lu, *) '%'//linb(1:lb)//'%'
C*
 110  DO 200 II = 1, 2
        IF (I1 .GT. LB) CALL ERRMES (29, 1)
        I1 = NBLK (I1, LB, LINB)
        CJ = LINB(I1:I1)
        IX = 0
C*
C        write (lu, *) 'cj =', cj
C*
C   Check if this is the start of a numeric constant.
C
        IS1 = INDEX (DIG, CJ)
        IF ((CJ .EQ. '-' .OR. CJ .EQ. '.') .AND. I1 .LT. LB) THEN
          I2 = NBLK (I1 + 1, LB, LINB)
          IS2 = INDEX (DIG, LINB(I2:I2))
        ELSE
          IS2 = 0
        ENDIF
C
        IF (IS1 .NE. 0 .OR. IS2 .NE. 0) THEN
          IT = NUMCON (I1, I2, LB, LINB)
C
C   If the mixed mode safe flag is on, then the numeric constant is always
C   of type MP.
C
          IF (IMM .GE. 1) THEN
            IF (IT .EQ. 1) THEN
              IT = 8
            ELSEIF (IT .EQ. 2 .or. IT .EQ. 3) THEN
              IT = 9
            ENDIF
          ENDIF
          IF (IT .LE. 3) THEN
            ID1(II) = I1
            ID2(II) = I2
            ITA(II) = IT
            LNA(II) = I2 - I1 + 1
            AR(II) = LINB(I1:I2)
          ELSE
            ID1(1) = I1
            ID2(2) = I2
            ITPY = IT
            CALL GENCON (LU, I1, I2, LINB, ITPY, LY, ARGY)
            I1 = NBLK (I2 + 1, LB, LINB)
            GOTO 220
          ENDIF
C
C   Check if string is a variable name.
C
        ELSEIF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN
C
          DO 120 J = I1, LB
            CJ = LINB(J:J)
            IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN
              GOTO 120
            ELSEIF (INDEX (DIG, CJ) .NE. 0) THEN
              GOTO 120
            ELSE
              GOTO 130
            ENDIF
 120      CONTINUE
C
          J = LB + 1
C
C   Variable or function name has been identified.
C
 130      I2 = J - 1
          L1 = I2 - I1 + 1
          NAM = LINB(I1:I2)
          IX = ITAB (1, 0, NAM)
          IF (IX .EQ. 0) THEN
            CALL ERRMES (30, 0)
            WRITE (6, 1) NAM
 1          FORMAT ('This Fortran keyword may not appear in an',        
     $        ' expression: ',A)
            CALL ABRT
          ELSEIF (KTYP(IX) .EQ. 0) THEN
            CALL ERRMES (31, 0)
            WRITE (6, 2) NAM
 2          FORMAT ('This variable has not been typed: ',A)
            CALL ABRT
          ENDIF
          ID1(II) = I1
          ID2(II) = I2
          ITA(II) = KTYP(IX)
          LNA(II) = L1
          AR(II)(1:L1) = LINB(I1:I2)
C
C   Check if string is a logical constant.
C
        ELSEIF (CJ .EQ. '.' .AND. I1 .LT. LB .AND.                      
     $      (LINB(I1+1:I1+1) .EQ. 'T' .OR. LINB(I1+1:I1+1) .EQ. 't' .OR.
     $      LINB(I1+1:I1+1) .EQ. 'F' .OR. LINB(I1+1:I1+1) .EQ. 'f'))    
     $      THEN
          IF (LINB(I1:I1+2) .EQ. '.T.' .OR. LINB(I1:I1+2) .EQ. '.t.'.OR.
     $      LINB(I1:I1+2) .EQ. '.F.' .OR. LINB(I1:I1+2) .EQ. '.t.')     
     $      THEN
            I2 = I1 + 2
          ELSEIF (LINB(I1:I1+5) .EQ. '.TRUE.' .OR.                      
     $        LINB(I1:I1+5) .EQ. '.true.') THEN
            I2 = I1 + 5
          ELSEIF (LINB(I1:I1+6) .EQ. '.FALSE.' .OR.                     
     $        LINB(I1:I1+6) .EQ. '.false.') THEN
            I2 = I1 + 6
          ELSE
            CALL ERRMES (32, 1)
          ENDIF
          ID1(II) = I1
          ID2(II) = I2
          ITA(II) = 7
          LNA(II) = I2 - I1 + 1
          AR(II) = LINB(I1:I2)
C
C   Check if argument is a character constant delimited by ".
C
        ELSEIF (CJ .EQ. '"') THEN
          J1 = I1
 140      I2 = INDX (J1 + 1, LB, '"', LINB)
          IF (I2 .EQ. 0) CALL ERRMES (33, 1)
          IF (I2 .LT. LB .AND. LINB(I2+1:I2+1) .EQ. '"') THEN
            J1 = I2 + 1
            GOTO 140
          ENDIF
          ID1(II) = I1
          ID2(II) = I2
          ITA(II) = 6
          LNA(II) = I2 - I1 + 1
          AR(II) = LINB(I1:I2)
C
C   Check if argument is a character constant delimited by '.
C
        ELSEIF (CJ .EQ. "'") THEN
          J1 = I1
 150      I2 = INDX (J1 + 1, LB, "'", LINB)
          IF (I2 .EQ. 0) CALL ERRMES (34, 1)
          IF (I2 .LT. LB .AND. LINB(I2+1:I2+1) .EQ. "'") THEN
            J1 = I2 + 1
            GOTO 150
          ENDIF
          ID1(II) = I1
          ID2(II) = I2
          ITA(II) = 6
          LNA(II) = I2 - I1 + 1
          AR(II) = LINB(I1:I2)
C
C   Check if argument is a unary minus sign (i.e. argument 1 is null).
C
        ELSEIF (CJ .EQ. '-') THEN
          IF (II .EQ. 2) GOTO 110
          ID1(1) = I1
          ID2(1) = I1
          ITA(1) = 0
          LNA(1) = 1
          AR(1) = ' '
          IOP(1) = 3
          I1 = I1 + 1
          GOTO 200
C
C   Check if the next character is a left parenthesis.  If so, evaluate the
C   expression in parentheses.
C
        ELSEIF (CJ .EQ. '(') THEN
          I2 = MATCH (0, I1 + 1, LB, LINB)
          IF (I2 .EQ. 0) CALL ERRMES (35, 1)
          LC = I2 - I1 - 1
          LINC(1:LC) = LINB(I1+1:I2-1)
          ID1(1) = I1
          ID2(2) = I2
          IF (LB .EQ. 0) CALL ERRMES (36, 1)
          CALL EXPRES (LU, LC, LINC, ITPY, LY, ARGY)
          GOTO 220
        ELSE
          CALL ERRMES (37, 0)
          WRITE (6, 3) CJ
 3        FORMAT ('Illegal character: ',A)
          CALL ABRT
        ENDIF
C
C   Check if the end of the variable or constant is the end of the statement.
C
 160    CONTINUE
        IF (I2 .EQ. LB .OR. LINB(I2+1:LB) .EQ. ' ') THEN
C
C   If this occurs on the first pass, we are done.
C
          IF (II .EQ. 1) THEN
            ITPX = ITA(1)
            LX = LNA(1)
            ARGX(1:LX) = AR(1)(1:LX)
            GOTO 230
C
C   If this occurs on the second pass, proceed to evaluate.
C
          ELSE
            GOTO 210
          ENDIF
        ENDIF
C
C   Check if the next character after the variable name is a left parenthesis.
C
        I3 = NBLK (I2 + 1, LB, LINB)
        CJ = LINB(I3:I3)
        IF (CJ .EQ. '(') THEN
          IF (IX .EQ. 0) CALL ERRMES (38, 1)
          I2 = MATCH (0, I3 + 1, LB, LINB)
          IF (I2 .EQ. 0) CALL ERRMES (39, 1)
          K1 = INDEX (LINB(I2:LB), '=')
 170      CONTINUE
C
C   Check if the subscripted variable is really a function reference.
C
          IF (KDIM(IX) .EQ. -1) THEN
            IF (K1 .NE. 0) THEN
              CALL ERRMES (40, 0)
              WRITE (6, 4) NAM(1:L1)
 4            FORMAT ('A function name may not appear on the LHS of',   
     $          ' an assignment statement: ',A)
              CALL ABRT
            ENDIF
C
C   Generate a function call.  If it is an intrinsic reference and the mixed
C   mode SAFE option is in effect, set IMM = 2 as a flag to inform ARLIST not
C   to revert to mixed mode FAST while evaluating the argument list.
C
            ID1(1) = I1
            ID2(2) = I2
            LC = I2 - I3 - 1
            LINC(1:LC) = LINB(I3+1:I2-1)
            IMS = IMM
            IF (IX .LE. MINT .AND. IMM .GE. 1) IMM = 2
            CALL ARLIST (LU, LC, LINC, NAR, ITAR, LAR, ARG)
            IMM = IMS
            IT1 = ITA(II)
            LN1 = LNA(II)
            ARG1 = AR(II)
            CALL GENFUN (LU, IT1, LN1, ARG1, NAR, ITAR, LAR, ARG, ITPY, 
     $        LY, ARGY)
            I1 = NBLK (I2 + 1, LB, LINB)
            GOTO 220
C
C     Check if the subscripted variable has a dimension.
C
          ELSEIF (KDIM(IX) .EQ. 0) THEN
            IF (K1 .EQ. 0) THEN
              KT = KTYP(IX)
              WRITE (LU, 5) NAM(1:L1), CTP(KT)
 5            FORMAT ('CMP*'/'CMP*  Undimensioned variable assumed to', 
     $          ' be an external function.'/'CMP*  Name: ',A,4X,        
     $          'Type: ',A/'CMP*')
              KDIM(IX) = -1
              KDEC(IX) = 1
              GOTO 170
            ELSE
              CALL ERRMES (41, 0)
              WRITE (6, 6)
 6            FORMAT ('MP variables may not be used in statement',      
     $          ' function definitions.'/'Define an external function', 
     $          ' for this purpose.')
              CALL ABRT
            ENDIF
C
C   Otherwise it must be an ordinary array with subscript.  The combination of
C   the variable name and the subscript will now be treated as a variable.
C   IX is set to 0 as a flag indicating that this has been done.
C
          ELSE
            I4 = ISCAN (I3, I2, LINB)
            IF (I4 .NE. 0) THEN
              CALL ERRMES (42, 0)
              WRITE (6, 7) NAM
 7            FORMAT ('The MP subscript on this variable is not',       
     $          ' allowed: ',A)
              CALL ABRT
            ENDIF
            L1 = I2 - I1 + 1
            ID2(II) = I2
            LNA(II) = L1
            AR(II)(1:L1) = LINB(I1:I2)
            IX = 0
            GOTO 160
          ENDIF
        ELSE
C
C   The variable does not have a subscript.  Check if it has a dimension.
C
          IF (IX .GT. 0) THEN
            IF (KDIM(IX) .GT. 0) THEN
              CALL ERRMES (43, 0)
              WRITE (6, 8) NAM(1:L1)
 8            FORMAT ('This dimensioned variable is used without a',    
     $          ' subscript: ',A)
              CALL ABRT
            ENDIF
          ENDIF
        ENDIF
        I1 = I3
C
C   Identify the operator.
C
        DO 180 I = 1, NOP
          L1 = LOP(I) - 1
          IF (LINB(I1:I1+L1) .EQ. LOPR(I) .OR. LINB(I1:I1+L1) .EQ.      
     $      UOPR(I)) GOTO 190
 180    CONTINUE
C
        CALL ERRMES (44, 0)
        WRITE (6, 9) LINB(I1:I1)
 9      FORMAT ('Illegal operator: ',A)
        CALL ABRT
C
 190    IOP(II) = I
        I1 = I1 + LOP(I)
 200  CONTINUE
C
C   Compare the precedence levels of the two operators.
C
      IF (KOP(IOP(1)) .LT. KOP(IOP(2))) THEN
        I1 = ID1(2)
        GOTO 110
      ENDIF
C
C   An operation can be performed.
C
 210  CALL GEN (LU, ITA, LNA, AR, IOP(1), ITPY, LY, ARGY)
C
C   Replace the two operands and the operator with the result in LINB.
C
 220  IF (LY .NE. 0) THEN
        I1 = ID1(1)
        I2 = ID2(2)
        L1 = I2 - I1 + 1
        LD = LY - L1
        IF (I1 .GT. 0) LINC(1:I1-1) = LINB(1:I1-1)
        LINC(I1:I1+LY-1) = ARGY(1:LY)
        IF (LB .GT. I2) LINC(I1+LY:LB+LD) = LINB(I2+1:LB)
        LB = LB + LD
        LINB(1:LB) = LINC(1:LB)
        GOTO 100
      ELSE
        ITPX = ITPY
        LX = LY
        ARGX = ARGY
      ENDIF
C
C   Finished at last.
C
 230  CONTINUE
C*
C      write (lu, *) 'exit express, argx = %'//argx(1:lx)//'%'
C*
      RETURN
      END
C
      SUBROUTINE FIXSUB (K1, K2, LN)
C
C   This routine prepends '1,' to subscripts MP variables in LINE between K1
C   and K2.  LN is the length of the full line.  It also changes the names of
C   the special constants when found.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINX
      CHARACTER*16 NAM, NAMQ
      CHARACTER*1 CJ
C
      J1 = K1
      NAMQ = 'MPNWP'
      IQNWP = ITAB (0, 0, NAMQ)
      NAMQ = 'DPPIC'
      IQPIC = ITAB (0, 0, NAMQ)
      IQD = IQPIC - IQNWP + 1
C
C   Extract the next character from the line.
C
 100  IF (J1 .GT. K2) GOTO 130
      J1 = NBLK (J1, K2, LINE)
      CJ = LINE(J1:J1)
C
C   Check if it is the start of a numeric constant.
C
      IS1 = INDEX (DIG, CJ)
      IF ((CJ .EQ. '-' .OR. CJ .EQ. '.') .AND. J1 .LT. K2) THEN
        J2 = NBLK (J1 + 1, K2, LINE)
        IS2 = INDEX (DIG, LINE(J2:J2))
      ELSE
        IS2 = 0
      ENDIF
C
      IF (IS1 .NE. 0 .OR. IS2 .NE. 0) THEN
        ITP = NUMCON (J1, J2, LN, LINE)
        J1 = J2 + 1
        GOTO 100
C
C   Check if it the start of a name.
C
      ELSEIF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN
C
        DO 110 J = J1, K2
          CJ = LINE(J:J)
          IF (INDEX (DEL, CJ) .NE. 0) GOTO 120
 110    CONTINUE
C
        J = K2 + 1
C
C   The variable has been identified.
C
 120    I2 = J - 1
        NAM = LINE(J1:I2)
        IX = ITAB (0, 0, NAM)
        IF (IX .EQ. 0) THEN
          J1 = I2 + 1
          GOTO 100
        ENDIF
        ITP = KTYP(IX)
C
C   Check if the variable is the function value.  If so, change its name.
C
        IF (KDIM(IX) .EQ. -2) THEN
          LX = LN - I2 + 5
          LINX(1:5) = 'MPFVX'
          LINX(6:LX) = LINE(I2+1:LN)
          LD = J1 - I2 + 4
          K2 = K2 + LD
          LN = LN + LD
          LINE(J1:LN) = LINX(1:LX)
          J1 = J1 + 5
          GOTO 100
C
C   Check if the variable is a special constant.  If so, change its name.
C
        ELSEIF (IX .GE. IQNWP .AND. IX .LE. IQPIC) THEN
          LINE(J1:I2) = VAR(IX+IQD)
          KCON(IX) = 1
          J1 = I2 + 1
          GOTO 100
C
C   Check if the variable is MP.
C
        ELSEIF (ITP .GE. 8) THEN
C
C   Check if this MP variable has a subscript.
C
          I1 = NBLK (I2 + 1, K2, LINE)
          IF (I1 .EQ. 0) GOTO 130
          IF (LINE(I1:I1) .EQ. '(') THEN
            IF (KDIM(IX) .GT. 0) THEN
              LX = LN - I1 + 2
              LINX(1:2) = '1,'
              LINX(3:LX) = LINE(I1+1:LN)
              LINE(I1+1:LN+2) = LINX(1:LX)
              K2 = K2 + 2
              LN = LN + 2
              J1 = INDX (I1 + 1, K2, ')', LINE)
              IF (J1 .EQ. 0) CALL ERRMES (45, 1)
            ENDIF
          ELSE
            J1 = I2 + 1
            GOTO 100
          ENDIF
        ENDIF
        J1 = I2 + 1
        GOTO 100
C
C   Check if it is the start of a logical constant.
C
      ELSEIF (CJ .EQ. '.') THEN
        I1 = INDX (J1 + 1, K2, '.', LINE)
        IF (I1 .EQ. 0) CALL ERRMES (46, 1)
        J1 = I1 + 1
        GOTO 100
C
C   Check if it is the start of a character constant.
C
      ELSEIF (CJ .EQ. '"') THEN
        I1 = INDX (J1 + 1, K2, '"', LINE)
        IF (I1 .EQ. 0) CALL ERRMES (47, 1)
        J1 = I1 + 1
        GOTO 100
      ELSEIF (CJ .EQ. "'") THEN
        I1 = INDX (J1 + 1, K2, "'", LINE)
        IF (I1 .EQ. 0) CALL ERRMES (48, 1)
        J1 = I1 + 1
        GOTO 100
      ENDIF
C
C   Check if it is one of the miscellaneous symbols.
C
      I1 = INDEX (DEL, CJ)
      IF (I1 .EQ. 0) CALL ERRMES (49, 1)
      J1 = J1 + 1
      GOTO 100
C
 130  RETURN
      END
C
      SUBROUTINE GEN (LU, ITA, LNA, AR, IOP, ITPX, LX, ARGX)
C
C   This generates code for a single operation.  The two input argument names
C   are in AR, with types in ITA and lengths in LNA.  The operation code is in
C   IOP.  The result (ordinarily a temporary variable name, but empty in case
C   of assignments) is placed in ARGX, with type ITPX and length LX.  LU is
C   the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*80 AR(2), ARG1, ARG2, ARG3, ARGX
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
      DIMENSION ITA(2), LNA(2)
C
      ITP1 = ITA(1)
      L1 = LNA(1)
      ARG1(1:L1) = AR(1)(1:L1)
      ITP2 = ITA(2)
      L2 = LNA(2)
      ARG2(1:L2) = AR(2)(1:L2)
C*
C      write (lu, *) 'enter gen ', itp1, itp2, ' ', uopr(iop)
C      write (lu, *) 'args: ', arg1(1:l1), '  ', arg2(1:l2)
C*
C   Check for character entities with non-character entities.
C
      IF (ITP1 .EQ. 6 .AND. ITP2 .NE. 6 .OR. ITP1 .NE. 6 .AND.          
     $  ITP2 .EQ. 6) GOTO 110
C
C   Check for logical entities with non-logical entities.
C
      IF (ITP1 .EQ. 7 .AND. ITP2 .NE. 7 .OR. ITP1 .NE. 7 .AND.          
     $  ITP2 .EQ. 7) GOTO 110
C
C   Check for assignments.
C
      IF (IOP .EQ. 1) THEN
        ITPX = 0
        ARGX(1:4) = ' '
        LX = 0
        CALL GENASN (LU, ITP1, L1, ARG1, ITP2, L2, ARG2)
        GOTO 100
      ENDIF
C
C   Handle all other operations here.  The result variable will be a
C   temporary variable and the result type is the max of the two type numbers,
C   except for comparisons and a couple of other mixed mode cases.
C
      IF (IOP .LE. 6) THEN
        IF (ITP1 .EQ. 8 .AND. (ITP2 .EQ. 2 .OR. ITP2 .EQ. 3) .OR.       
     $    ITP2 .EQ. 8 .AND. (ITP1 .EQ. 2 .OR. ITP1 .EQ. 3)) THEN
          ITPX = 9
        ELSEIF (ITP1 .GE. 8 .AND. (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) .OR.   
     $      ITP2 .GE. 8 .AND. (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5)) THEN
          ITPX = 10
        ELSE
          ITPX = MAX (ITP1, ITP2)
        ENDIF
C
C   If the mixed mode safe option is in effect, change IN, SP, DP, CO and DC
C   results to the appropriate MP type.
C
        IF (IMM .GE. 1) THEN
          IF (ITPX .EQ. 1) THEN
            ITPX = 8
            ITP3 = 8
          ELSEIF (ITPX .EQ. 2 .OR. ITPX .EQ. 3) THEN
            ITPX = 9
            ITP3 = 9
          ELSEIF (ITPX .EQ. 4 .OR. ITPX .EQ. 5) THEN
            ITPX = 10
            ITP3 = 10
          ENDIF
        ENDIF
      ELSE
        ITPX = 7
      ENDIF
C
C   Check if the operation is really the definition of a MPI or MPR constant.
C
      IF (IOP .EQ. 2 .AND. L2 .EQ. 1 .AND. ARG2(1:1) .EQ. '0') THEN
        IF (INDEX (DIG, ARG1(1:1)) .NE. 0 .OR. ARG1(1:1) .EQ. '.' .OR.  
     $    ARG1(1:1) .EQ. '-' .OR. ARG1(1:1) .EQ. '+') THEN
          LINA(1:L1) = ARG1(1:L1)
          IF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 8) THEN
            ITPX = 8
          ELSEIF (ITP1 .EQ. 2 .OR. ITP1 .EQ. 3 .OR. ITP1 .EQ. 9) THEN
            ITPX = 9
          ENDIF
          CALL GENCON (LU, 1, L1, LINA, ITPX, LX, ARGX)
        ELSE
          ITPX = ITP1
          LX = L1
          ARGX(1:LX) = ARG1(1:L1)
        ENDIF
        GOTO 120
      ENDIF
      LX = 4
      ARGX(1:4) = GETMP (ITPX)
C
C   Generate code for non-MP operands.
C
      IF (ITP1 .LT. 8 .AND. ITP2 .LT. 8) THEN
        IF (IMM .EQ. 0 .OR. ITP1 .EQ. 7 .AND. ITP2 .EQ. 7 .OR.          
     $    IOP .GE. 7) THEN
C
C   Either mixed mode fast option is in effect, or else the operation is a
C   comparison or logical operation.  Generate a simple one line non-MP
C   statement.
C
          WRITE (LU, 1) ARGX(1:4), ARG1(1:L1), UOPR(IOP)(1:LOP(IOP)),   
     $      ARG2(1:L2)
 1        FORMAT (6X,A,' = ',A,' ',A,' ',A)
          GOTO 100
        ELSE
C
C   The mixed mode safe option is in effect.  Convert the left operand to
C   the appropriate MP type so that it will be evaluated using the MP routines.
C
          TMP1 = GETMP (ITP3)
          ARG3(1:4) = TMP1
          L3 = 4
          CALL GENASN (LU, ITP3, L3, ARG3, ITP1, L1, ARG1)
C
C   If ARG1 is a temporary, release it.  Then set ARG1 = ARG3 and generate
C   code for this operation using the appropriate GENXXX routine.
C
          IF (L1 .EQ. 4) THEN
            IF (ARG1(1:2) .EQ. 'MP') THEN
              TMP1 = ARG1(1:4)
              CALL RLTMP (TMP1)
            ENDIF
          ENDIF
          ITP1 = ITP3
          L1 = L3
          ARG1(1:L1) = ARG3(1:L3)
        ENDIF
      ENDIF
C
C   Check if operation is a plus.
C
      IF (IOP .EQ. 2) THEN
        CALL GENADD (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   Check if the operation is minus.
C
      ELSEIF (IOP .EQ. 3) THEN
        CALL GENSUB (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   Check if the operation is exponentiation.
C
      ELSEIF (IOP .EQ. 4) THEN
        CALL GENEXP (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   Check if the operation is multiplication.
C
      ELSEIF (IOP .EQ. 5) THEN
        CALL GENMUL (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   Check if the operation is division.
C
      ELSEIF (IOP .EQ. 6) THEN
        CALL GENDIV (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   Check if the operation is comparison.
C
      ELSEIF (IOP .GE. 7 .AND. IOP .LE. 12) THEN
        CALL GENCPR (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, IOP, ARGX)
        GOTO 100
      ELSE
        GOTO 110
      ENDIF
C
C   If the result is of type MPI, truncate the result.
C
      IF (ITPX .EQ. 8) THEN
        TMP1 = GETMP (9)
        WRITE (LU, 2) ARGX(1:4), ARGX(1:4), TMP1
 2      FORMAT (6X,'CALL MPINFR (',A,', ',A,', ',A,')')
        CALL RLTMP (TMP1)
      ENDIF
C
C   Release any temporaries among the arguments.
C
 100  IF (L1 .EQ. 4) THEN
        IF (ARG1(1:2) .EQ. 'MP') THEN
          TMP1 = ARG1(1:4)
          CALL RLTMP (TMP1)
        ENDIF
      ENDIF
      IF (L2 .EQ. 4) THEN
        IF (ARG2(1:2) .EQ. 'MP') THEN
          TMP1 = ARG2(1:4)
          CALL RLTMP (TMP1)
        ENDIF
      ENDIF
      GOTO 120
C
 110  CALL ERRMES (50, 0)
      WRITE (6, 3) UOPR(IOP)(1:LOP(IOP))
 3    FORMAT ('Operation ',A,' is not defined with these operands.')
      CALL ABRT
C
 120  CONTINUE
C*
C      write (lu, *) 'exit gen itpx, lx, argx =', itpx, lx, ' ',
C     $  argx(1:lx)
C*
      RETURN
      END
C
      SUBROUTINE GENADD (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   This generates code for an add operation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  The result
C   name is in ARGX (also input).  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
      IF (ITP1 .LT. 8) THEN
        IF (ITP1 .EQ. 3) THEN
C
C   (Arg1 is DP) and (Arg2 is MP).
C
          TMP1 = GETMP (9)
          IF (ITP2 .EQ. 10) THEN
            WRITE (LU, 1) ARG2(1:L2), ARGX(1:4)
 1          FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')')
          ENDIF
          WRITE (LU, 2) ARG1(1:L1), TMP1
 2        FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
          WRITE (LU, 3) TMP1, ARG2(1:L2), ARGX(1:4)
 3        FORMAT (6X,'CALL MPADD (',A,', ',A,', ',A,')')
          CALL RLTMP (TMP1)
        ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MP).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (9)
          IF (ITP2 .EQ. 10) THEN
            WRITE (LU, 1) ARG2(1:L2), ARGX(1:4)
          ENDIF
          WRITE (LU, 4) TMP1, ARG1(1:L1)
 4        FORMAT (6X,A,' = ',A)
          WRITE (LU, 2) TMP1, TMP2
          WRITE (LU, 3) TMP2, ARG2(1:L2), ARGX(1:4)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
        ELSE
C
C   (Arg1 is CO or DC) and (Arg2 is MP).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (3)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          TMP5 = GETMP (10)
          IF (ITP1 .EQ. 5) THEN
            WRITE (LU, 5) TMP1, ARG1(1:L1)
 5          FORMAT (6X,A,' = DREAL (',A,')')
            WRITE (LU, 6) TMP2, ARG1(1:L1)
 6          FORMAT (6X,A,' = DIMAG (',A,')')
          ELSE
            WRITE (LU, 7) TMP1, ARG1(1:L1)
 7          FORMAT (6X,A,' = REAL (',A,')')
            WRITE (LU, 8) TMP2, ARG1(1:L1)
 8          FORMAT (6X,A,' = AIMAG (',A,')')
          ENDIF
          WRITE (LU, 2) TMP1, TMP3
          WRITE (LU, 2) TMP2, TMP4
          WRITE (LU, 9) TMP3, TMP4, TMP5
 9        FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
          IF (ITP2 .EQ. 10) THEN
            WRITE (LU, 10) TMP5, ARG2(1:L2), ARGX(1:4)
 10         FORMAT (6X,'CALL MPCADD (MPNW4, ',A,', ',A,', ',A,')')
          ELSE
            TMP6 = GETMP (10)
            WRITE (LU, 11) TMP3
 11         FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')')
            WRITE (LU, 9) ARG2(1:L2), TMP3, TMP6
            WRITE (LU, 10) TMP5, TMP6, ARGX(1:4)
            CALL RLTMP (TMP6)
          ENDIF
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP2 .EQ. 3) THEN
C
C   (Arg1 is MP) and (Arg2 is DP).
C
          TMP1 = GETMP (9)
          IF (ITP1 .EQ. 10) THEN
            WRITE (LU, 1) ARG1(1:L1), ARGX(1:4)
          ENDIF
          WRITE (LU, 2) ARG2(1:L2), TMP1
          WRITE (LU, 3) ARG1(1:L1), TMP1, ARGX(1:4)
          CALL RLTMP (TMP1)
        ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN
C
C   (Arg1 is MP) and (Arg2 is IN or SP).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (9)
          IF (ITP1 .EQ. 10) THEN
            WRITE (LU, 1) ARG1(1:L1), ARGX(1:4)
          ENDIF
          WRITE (LU, 4) TMP1, ARG2(1:L2)
          WRITE (LU, 2) TMP1, TMP2
          WRITE (LU, 3) ARG1(1:L1), TMP2, ARGX(1:4)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
        ELSE
C
C   (Arg1 is MP) and (Arg2 is CO or DC).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (3)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          TMP5 = GETMP (10)
          IF (ITP2 .EQ. 5) THEN
            WRITE (LU, 5) TMP1, ARG2(1:L2)
            WRITE (LU, 6) TMP2, ARG2(1:L2)
          ELSE
            WRITE (LU, 7) TMP1, ARG2(1:L2)
            WRITE (LU, 8) TMP2, ARG2(1:L2)
          ENDIF
          WRITE (LU, 2) TMP1, TMP3
          WRITE (LU, 2) TMP2, TMP4
          WRITE (LU, 9) TMP3, TMP4, TMP5
          IF (ITP1 .EQ. 10) THEN
            WRITE (LU, 10) ARG1(1:L1), TMP5, ARGX(1:4)
          ELSE
            TMP6 = GETMP (10)
            WRITE (LU, 11) TMP3
            WRITE (LU, 9) ARG1(1:L1), TMP3, TMP6
            WRITE (LU, 10) TMP6, TMP5, ARGX(1:4)
            CALL RLTMP (TMP6)
          ENDIF
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
        ENDIF
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR).
C
        WRITE (LU, 3) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPC).
C
        TMP1 = GETMP (3)
        TMP2 = GETMP (10)
        WRITE (LU, 11) TMP1
        WRITE (LU, 9) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 10) TMP2, ARG2(1:L2), ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPC) and (Arg1 is MPI or MPR).
C
        TMP1 = GETMP (3)
        TMP2 = GETMP (10)
        WRITE (LU, 11) TMP1
        WRITE (LU, 9) ARG2(1:L2), TMP1, TMP2
        WRITE (LU, 10) ARG1(1:L1), TMP2, ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSE
C
C   (Arg1 is MPC) and (Arg2 is MPC).
C
        WRITE (LU, 10) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE GENASN (LU, ITP1, L1, ARG1, ITP2, L2, ARG2)
C
C   This generates code for an assign operation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  There is no
C   "result" temporary with assignments.  LU is the unit number for output
C   code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*16 NAM, NAMQ
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
      NAMQ = 'MPNWP'
      IQNWP = ITAB (0, 0, NAMQ)
      NAMQ = 'DPPIC'
      IQPIC = ITAB (0, 0, NAMQ)
      IQD = IQPIC - IQNWP + 1
      ISC = IQNWP + 2 * IQD - 1
C
C   Check if Arg1 is an appropriate name for the result of an assignment
C   (i.e. it must not be special constant or a function name or parameter).
C
      K = INDEX (ARG1, '(')
      IF (K .EQ. 0) K = 100
      L = MIN (K - 1, L1, 16)
      NAM = ARG1(1:L)
      IX = ITAB (0, 0, NAM)
      IF (IX .GT. IQPIC .AND. IX .LE. ISC .AND. LU .EQ. 12) THEN
        IX = IX - IQD
        WRITE (LU, 1) VAR(IX)(1:LVAR(IX))
 1      FORMAT ('CMP*'/'CMP*  The parameter definition of this special',
     $    ' constant is ignored: ',A/'CMP*')
        GOTO 100
      ELSEIF (IX .LE. MINT .OR. KDIM(IX) .LT. 0) THEN
        CALL ERRMES (51, 0)
        WRITE (6, 2) NAM(1:L)
 2      FORMAT ('This name may not appear on the LHS of an assignment', 
     $    ' statement: ',A)
        CALL ABRT
      ELSEIF (LU .EQ. 12) THEN
C
C   If this is a MP parameter definition, set KDIM(IX) to -3 so that it can't
C   be stored into again.
C
        KDIM(IX) = -3
      ENDIF
C
      IF (ITP1 .LT. 8) THEN
        IF (ITP2 .LT. 8) THEN
C
C   (LHS is non-MP) and (RHS is non-MP).
C
          WRITE (LU, 3) ARG1(1:L1), ARG2(1:L2)
 3        FORMAT (6X,A,' = ',A)
        ELSEIF (ITP1 .LE. 3 .OR. ITP2 .NE. 10) THEN
C
C   (LHS is IN, SP or DP) or (RHS is MPI or MPR).  At least one is not complex.
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (1)
          WRITE (LU, 4) ARG2(1:L2), TMP1, TMP2
 4        FORMAT (6X,'CALL MPMDC (',A,', ',A,', ',A,')')
          WRITE (LU, 5) ARG1(1:L1), TMP1, TMP2
 5        FORMAT (6X,A,' = ',A,' * 2.D0 ** ',A)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
        ELSE
C
C   (LHS is CO or DC) and (RHS is MPC).
C
          TMP1 = GETMP (9)
          TMP2 = GETMP (9)
          TMP3 = GETMP (3)
          TMP4 = GETMP (3)
          TMP5 = GETMP (1)
          WRITE (LU, 6) ARG2(1:L2), TMP1, TMP2
 6        FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')')
          WRITE (LU, 4) TMP1, TMP3, TMP5
          WRITE (LU, 5) TMP3, TMP3, TMP5
          WRITE (LU, 4) TMP2, TMP4, TMP5
          WRITE (LU, 5) TMP4, TMP4, TMP5
          WRITE (LU, 7) ARG1(1:L1), TMP3, TMP4
 7        FORMAT (6X,A,' = DCMPLX (',A,', ',A,')')
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP2 .EQ. 3) THEN
C
C   (LHS is MP) and (RHS is DP).
C
          WRITE (LU, 8) ARG2(1:L2), ARG1(1:L1)
 8        FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
        ELSEIF (ITP1 .NE. 10 .OR. ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN
C
C   (LHS is MP) or (RHS is IN or SP).  At least one is not complex.
C
          TMP1 = GETMP (3)
          WRITE (LU, 3) TMP1, ARG2(1:L2)
          WRITE (LU, 8) TMP1, ARG1(1:L1)
          CALL RLTMP (TMP1)
        ELSE
C
C   (LHS is MPC) and (RHS is CO or DC).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (3)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          IF (ITP2 .EQ. 5) THEN
            WRITE (LU, 9) TMP1, ARG2(1:L2)
 9          FORMAT (6X,A,' = DREAL (',A,')')
            WRITE (LU, 10) TMP2, ARG2(1:L2)
 10         FORMAT (6X,A,' = DIMAG (',A,')')
          ELSE
            WRITE (LU, 11) TMP1, ARG2(1:L2)
 11         FORMAT (6X,A,' = REAL (',A,')')
            WRITE (LU, 12) TMP2, ARG2(1:L2)
 12         FORMAT (6X,A,' = AIMAG (',A,')')
          ENDIF
          WRITE (LU, 8) TMP1, TMP3
          WRITE (LU, 8) TMP2, TMP4
          WRITE (LU, 13) TMP3, TMP4, ARG1(1:L1)
 13       FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
        ENDIF
      ELSEIF (ITP1 .NE. 10 .OR. ITP2 .NE. 10) THEN
C
C   (LHS is MPI or MPR) or (RHS is MPI or MPR).  At least one is not MPC.
C
        WRITE (LU, 14) ARG2(1:L2), ARG1(1:L1)
 14     FORMAT (6X,'CALL MPEQ (',A,', ',A,')')
      ELSE
C
C   (LHS is MPC) and (RHS is MPC).
C
        WRITE (LU, 15) ARG2(1:L2), ARG1(1:L1)
 15     FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')')
      ENDIF
      IF (ITP1 .EQ. 8 .AND. ITP2 .NE. 1 .AND. ITP2 .NE. 8) THEN
C
C   Truncate the result if (LHS is MPI) and (RHS is not IN or MPI).
C
        TMP1 = GETMP (9)
        WRITE (LU, 16) ARG1(1:L1), ARG1(1:L1), TMP1
 16     FORMAT (6X,'CALL MPINFR (',A,', ',A,', ',A,')')
        CALL RLTMP (TMP1)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 4 .AND. ITP2 .NE. 5 .AND.    
     $    ITP2 .NE. 10) THEN
C
C   Zero the imaginary part if (LHS is MPC) and (RHS is not CO or DC or MPC).
C
        TMP1 = GETMP (9)
        WRITE (LU, 17) TMP1
 17     FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')')
        WRITE (LU, 13) ARG1(1:L1), TMP1, ARG1(1:L1)
        CALL RLTMP (TMP1)
      ENDIF
C
 100  RETURN
      END
C
      SUBROUTINE GENCON (LU, I1, I2, LINA, ITPY, LY, ARGY)
C
C   This generates the code for a MPR constant.  I1 and I2 are the indicies
C   of LINA delimiting the constant.  The output MP temporary is placed in
C   ARGY, with length LY.  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA, LINB
      CHARACTER*80 ARGY
      CHARACTER*4 NUM, TMP1, TMP2, TMP3, GETMP
C
      TMP1 = GETMP (11)
      TMP2 = GETMP (6)
      TMP3 = GETMP (1)
      LY = 4
      ARGY(1:4) = GETMP (ITPY)
      LA = I2 - I1 + 1
      L2 = MAX (INDEX (LINA(I1:I2), 'D'), INDEX (LINA(I1:I2), 'd'),     
     $  INDEX (LINA(I1:I2), 'E'), INDEX (LINA(I1:I2), 'e')) - 1
      IF (L2 .GE. 0) THEN
        L1 = LA - L2 - 1
      ELSE
        L1 = 0
        L2 = LA
      ENDIF
      LINB(1:6) = ' '
      LINB(7:10) = TMP1
      LINB(11:17) = " = '10^"
      IF (L1 .GT. 0) THEN
        LINB(18:L1+17) = LINA(I1+L2+1:I2)
      ELSE
        L1 = 1
        LINB(18:18) = '0'
      ENDIF
      LINB(L1+18:L1+20) = ' x '
      LINB(L1+21:L1+L2+20) = LINA(I1:I1+L2-1)
      LINB(L1+L2+21:L1+L2+21) = "'"
      L = L1 + L2 + 21
      IF (LU .EQ. 11) THEN
        CALL OUTLIN (1, L, LINB)
      ELSE
        CALL OUTLIN (3, L, LINB)
      ENDIF
      LS = L1 + L2 + 6
      LSM = MAX (LSM, LS)
      WRITE (NUM, '(I3)') LS
      WRITE (LU, 1) TMP1, NUM(1:3), TMP2, TMP3, TMP3, NUM(1:3)
 1    FORMAT (6X,'READ (',A,", '(",A,"A1)' ) (",A,'(',A,'), ',A,        
     $  ' = 1, ',A,')')
      WRITE (LU, 2) TMP2, LS, ARGY(1:4)
 2    FORMAT (6X,'CALL MPINPC (',A,', ',I3,', ',A,')')
      CALL RLTMP (TMP3)
C
      RETURN
      END
C
      SUBROUTINE GENCPR (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, IOP, ARGX)
C
C   This generates code for a compare operation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  The result
C   name is in ARGX (also input).  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*8 ANDOR
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
C   If one of the operands has a complex type, only .EQ. and .NE. are allowed.
C
      IF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5 .OR. ITP1 .EQ. 10 .OR.           
     $  ITP2 .EQ. 4 .OR. ITP2 .EQ. 5 .OR. ITP2 .EQ. 10) THEN
        IF (IOP .GE. 9) GOTO 100
        IF (IOP .EQ. 7) THEN
          ANDOR = '.AND.'
        ELSE
          ANDOR = '.OR.'
        ENDIF
      ENDIF
C
      IF (ITP1 .LT. 8) THEN
        IF (ITP1 .EQ. 3) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is DP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (1)
            WRITE (LU, 1) ARG1(1:L1), TMP1
 1          FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
            WRITE (LU, 2) TMP1, ARG2(1:L2), TMP2
 2          FORMAT (6X,'CALL MPCPR (',A,', ',A,', ',A,')')
            WRITE (LU, 3) ARGX(1:4), TMP2, UOPR(IOP)(1:LOP(IOP))
 3          FORMAT (6X,A,' = ',A,' ',A,' 0')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ELSE
C
C   (Arg1 is DP) and (Arg2 is MPC).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (1)
            TMP6 = GETMP (1)
            WRITE (LU, 1) ARG1(1:L1), TMP1
            WRITE (LU, 4) TMP2
 4          FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')')
            WRITE (LU, 5) ARG2(1:L2), TMP3, TMP4
 5          FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')')
            WRITE (LU, 2) TMP1, TMP3, TMP5
            WRITE (LU, 2) TMP2, TMP4, TMP6
            WRITE (LU, 6) ARGX(1:4), TMP5, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP6, UOPR(IOP)(1:LOP(IOP))
 6          FORMAT (6X,A,' = ',A,' ',A,' 0 ',A,' ',A,' ',A,' 0')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
          ENDIF
        ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (1)
            WRITE (LU, 7) TMP1, ARG1(1:L1)
 7          FORMAT (6X,A,' = ',A)
            WRITE (LU, 1) TMP1, TMP2
            WRITE (LU, 2) TMP2, ARG2(1:L2), TMP3
            WRITE (LU, 3) ARGX(1:4), TMP3, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ELSE
C
C   (Arg1 is IN or SP) and (Arg2 is MPC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (9)
            TMP6 = GETMP (1)
            TMP7 = GETMP (1)
            WRITE (LU, 7) TMP1, ARG1(1:L1)
            WRITE (LU, 1) TMP1, TMP2
            WRITE (LU, 4) TMP3
            WRITE (LU, 5) ARG2(1:L2), TMP4, TMP5
            WRITE (LU, 2) TMP2, TMP4, TMP6
            WRITE (LU, 2) TMP3, TMP5, TMP7
            WRITE (LU, 6) ARGX(1:4), TMP6, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP7, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
            CALL RLTMP (TMP7)
          ENDIF
        ELSEIF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is CO or DC) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (1)
            IF (ITP1 .EQ. 5) THEN
              WRITE (LU, 8) TMP1, ARG1(1:L1)
 8            FORMAT (6X,A,' = DREAL (',A,')')
              WRITE (LU, 9) TMP2, ARG1(1:L1)
 9            FORMAT (6X,A,' = DIMAG (',A,')')
            ELSE
              WRITE (LU, 10) TMP1, ARG1(1:L1)
 10           FORMAT (6X,A,' = REAL (',A,')')
              WRITE (LU, 11) TMP2, ARG1(1:L1)
 11           FORMAT (6X,A,' = AIMAG (',A,')')
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 2) TMP3, ARG2(1:L2), TMP4
            WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP2, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
          ELSE
C
C   (Arg1 is CO or DC) and (Arg2 is MPC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (9)
            TMP6 = GETMP (9)
            TMP7 = GETMP (1)
            TMP8 = GETMP (1)
            IF (ITP1 .EQ. 5) THEN
              WRITE (LU, 8) TMP1, ARG1(1:L1)
              WRITE (LU, 9) TMP2, ARG1(1:L1)
            ELSE
              WRITE (LU, 10) TMP1, ARG1(1:L1)
              WRITE (LU, 11) TMP2, ARG1(1:L1)
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 1) TMP2, TMP4
            WRITE (LU, 5) ARG2(1:L2), TMP5, TMP6
            WRITE (LU, 2) TMP3, TMP5, TMP7
            WRITE (LU, 2) TMP4, TMP6, TMP8
            WRITE (LU, 6) ARGX(1:4), TMP7, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP8, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
            CALL RLTMP (TMP7)
            CALL RLTMP (TMP8)
          ENDIF
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP2 .EQ. 3) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is DP).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (1)
            WRITE (LU, 1) ARG2(1:L2), TMP1
            WRITE (LU, 2) ARG1(1:L1), TMP1, TMP2
            WRITE (LU, 3) ARGX(1:4), TMP2, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is DP).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (1)
            TMP6 = GETMP (1)
            WRITE (LU, 1) ARG2(1:L2), TMP1
            WRITE (LU, 4) TMP2
            WRITE (LU, 5) ARG1(1:L1), TMP3, TMP4
            WRITE (LU, 2) TMP3, TMP1, TMP5
            WRITE (LU, 2) TMP4, TMP2, TMP6
            WRITE (LU, 6) ARGX(1:4), TMP5, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP6, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
          ENDIF
        ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is IN or SP).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (1)
            WRITE (LU, 7) TMP1, ARG2(1:L2)
            WRITE (LU, 1) TMP1, TMP2
            WRITE (LU, 2) ARG1(1:L1), TMP2, TMP3
            WRITE (LU, 3) ARGX(1:4), TMP3, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is IN or SP).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (9)
            TMP6 = GETMP (1)
            TMP7 = GETMP (1)
            WRITE (LU, 7) TMP1, ARG2(1:L2)
            WRITE (LU, 1) TMP1, TMP2
            WRITE (LU, 4) TMP3
            WRITE (LU, 5) ARG1(1:L1), TMP4, TMP5
            WRITE (LU, 2) TMP4, TMP2, TMP6
            WRITE (LU, 2) TMP5, TMP3, TMP7
            WRITE (LU, 6) ARGX(1:4), TMP6, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP7, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
            CALL RLTMP (TMP7)
          ENDIF
        ELSEIF (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is CO or DC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (1)
            IF (ITP2 .EQ. 5) THEN
              WRITE (LU, 8) TMP1, ARG2(1:L2)
              WRITE (LU, 9) TMP2, ARG2(1:L2)
            ELSE
              WRITE (LU, 10) TMP1, ARG2(1:L2)
              WRITE (LU, 11) TMP2, ARG2(1:L2)
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 2) ARG1(1:L1), TMP3, TMP4
            WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP2, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is CO or DC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (9)
            TMP6 = GETMP (9)
            TMP7 = GETMP (1)
            TMP8 = GETMP (1)
            IF (ITP2 .EQ. 5) THEN
              WRITE (LU, 8) TMP1, ARG2(1:L2)
              WRITE (LU, 9) TMP2, ARG2(1:L2)
            ELSE
              WRITE (LU, 10) TMP1, ARG2(1:L2)
              WRITE (LU, 11) TMP2, ARG2(1:L2)
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 1) TMP2, TMP4
            WRITE (LU, 5) ARG1(1:L1), TMP5, TMP6
            WRITE (LU, 2) TMP5, TMP3, TMP7
            WRITE (LU, 2) TMP6, TMP4, TMP8
            WRITE (LU, 6) ARGX(1:4), TMP7, UOPR(IOP)(1:LOP(IOP)),       
     $       ANDOR(1:5), TMP8, UOPR(IOP)(1:LOP(IOP))
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
            CALL RLTMP (TMP7)
            CALL RLTMP (TMP8)
          ENDIF
        ENDIF
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR).
C
        TMP1 = GETMP (1)
        WRITE (LU, 2) ARG1(1:L1), ARG2(1:L2), TMP1
        WRITE (LU, 3) ARGX(1:4), TMP1, UOPR(IOP)(1:LOP(IOP))
        CALL RLTMP (TMP1)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPC) and (Arg2 is MPI or MPR).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        TMP3 = GETMP (9)
        TMP4 = GETMP (1)
        TMP5 = GETMP (1)
        WRITE (LU, 5) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 4) TMP3
        WRITE (LU, 2) TMP1, ARG2(1:L2), TMP4
        WRITE (LU, 2) TMP2, TMP3, TMP5
        WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)),           
     $   ANDOR(1:5), TMP5, UOPR(IOP)(1:LOP(IOP))
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
        CALL RLTMP (TMP3)
        CALL RLTMP (TMP4)
        CALL RLTMP (TMP5)
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPC).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        TMP3 = GETMP (9)
        TMP4 = GETMP (1)
        TMP5 = GETMP (1)
        WRITE (LU, 5) ARG2(1:L2), TMP1, TMP2
        WRITE (LU, 4) TMP3
        WRITE (LU, 2) ARG1(1:L1), TMP1, TMP4
        WRITE (LU, 2) TMP3, TMP2, TMP5
        WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)),           
     $   ANDOR(1:5), TMP5, UOPR(IOP)(1:LOP(IOP))
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
        CALL RLTMP (TMP3)
        CALL RLTMP (TMP4)
        CALL RLTMP (TMP5)
      ELSE
C
C   (Arg1 is MPC) AND (Arg2 is MPC).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        TMP3 = GETMP (9)
        TMP4 = GETMP (9)
        TMP5 = GETMP (1)
        TMP6 = GETMP (1)
        WRITE (LU, 5) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 5) ARG2(1:L2), TMP3, TMP4
        WRITE (LU, 2) TMP1, TMP3, TMP5
        WRITE (LU, 2) TMP2, TMP4, TMP6
        WRITE (LU, 6) ARGX(1:4), TMP5, UOPR(IOP)(1:LOP(IOP)),           
     $   ANDOR(1:5), TMP6, UOPR(IOP)(1:LOP(IOP))
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
        CALL RLTMP (TMP3)
        CALL RLTMP (TMP4)
        CALL RLTMP (TMP5)
        CALL RLTMP (TMP6)
      ENDIF
      GOTO 110
C
C
 100  CALL ERRMES (52, 0)
      WRITE (6, 12) UOPR(IOP)(1:LOP(IOP))
 12   FORMAT ('Operation ',A,' is not defined with these operands.')
      CALL ABRT
C
 110  RETURN
      END
C
      SUBROUTINE GENDIV (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   This generates code for a divide operation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  The result
C   name is in ARGX (also input).  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
      IF (ITP1 .LT. 8) THEN
        IF (ITP1 .EQ. 3) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is DP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (9)
            WRITE (LU, 1) ARG1(1:L1), TMP1
 1          FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
            WRITE (LU, 2) TMP1, ARG2(1:L2), ARGX(1:4)
 2          FORMAT (6X,'CALL MPDIV (',A,', ',A,', ',A,')')
            CALL RLTMP (TMP1)
          ELSE
C
C   (Arg1 is DP) and (Arg2 is MPC).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (9)
            TMP3 = GETMP (10)
            WRITE (LU, 1) ARG1(1:L1), TMP1
            WRITE (LU, 3) TMP2
 3          FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')')
            WRITE (LU, 4) TMP1, TMP2, TMP3
 4          FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
            WRITE (LU, 5) TMP3, ARG2(1:L2), ARGX(1:4)
 5          FORMAT (6X,'CALL MPCDIV (MPNW4, ',A,', ',A,', ',A,')')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ENDIF
        ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            WRITE (LU, 6) TMP1, ARG1(1:L1)
 6          FORMAT (6X,A,' = ',A)
            WRITE (LU, 1) TMP1, TMP2
            WRITE (LU, 2) TMP2, ARG2(1:L2), ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ELSE
C
C   (Arg1 is IN or SP) and (Arg2 is MPC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            TMP4 = GETMP (10)
            WRITE (LU, 6) TMP1, ARG1(1:L1)
            WRITE (LU, 1) TMP1, TMP2
            WRITE (LU, 3) TMP3
            WRITE (LU, 4) TMP2, TMP3, TMP4
            WRITE (LU, 5) TMP4, ARG2(1:L2), ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
          ENDIF
        ELSEIF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is CO or DP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            IF (ITP1 .EQ. 5) THEN
              WRITE (LU, 7) TMP1, ARG1(1:L1)
 7            FORMAT (6X,A,' = DREAL (',A,')')
              WRITE (LU, 8) TMP2, ARG1(1:L1)
 8            FORMAT (6X,A,' = DIMAG (',A,')')
            ELSE
              WRITE (LU, 9) TMP1, ARG1(1:L1)
 9            FORMAT (6X,A,' = REAL (',A,')')
              WRITE (LU, 10) TMP2, ARG1(1:L1)
 10           FORMAT (6X,A,' = AIMAG (',A,')')
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 1) TMP2, TMP4
            WRITE (LU, 2) TMP3, ARG2(1:L2), ARGX(1:4)
            WRITE (LU, 11) TMP4, ARG2(1:L2), ARGX(1:4)
 11         FORMAT (6X,'CALL MPDIV (',A,', ',A,', ',A,'(MPNWQ+5))')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
          ELSE
C
C   (Arg1 is CO or DP) and (Arg2 is MPC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (10)
            IF (ITP1 .EQ. 5) THEN
              WRITE (LU, 7) TMP1, ARG1(1:L1)
              WRITE (LU, 8) TMP2, ARG1(1:L1)
            ELSE
              WRITE (LU, 9) TMP1, ARG1(1:L1)
              WRITE (LU, 10) TMP2, ARG1(1:L1)
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 1) TMP2, TMP4
            WRITE (LU, 4) TMP3, TMP4, TMP5
            WRITE (LU, 12) TMP5, ARG2(1:L2), ARGX(1:4)
 12         FORMAT (6X,'CALL MPCDIV (MPNW4, ',A,', ',A,', ',A,')')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
          ENDIF
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP2 .EQ. 3) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is DP).
C
            WRITE (LU, 13) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
 13         FORMAT (6X,'CALL MPDIVD (',A,', ',A,', 0, ',A,')')
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is DP).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (9)
            WRITE (LU, 14) ARG1(1:L1), TMP1, TMP2
 14         FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')')
            WRITE (LU, 13) TMP1, ARG2(1:L2), ARGX(1:4)
            WRITE (LU, 15) TMP2, ARG2(1:L2), ARGX(1:4)
 15         FORMAT (6X,'CALL MPDIVD (',A,', ',A,', 0, ',A,              
     $        '(MPNWQ+5))')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ENDIF
        ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is IN or SP).
C
            TMP1 = GETMP (3)
            WRITE (LU, 6) TMP1, ARG2(1:L2)
            WRITE (LU, 13) ARG1(1:L1), TMP1, ARGX(1:4)
            CALL RLTMP (TMP1)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is IN or SP).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            WRITE (LU, 6) TMP1, ARG2(1:L2)
            WRITE (LU, 14) ARG1(1:L1), TMP2, TMP3
            WRITE (LU, 13) TMP2, TMP1, ARGX(1:4)
            WRITE (LU, 15) TMP3, TMP1, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ENDIF
        ELSEIF (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is CO or DC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (10)
            TMP6 = GETMP (10)
            IF (ITP2 .EQ. 5) THEN
              WRITE (LU, 7) TMP1, ARG2(1:L2)
              WRITE (LU, 8) TMP2, ARG2(1:L2)
            ELSE
              WRITE (LU, 9) TMP1, ARG2(1:L2)
              WRITE (LU, 10) TMP2, ARG2(1:L2)
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 1) TMP2, TMP4
            WRITE (LU, 4) TMP3, TMP4, TMP5
            WRITE (LU, 3) TMP3
            WRITE (LU, 4) ARG1(1:L1), TMP3, TMP6
            WRITE (LU, 12) TMP6, TMP5, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
            CALL RLTMP (TMP6)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is CO or DC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (10)
            IF (ITP2 .EQ. 5) THEN
              WRITE (LU, 7) TMP1, ARG2(1:L2)
              WRITE (LU, 8) TMP2, ARG2(1:L2)
            ELSE
              WRITE (LU, 9) TMP1, ARG2(1:L2)
              WRITE (LU, 10) TMP2, ARG2(1:L2)
            ENDIF
            WRITE (LU, 1) TMP1, TMP3
            WRITE (LU, 1) TMP2, TMP4
            WRITE (LU, 4) TMP3, TMP4, TMP5
            WRITE (LU, 12) ARG1(1:L1), TMP5, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
          ENDIF
        ENDIF
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR).
C
        WRITE (LU, 2) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPC) and (Arg2 is MPI or MPR).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        WRITE (LU, 14) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 2) TMP1, ARG2(1:L2), ARGX(1:4)
        WRITE (LU, 11) TMP2, ARG2(1:L2), ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPC).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (10)
        WRITE (LU, 3) TMP1
        WRITE (LU, 4) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 12) TMP2, ARG2(1:L2), ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPC) and (Arg2 is MPC).
C
        WRITE (LU, 12) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE GENEXP (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   This generates code for an exponentiation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  The result
C   name is in ARGX (also input).  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
      IOP = 4
      IF (ITP1 .LT. 8) THEN
        IF (ITP1 .EQ. 3 .AND. ITP2 .EQ. 8) THEN
C
C   (Arg1 is DP) and (Arg2 is MPI).
C
          KCON(3) = 1
          TMP1 = GETMP (9)
          TMP2 = GETMP (8)
          TMP3 = GETMP (3)
          TMP4 = GETMP (1)
          TMP5 = GETMP (9)
          TMP6 = GETMP (9)
          WRITE (LU, 1) ARG1(1:L1), TMP1
 1        FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
          WRITE (LU, 2) ARG2(1:L2), TMP2
 2        FORMAT (6X,'CALL MPEQ (',A,', ',A,')')
          WRITE (LU, 3) TMP2, TMP2
 3        FORMAT (6X,'IF (',A,'(2) .EQ. 0. .OR. ',A,'(2) .EQ. 1) THEN')
          WRITE (LU, 4) TMP2, TMP3, TMP4
 4        FORMAT (6X,'CALL MPMDC (',A,', ',A,', ',A,')')
          WRITE (LU, 5) TMP4, TMP3, TMP4
 5        FORMAT (6X,A,' = ',A,' * 2.D0 ** ',A,' + 0.25D0')
          WRITE (LU, 6) TMP1, TMP4, ARGX(1:4)
 6        FORMAT (6X,'CALL MPNPWR (',A,', ',A,', ',A,')')
          WRITE (LU, 7)
 7        FORMAT (6X,'ELSE')
          WRITE (LU, 8) TMP1, TMP5
 8        FORMAT (6X,'CALL MPLOG (',A,', MPL02, ',A,')')
          WRITE (LU, 9) ARG2(1:L2), TMP5, TMP6
 9        FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,')')
          WRITE (LU, 10) TMP6, ARGX(1:4)
 10       FORMAT (6X,'CALL MPEXP (',A,', MPL02, ',A,')')
          WRITE (LU, 11)
 11       FORMAT (6X,'ENDIF')
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
          CALL RLTMP (TMP6)
        ELSEIF (ITP1 .EQ. 3 .AND. ITP2 .EQ. 9) THEN
C
C   (Arg1 is DP) and (Arg2 is MPR).
C
          KCON(3) = 1
          TMP1 = GETMP (9)
          TMP2 = GETMP (9)
          TMP3 = GETMP (9)
          WRITE (LU, 1) ARG1(1:L1), TMP1
          WRITE (LU, 8) TMP1, TMP2
          WRITE (LU, 9) ARG2(1:L2), TMP2, TMP3
          WRITE (LU, 10) TMP3, ARGX(1:4)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
        ELSEIF ((ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) .AND. ITP2 .EQ. 8) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MPI).
C
          KCON(3) = 1
          TMP1 = GETMP (9)
          TMP2 = GETMP (8)
          TMP3 = GETMP (3)
          TMP4 = GETMP (1)
          TMP5 = GETMP (9)
          TMP6 = GETMP (9)
          WRITE (LU, 12) TMP3, ARG1(1:L1)
 12       FORMAT (6X,A,' = ',A)
          WRITE (LU, 1) TMP3, TMP1
          WRITE (LU, 2) ARG2(1:L2), TMP2
          WRITE (LU, 3) TMP2, TMP2
          WRITE (LU, 4) TMP2, TMP3, TMP4
          WRITE (LU, 5) TMP4, TMP3, TMP4
          WRITE (LU, 6) TMP1, TMP4, ARGX(1:4)
          WRITE (LU, 7)
          WRITE (LU, 8) TMP1, TMP5
          WRITE (LU, 9) ARG2(1:L2), TMP5, TMP6
          WRITE (LU, 10) TMP6, ARGX(1:4)
          WRITE (LU, 11)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
          CALL RLTMP (TMP6)
        ELSEIF ((ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) .AND. ITP2 .EQ. 9) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MPI or MPR).
C
          KCON(3) = 1
          TMP1 = GETMP (3)
          TMP2 = GETMP (9)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          WRITE (LU, 13) TMP1, ARG1(1:L1)
 13       FORMAT (6X,A,' = ',A)
          WRITE (LU, 1) TMP1, TMP2
          WRITE (LU, 8) TMP2, TMP3
          WRITE (LU, 9) ARG2(1:L2), TMP3, TMP4
          WRITE (LU, 10) TMP4, ARGX(1:4)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
        ELSE
          GOTO 100
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP1 .NE. 10 .AND. ITP2 .EQ. 1) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is IN).
C
          WRITE (LU, 14) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
 14       FORMAT (6X,'CALL MPNPWR (',A,', ',A,', ',A,')')
        ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .EQ. 1) THEN
C
C   (Arg1 is MPC) and (Arg2 is IN).  This is the only permissible
C   exponentiation with a MPC operand.
C
          WRITE (LU, 15) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
 15       FORMAT (6X, 'CALL MPCPWR (MPNW4, ',A,', ',A,', ',A,')')
        ELSEIF (ITP1 .NE. 10 .AND. (ITP2 .EQ. 2 .OR. ITP2 .EQ. 3))      
     $      THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is SP or DP).
C
          KCON(3) = 1
          TMP1 = GETMP (3)
          TMP2 = GETMP (9)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          WRITE (LU, 13) TMP1(1:4), ARG2(1:L2)
          WRITE (LU, 1) TMP1(1:4), TMP2
          WRITE (LU, 8) ARG1(1:L1), TMP3
          WRITE (LU, 9) TMP2, TMP3, TMP4
          WRITE (LU, 10) TMP4, ARGX(1:4)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
        ELSE
          GOTO 100
        ENDIF
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 8) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPI).
C
        KCON(3) = 1
        TMP1 = GETMP (8)
        TMP2 = GETMP (3)
        TMP3 = GETMP (1)
        TMP4 = GETMP (9)
        TMP5 = GETMP (9)
        WRITE (LU, 2) ARG2(1:L2), TMP1
        WRITE (LU, 3) TMP1, TMP1
        WRITE (LU, 4) TMP1, TMP2, TMP3
        WRITE (LU, 5) TMP3, TMP2, TMP3
        WRITE (LU, 6) ARG1(1:L1), TMP3, ARGX(1:4)
        WRITE (LU, 7)
        WRITE (LU, 8) ARG1(1:L1), TMP4
        WRITE (LU, 9) ARG2(1:L2), TMP4, TMP5
        WRITE (LU, 10) TMP5, ARGX(1:4)
        WRITE (LU, 11)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
        CALL RLTMP (TMP3)
        CALL RLTMP (TMP4)
        CALL RLTMP (TMP5)
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 9) THEN
C
C  (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR).
C
        KCON(3) = 1
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        WRITE (LU, 8) ARG1(1:L1), TMP1
        WRITE (LU, 9) ARG2(1:L2), TMP1, TMP2
        WRITE (LU, 10) TMP2, ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ENDIF
      GOTO 110
C
 100  CALL ERRMES (53, 0)
      WRITE (6, 16) UOPR(IOP)(1:LOP(IOP))
 16   FORMAT ('Operation ',A,' is not defined with these operands.')
      CALL ABRT
C
 110  RETURN
      END
C
      SUBROUTINE GENMUL (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   This generates code for a multiply operation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  The result
C   name is in ARGX (also input).  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
      IF (ITP1 .LT. 8) THEN
        IF (ITP1 .EQ. 3) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is DP) and (Arg2 is MPI or MPR).
C
            WRITE (LU, 1) ARG2(1:L2), ARG1(1:L1), ARGX(1:4)
 1          FORMAT (6X,'CALL MPMULD (',A,', ',A,', 0, ',A,')')
          ELSE
C
C   (Arg1 is DP) and (Arg2 is MPC).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (9)
            WRITE (LU, 2) ARG2(1:L2), TMP1, TMP2
 2          FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')')
            WRITE (LU, 1) TMP1, ARG1(1:L1), ARGX(1:4)
            WRITE (LU, 3) TMP2, ARG1(1:L1), ARGX(1:4)
 3          FORMAT (6X,'CALL MPMULD (',A,', ',A,', 0, ',A,              
     $        '(MPNWQ+5))')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ENDIF
        ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (3)
            WRITE (LU, 4) TMP1, ARG1(1:L1)
 4          FORMAT (6X,A,' = ',A)
            WRITE (LU, 1) ARG2(1:L2), TMP1, ARGX(1:4)
            CALL RLTMP (TMP1)
          ELSE
C
C   (Arg1 is IN or SP) and (Arg2 is MPC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            WRITE (LU, 4) TMP1, ARG1(1:L1)
            WRITE (LU, 2) ARG2(1:L2), TMP2, TMP3
            WRITE (LU, 1) TMP2, TMP1, ARGX(1:4)
            WRITE (LU, 3) TMP3, TMP1, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ENDIF
        ELSEIF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5) THEN
          IF (ITP2 .NE. 10) THEN
C
C   (Arg1 is CO or DP) and (Arg2 is MPI or MPR).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            IF (ITP1 .EQ. 5) THEN
              WRITE (LU, 5) TMP1, ARG1(1:L1)
 5            FORMAT (6X,A,' = DREAL (',A,')')
              WRITE (LU, 6) TMP2, ARG1(1:L1)
 6            FORMAT (6X,A,' = DIMAG (',A,')')
            ELSE
              WRITE (LU, 7) TMP1, ARG1(1:L1)
 7            FORMAT (6X,A,' = REAL (',A,')')
              WRITE (LU, 8) TMP2, ARG1(1:L1)
 8            FORMAT (6X,A,' = AIMAG (',A,')')
            ENDIF
            WRITE (LU, 1) ARG2(1:L2), TMP1, ARGX(1:4)
            WRITE (LU, 3) ARG2(1:L2), TMP2, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ELSE
C
C   (Arg1 is CO or DP) and (Arg2 is MPC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (10)
            IF (ITP1 .EQ. 5) THEN
              WRITE (LU, 5) TMP1, ARG1(1:L1)
              WRITE (LU, 6) TMP2, ARG1(1:L1)
            ELSE
              WRITE (LU, 7) TMP1, ARG1(1:L1)
              WRITE (LU, 8) TMP2, ARG1(1:L1)
            ENDIF
            WRITE (LU, 9) TMP1, TMP3
 9          FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
            WRITE (LU, 9) TMP2, TMP4
            WRITE (LU, 10) TMP3, TMP4, TMP5
 10         FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
            WRITE (LU, 11) TMP5, ARG2(1:L2), ARGX(1:4)
 11         FORMAT (6X,'CALL MPCMUL (MPNW4, ',A,', ',A,', ',A,')')
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
          ENDIF
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP2 .EQ. 3) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is DP).
C
            WRITE (LU, 1) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is DP).
C
            TMP1 = GETMP (9)
            TMP2 = GETMP (9)
            WRITE (LU, 2) ARG1(1:L1), TMP1, TMP2
            WRITE (LU, 1) TMP1, ARG2(1:L2), ARGX(1:4)
            WRITE (LU, 3) TMP2, ARG2(1:L2), ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ENDIF
        ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is IN or SP).
C
            TMP1 = GETMP (3)
            WRITE (LU, 4) TMP1, ARG2(1:L2)
            WRITE (LU, 1) ARG1(1:L1), TMP1, ARGX(1:4)
            CALL RLTMP (TMP1)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is IN or SP).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            WRITE (LU, 4) TMP1, ARG2(1:L2)
            WRITE (LU, 2) ARG1(1:L1), TMP2, TMP3
            WRITE (LU, 1) TMP2, TMP1, ARGX(1:4)
            WRITE (LU, 3) TMP3, TMP1, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ENDIF
        ELSEIF (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) THEN
          IF (ITP1 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is CO or DC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            IF (ITP2 .EQ. 5) THEN
              WRITE (LU, 5) TMP1, ARG2(1:L2)
              WRITE (LU, 6) TMP2, ARG2(1:L2)
            ELSE
              WRITE (LU, 7) TMP1, ARG2(1:L2)
              WRITE (LU, 8) TMP2, ARG2(1:L2)
            ENDIF
            WRITE (LU, 1) ARG1(1:L1), TMP1, ARGX(1:4)
            WRITE (LU, 3) ARG1(1:L1), TMP2, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
          ELSE
C
C   (Arg1 is MPC) and (Arg2 is CO or DC).
C
            TMP1 = GETMP (3)
            TMP2 = GETMP (3)
            TMP3 = GETMP (9)
            TMP4 = GETMP (9)
            TMP5 = GETMP (10)
            IF (ITP2 .EQ. 5) THEN
              WRITE (LU, 5) TMP1, ARG2(1:L2)
              WRITE (LU, 6) TMP2, ARG2(1:L2)
            ELSE
              WRITE (LU, 7) TMP1, ARG2(1:L2)
              WRITE (LU, 8) TMP2, ARG2(1:L2)
            ENDIF
            WRITE (LU, 9) TMP1, TMP3
            WRITE (LU, 9) TMP2, TMP4
            WRITE (LU, 10) TMP3, TMP4, TMP5
            WRITE (LU, 11) ARG1(1:L1), TMP5, ARGX(1:4)
            CALL RLTMP (TMP1)
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
            CALL RLTMP (TMP4)
            CALL RLTMP (TMP5)
          ENDIF
        ENDIF
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR).
C
        WRITE (LU, 12) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
 12     FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,')')
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPC) and (Arg2 is MPI or MPR).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        WRITE (LU, 2) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 12) TMP1, ARG2(1:L2), ARGX(1:4)
        WRITE (LU, 13) TMP2, ARG2(1:L2), ARGX(1:4)
 13     FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,'(MPNWQ+5))')
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPC).
C
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        WRITE (LU, 2) ARG2(1:L2), TMP1, TMP2
        WRITE (LU, 12) ARG1(1:L1), TMP1, ARGX(1:4)
        WRITE (LU, 13) ARG1(1:L1), TMP2, ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPC) and (Arg2 is MPC).
C
        WRITE (LU, 11) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE GENSUB (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX)
C
C   This generates code for a subtract operation.  The operands are in ARG1 and
C   ARG2, with types ITP1 and ITP2, and with lengths L1 and L2.  The result
C   name is in ARGX (also input).  LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG2, ARGX
      CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP
C
      IF (ITP1 .EQ. 0) THEN
C
C   Handle the negation of a MP entity.
C
        IF (ITP2 .NE. 10) THEN
C
C   Arg2 is MPI or MPR.
C
          WRITE (LU, 1) ARG2(1:L2), ARGX(1:4)
 1        FORMAT (6X,'CALL MPEQ (',A,', ',A,')')
          WRITE (LU, 2) ARGX(1:4), ARGX(1:4)
 2        FORMAT (6X,A,'(1) = - ',A,'(1)')
        ELSE
C
C   Arg2 is MPC.
C
          WRITE (LU, 3) ARG2(1:L2), ARGX(1:4)
 3        FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')')
          WRITE (LU, 2) ARGX(1:4), ARGX(1:4)
          WRITE (LU, 4) ARGX(1:4), ARGX(1:4)
 4        FORMAT (6X,A,'(MPNWQ+5) = - ',A,'(MPNWQ+5)')
        ENDIF
      ELSEIF (ITP1 .LT. 8) THEN
        IF (ITP1 .EQ. 3) THEN
C
C   (Arg1 is DP) and (Arg2 is MP).
C
          TMP1 = GETMP (9)
          IF (ITP2 .EQ. 10) THEN
            WRITE (LU, 5) ARG2(1:L2), ARGX(1:4)
 5          FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')')
          ENDIF
          WRITE (LU, 6) ARG1(1:L1), TMP1
 6        FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')')
          WRITE (LU, 7) TMP1, ARG2(1:L2), ARGX(1:4)
 7        FORMAT (6X,'CALL MPSUB (',A,', ',A,', ',A,')')
          CALL RLTMP (TMP1)
        ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN
C
C   (Arg1 is IN or SP) and (Arg2 is MP).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (9)
          IF (ITP2 .EQ. 10) THEN
            WRITE (LU, 5) ARG2(1:L2), ARGX(1:4)
          ENDIF
          WRITE (LU, 8) TMP1, ARG1(1:L1)
 8        FORMAT (6X,A,' = ',A)
          WRITE (LU, 6) TMP1, TMP2
          WRITE (LU, 9) TMP2, ARG2(1:L2), ARGX(1:4)
 9        FORMAT (6X,'CALL MPSUB (',A,', ',A,', ',A,')')
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
        ELSE
C
C   (Arg1 is CO or DC) and (Arg2 is MP).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (3)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          TMP5 = GETMP (10)
          IF (ITP1 .EQ. 5) THEN
            WRITE (LU, 10) TMP1, ARG1(1:L1)
 10         FORMAT (6X,A,' = DREAL (',A,')')
            WRITE (LU, 11) TMP2, ARG1(1:L1)
 11         FORMAT (6X,A,' = DIMAG (',A,')')
          ELSE
            WRITE (LU, 12) TMP1, ARG1(1:L1)
 12         FORMAT (6X,A,' = REAL (',A,')')
            WRITE (LU, 13) TMP2, ARG1(1:L1)
 13         FORMAT (6X,A,' = AIMAG (',A,')')
          ENDIF
          WRITE (LU, 6) TMP1, TMP3
          WRITE (LU, 6) TMP2, TMP4
          WRITE (LU, 14) TMP3, TMP4, TMP5
 14       FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
          IF (ITP2 .EQ. 10) THEN
            WRITE (LU, 15) TMP5, ARG2(1:L2), ARGX(1:4)
 15         FORMAT (6X,'CALL MPCSUB (MPNW4, ',A,', ',A,', ',A,')')
          ELSE
            TMP6 = GETMP (10)
            WRITE (LU, 16) TMP3
 16         FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')')
            WRITE (LU, 14) ARG2(1:L2), TMP3, TMP6
            WRITE (LU, 15) TMP5, TMP6, ARGX(1:4)
            CALL RLTMP (TMP6)
          ENDIF
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
        ENDIF
      ELSEIF (ITP2 .LT. 8) THEN
        IF (ITP2 .EQ. 3) THEN
C
C   (Arg1 is MP) and (Arg2 is DP).
C
          TMP1 = GETMP (9)
          IF (ITP1 .EQ. 10) THEN
            WRITE (LU, 5) ARG1(1:L1), ARGX(1:4)
          ENDIF
          WRITE (LU, 6) ARG2(1:L2), TMP1
          WRITE (LU, 7) ARG1(1:L1), TMP1, ARGX(1:4)
          CALL RLTMP (TMP1)
        ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN
C
C   (Arg1 is MP) and (Arg2 is IN or SP).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (9)
          IF (ITP1 .EQ. 10) THEN
            WRITE (LU, 5) ARG1(1:L1), ARGX(1:4)
          ENDIF
          WRITE (LU, 8) TMP1, ARG2(1:L2)
          WRITE (LU, 6) TMP1, TMP2
          WRITE (LU, 7) ARG1(1:L1), TMP2, ARGX(1:4)
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
        ELSE
C
C   (Arg1 is MP) and (Arg2 is CO or DC).
C
          TMP1 = GETMP (3)
          TMP2 = GETMP (3)
          TMP3 = GETMP (9)
          TMP4 = GETMP (9)
          TMP5 = GETMP (10)
          IF (ITP2 .EQ. 5) THEN
            WRITE (LU, 10) TMP1, ARG2(1:L2)
            WRITE (LU, 11) TMP2, ARG2(1:L2)
          ELSE
            WRITE (LU, 12) TMP1, ARG2(1:L2)
            WRITE (LU, 13) TMP2, ARG2(1:L2)
          ENDIF
          WRITE (LU, 6) TMP1, TMP3
          WRITE (LU, 6) TMP2, TMP4
          WRITE (LU, 14) TMP3, TMP4, TMP5
          IF (ITP1 .EQ. 10) THEN
            WRITE (LU, 15) ARG1(1:L1), TMP5, ARGX(1:4)
          ELSE
            TMP6 = GETMP (10)
            WRITE (LU, 16) TMP3
            WRITE (LU, 14) ARG1(1:L1), TMP3, TMP6
            WRITE (LU, 15) TMP6, TMP5, ARGX(1:4)
            CALL RLTMP (TMP6)
          ENDIF
          CALL RLTMP (TMP1)
          CALL RLTMP (TMP2)
          CALL RLTMP (TMP3)
          CALL RLTMP (TMP4)
          CALL RLTMP (TMP5)
        ENDIF
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR).
C
        WRITE (LU, 9) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN
C
C   (Arg1 is MPI or MPR) and (Arg2 is MPC).
C
        TMP1 = GETMP (3)
        TMP2 = GETMP (10)
        WRITE (LU, 16) TMP1
        WRITE (LU, 14) ARG1(1:L1), TMP1, TMP2
        WRITE (LU, 15) TMP2, ARG2(1:L2), ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN
C
C   (Arg1 is MPC) and (Arg1 is MPI or MPR).
C
        TMP1 = GETMP (3)
        TMP2 = GETMP (10)
        WRITE (LU, 16) TMP1
        WRITE (LU, 14) ARG2(1:L2), TMP1, TMP2
        WRITE (LU, 15) ARG1(1:L1), TMP2, ARGX(1:4)
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
      ELSE
C
C   (Arg1 is MPC) and (Arg2 is MPC).
C
        WRITE (LU, 15) ARG1(1:L1), ARG2(1:L2), ARGX(1:4)
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE GENFUN (LU, ITP1, L1, ARG1, NAR, ITAR, LAR, ARG, ITPX, 
     $  LX, ARGX)
C
C   This generates code for a function reference.  The function name is ARG1,
C   with type ITP1 and length L1.  NAR is the number of arguments.  The
C   argument list is input in ARG, with types in ITAR and lengths in LAR.
C   The result is placed in ARGX, with type in ITPX and length in LX.  LU is
C   the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINY
      CHARACTER*80 ARG1, ARG(MAR), ARGI, ARGJ, ARGX
      CHARACTER*16 NAM, NAMQ, UCASE
      DIMENSION ITAR(MAR), LAR(MAR)
      CHARACTER*4 GETMP, TMP1
C*
C      write (lu, *) 'enter genfun nar, arg1 =', nar,
C     $  '  %'//arg1(1:l1)//'%'
C      write (lu, '(2i4,2x,a)') (i, itar(i), arg(i)(1:lar(i)),
C     $  i = 1, nar)
C*
      NAMQ = 'DPNRT'
      IQNRT = ITAB (0, 0, NAMQ)
      NAMQ = 'MPINT'
      IQINT = ITAB (0, 0, NAMQ)
      NAMQ = 'ABS'
      IQABS = ITAB (0, 0, NAMQ)
      NAMQ = 'NINT'
      IQNINT = ITAB (0, 0, NAMQ)
C
C   Check if this function is one of the obsolescent type-specific intrinsics.
C
      NAMQ = UCASE (ARG1(1:L1))
C
      DO 100 I = 1, NSF
        IF (SFUN(I) .EQ. NAMQ) THEN
          CALL ERRMES (54, 0)
          WRITE (6, 1) ARG1(1:L1)
 1        FORMAT ('This type-specific Fortran intrinsic function is',   
     $      ' not allowed: ',A/'Replace with the equivalent Fortran',   
     $      ' generic function.')
          CALL ABRT
        ENDIF
 100  CONTINUE
C
C   Find the function name in the symbol table.
C
      LL = MIN (L1, 16)
      NAM = ARG1(1:LL)
      IX = ITAB (0, 0, NAM)
      IF (IX .EQ. 0) CALL ERRMES (55, 1)
      IF (IX .GT. MINT) CALL CHKARG (LU, NAM, NAR, ITAR, LAR, ARG)
C
C   Check if this is a reference to an intrisic function.
C
      IF (IX .LE. MINT) THEN
C
C   Check if the mixed mode safe option is in effect.
C
        IF (IMM .GE. 1) THEN
C
C   Convert any non-MP arguments to MP.
C
          DO 110 I = 1, NAR
            ITPI = ITAR(I)
            LI = LAR(I)
            ARGI(1:LI) = ARG(I)(1:LI)
            IF (IX .EQ. IQNRT .AND. I .EQ. 2) GOTO 110
            IF (ITPI .EQ. 1) THEN
              ITPJ = 8
            ELSEIF (ITPI .EQ. 2 .OR. ITPI .EQ. 3) THEN
              ITPJ = 9
            ELSEIF (ITPI .EQ. 4 .OR. ITPI .EQ. 5) THEN
              ITPJ = 10
            ELSE
              GOTO 110
            ENDIF
            LJ = 4
            ARGJ(1:4) = GETMP (ITPJ)
            CALL GENASN (LU, ITPJ, LJ, ARGJ, ITPI, LI, ARGI)
            IF (LI .EQ. 4) THEN
              IF (ARGI(1:2) .EQ. 'MP') THEN
                TMP1 = ARGI(1:4)
                CALL RLTMP (TMP1)
              ENDIF
            ENDIF
C
C   Substitute the new argument (a MP temporary) for the old.
C
            ITAR(I) = ITPJ
            LAR(I) = 4
            ARG(I)(1:4) = ARGJ(1:4)
 110      CONTINUE
C
        ENDIF
        ITM = 0
C
C   Determine if any arguments are of a MP type.
C
        DO 120 I = 1, NAR
          IF (ITAR(I) .GE. 8) ITM = 1
 120    CONTINUE
C
C   Call INTRIN for intrinsic calls with MP arguments.  Other intrinsic
C   references will be handled in this routine.
C
        IF (ITM .NE. 0 .OR. IX .GE. IQINT) THEN
          CALL INTRIN (LU, ITP1, L1, ARG1, NAR, ITAR, LAR, ARG, ITPX,   
     $      LX, ARGX)
          GOTO 150
        ELSEIF (ITP1 .EQ. -1) THEN
C
C   Except for ABS with a complex or double complex argument, and NINT, the
C   result type of a Fortran-77 intrinsic functions with an argument-dependent
C   type is the type of the first argument.
C
          IF (IX .EQ. IQABS) THEN
            IF (ITAR(1) .EQ. 4) THEN
              ITPX = 2
            ELSEIF (ITAR(1) .EQ. 5) THEN
              ITPX = 3
            ELSE
              ITPX = ITAR(1)
            ENDIF
          ELSEIF (IX .EQ. IQNINT) THEN
            ITPX = 1
          ELSE
            ITPX = ITAR(1)
          ENDIF
        ELSE
          ITPX = ITP1
        ENDIF
      ELSE
C
C   For all other cases, set the result to be a temporary of type ITP1.
C
        ITPX = ITP1
      ENDIF
C
      IF (LU .EQ. 12 .AND. IX .GT. MINT) THEN
        CALL ERRMES (56, 0)
        WRITE (6, 2)
 2      FORMAT ('Only intrinsic functions may appear in a parameter',   
     $    ' statement.')
        CALL ABRT
      ENDIF
C
      LX = 4
      ARGX = GETMP (ITPX)
C
C   Check if this is an ordinary function reference of type MP.  If so,
C   generate a call statement.
C
      IF (ITP1 .GE. 8) THEN
        LINY(1:11) = '      CALL '
        LINY(12:L1+11) = ARG1(1:L1)
        LINY(L1+12:L1+13) = ' ('
        LY = L1 + 13
C
C   Append the argument list.
C
        DO 130 I = 1, NAR
          LI = LAR(I)
          LINY(LY+1:LY+LI) = ARG(I)(1:LI)
          LINY(LY+LI+1:LY+LI+2) = ', '
          LY = LY + LI + 2
 130    CONTINUE
C
C   Set the last argument of the call statement to be the result temporary
C   name.
C
        LINY(LY+1:LY+4) = ARGX(1:4)
        LINY(LY+5:LY+5) = ')'
        LY = LY + 5
C
C   Check if it is a non-MP function reference.  If so, generate an assignment
C   statement.
C
      ELSE
        LINY(1:6) = ' '
        LINY(7:10) = ARGX(1:4)
        LINY(11:13) = ' = '
        LINY(14:L1+13) = ARG1(1:L1)
        LINY(L1+14:L1+15) = ' ('
        LY = L1 + 15
C
C   Append the argument list.
C
        DO 140 I = 1, NAR
          LI = LAR(I)
          LINY(LY+1:LY+LI) = ARG(I)(1:LI)
          LINY(LY+LI+1:LY+LI+2) = ', '
          LY = LY + LI + 2
 140    CONTINUE
C
        IF (NAR .EQ. 0) THEN
          LY = LY + 1
        ELSE
          LY = LY - 1
        ENDIF
        LINY(LY:LY) = ')'
C
      ENDIF
C
      IF (LU .EQ. 11) THEN
        CALL OUTLIN (1, LY, LINY)
      ELSE
        CALL OUTLIN (3, LY, LINY)
      ENDIF
C
C   Release any temporaries among the arguments.
C
 150  DO 160 I = 1, NAR
        LI = LAR(I)
        IF (LI .EQ. 4) THEN
          IF (ARG(I)(1:2) .EQ. 'MP') THEN
            TMP1 = ARG(I)(1:4)
            CALL RLTMP (TMP1)
          ENDIF
        ENDIF
 160  CONTINUE
C*
C      write (lu, *) 'exit genfun  itpx, argx =', itpx,
C     $  ' %'//argx(1:lx)//'%'
C*
      RETURN
      END
C
      FUNCTION GETMP (ITP)
C
C   This returns a temporary variable name that is of type ITP.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*4 GETMP
      CHARACTER*16 NAM
C
      IF (ITP .LE. 0 .OR. ITP .GT. 11) THEN
        CALL ERRMES (57, 0)
        WRITE (6, 1)
 1      FORMAT ('Improper type input to GETMP.')
        CALL ABRT
      ENDIF
C
C   The two character types don't need to be put in the table, since they are
C   never retained after definition.
C
      IF (ITP .EQ. 6) THEN
        GETMP = 'MPA1'
        GOTO 120
      ELSEIF (ITP .EQ. 11) THEN
        GETMP = 'MPA2'
        GOTO 120
      ENDIF
C
      DO 100 I = 1, 9
        IF (ITMP(I,ITP) .EQ. 0) GOTO 110
 100  CONTINUE
C
      CALL ERRMES (58, 0)
      WRITE (6, 2)
 2    FORMAT ('Statement is too complicated.')
      CALL ABRT
C
 110  ITMP(I,ITP) = 1
      WRITE (GETMP, 3) CTM(ITP), I
 3    FORMAT ('MP',A1,I1)
C
 120  NAM = GETMP
      IX = ITAB (2, ITP, NAM)
C
      RETURN
      END
C
      SUBROUTINE IFST (IFL, IFS, K1, LN)
C
C   This handles MP IF and ELSEIF statements.  K1 is the index of the left
C   parenthesis, and LN is the last non-blank character in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*80 ARGX
      CHARACTER*16 LINQ, UCASE
      CHARACTER*4 TMP1
C
C   If this is an elseif statement, increase the IFL counter and output an
C   else statement.
C
      IF (IFS .EQ. 2) THEN
        IFL = IFL + 1
        WRITE (11, 1)
 1      FORMAT (6X,'ELSE')
      ENDIF
C
C   Locate the matching right parenthesis of the left parenthesis.
C
      J1 = K1
      J2 = MATCH (0, J1 + 1, LN, LINE)
C
C   Determine whether the expression inside the parentheses and the expression
C   following the parentheses have MP variables.
C
      I1 = ISCAN (J1, J2, LINE)
      IF (I1 .NE. 0) CALL FIXSUB (J1, J2, LN)
      J3 = NBLK (J2 + 1, LN, LINE)
      LQ = MIN (J3 + 15, LN)
      LINQ = UCASE (LINE(J3:LQ))
      IF (J3 + 3 .EQ. LN .AND. LINQ(1:4) .EQ. 'THEN') THEN
        I2 = 0
        ITH = 1
      ELSE
        I2 = ISCAN (J3, LN, LINE)
        J4 = LN
        IF (I2 .NE. 0) CALL FIXSUB (J3, J4, LN)
        ITH = 0
      ENDIF
C
C   If the expression inside parentheses has no MP variables, there is no
C   need to process it.
C
      IF (I1 .EQ. 0) THEN
        LA = J2
        LINA(1:LA) = LINE(1:LA)
        CALL OUTLIN (1, LA, LINA)
        WRITE (11, 2)
 2      FORMAT (5X,'$  THEN')
      ELSE
C
C   Process the expression inside parentheses.
C
        LA = J2 - J1 - 1
        LINA(1:LA) = LINE(J1+1:J2-1)
        CALL EXPRES (11, LA, LINA, ITPX, LX, ARGX)
C
C   Check if the result of the expression in parentheses is of type logical.
C
        IF (ITPX .NE. 7) THEN
          CALL ERRMES (59, 0)
          WRITE (6, 3)
 3        FORMAT ('Result of expression in parentheses is not of type', 
     $      ' logical.')
          CALL ABRT
        ENDIF
C
C   Output IF statement with the resulting logical variable.
C
        WRITE (11, 4) ARGX(1:LX)
 4      FORMAT (6X,'IF (',A,') THEN')
C
C   Release final logical temporary variable.
C
        TMP1 = ARGX(1:LX)
        CALL RLTMP (TMP1)
      ENDIF
C
C   If the expression following the parentheses is merely THEN, then we are
C   done.
C
      IF (ITH .EQ. 1) GOTO 100
C
C   If the expression following the parentheses has no MP variables, then
C   it does not need to be processed.
C
      IF (I2 .EQ. 0) THEN
        LA = LN - J2 + 6
        LINA(1:6) = ' '
        LINA(7:LA) = LINE(J2+1:LN)
        CALL OUTLIN (1, LA, LINA)
      ELSE
C
C   Process the executable MP expression after the parentheses.
C
        J1 = J2 + 1
        IF (J1 .GT. LN) CALL ERRMES (60, 1)
        J1 = NBLK (J1, LN, LINE)
        CALL EXEC (J1, LN)
      ENDIF
C
      WRITE (11, 5)
 5    FORMAT (6X,'ENDIF')
C
 100  RETURN
      END
C
      SUBROUTINE IMPLIC (K1, LN)
C
C   This handles IMPLICIT statements.  K1 and LN are the indices of the
C   first (after 'IMPLICIT') and last non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*16 LINQ, UCASE
      CHARACTER*1 CJ
C
C   Check if this is an implicit 'none' statement.
C
      J1 = K1
      IF (J1 + 3 .EQ. LN) THEN
        LINQ = UCASE (LINE(J1:LN))
        IF (LINQ(1:4) .EQ. 'NONE') THEN
C
          DO 100 I = 1, 26
            IF (IMPL(I) .LE. 7) IMPL(I) = 0
 100      CONTINUE
C
          GOTO 130
        ENDIF
      ENDIF
      IT = NTYPE (J1, LN)
      J1 = INDX (J1, LN, '(', LINE)
      IF (IT .EQ. 0 .OR. J1 .EQ. 0) CALL ERRMES (61, 1)
C
C   Process a normal implicit statement.
C
 110  J1 = NBLK (J1 + 1, LN, LINE)
      CJ = LINE(J1:J1)
      IF (CJ .EQ. '(') GOTO 110
      IF (CJ .EQ. ',') GOTO 110
      IF (CJ .EQ. ')') GOTO 130
      I1 = MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ))
      IF (J1 .EQ. 0 .OR. I1 .EQ. 0) CALL ERRMES (62, 1)
      IF (IMPL(I1) .LE. 7) IMPL(I1) = IT
      J2 = NBLK (J1 + 1, LN, LINE)
      CJ = LINE(J2:J2)
      IF (CJ .EQ. '-') THEN
        J2 = NBLK (J2 + 1, LN, LINE)
        CJ = LINE(J2:J2)
        I2 = MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ))
        IF (I2 .EQ. 0) CALL ERRMES (63, 1)
C
        DO 120 I = I1, I2
          IF (IMPL(I) .LE. 7) IMPL(I) = IT
 120    CONTINUE
C
        J1 = J2
      ENDIF
      GOTO 110
C
 130  RETURN
      END
C
      FUNCTION INDX (K1, K2, CX, LINA)
C
C   Finds the index of the first instance of character CX in LINA between
C   positions K1 and K2.
C
      CHARACTER*1600 LINA
      CHARACTER*1 CX
C
      DO 100 I = K1, K2
        IF (LINA(I:I) .EQ. CX) GOTO 110
 100  CONTINUE
C
      I = 0
 110  INDX = I
C
      RETURN
      END
C
      SUBROUTINE INIMP
C
C   This generates declaration and initialization code for MP routines.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 LIN
      CHARACTER*16 NAM
      CHARACTER*8 NUM1, NUM2, NUM3, NUM4, NUMX
C
C   Optionally print out the symbol table for this subprogram.
C*
C      write (6, '(4i4,2x,a)') (i, ktyp(i), kdim(i), lvar(i),
C     $  '%'//var(i)(1:lvar(i))//'%', i = mint + 1, nvar)
C*
C   Place the character and MP dimensions into character variables.
C
      WRITE (NUMX, '(I8)') MXP + 4
      I1 = NBLK (1, 8, NUMX)
      N1 = 9 - I1
      NUM1 = NUMX(I1:8)
      WRITE (NUMX, '(I8)') 2 * MXP + 8
      I1 = NBLK (1, 8, NUMX)
      N2 = 9 - I1
      NUM2 = NUMX(I1:8)
      WRITE (NUMX, '(I8)') INT (7.225 * MXP) + 100
      I1 = NBLK (1, 8, NUMX)
      N3 = 9 - I1
      NUM3 = NUMX(I1:8)
      WRITE (NUMX, '(I8)') LSM + 4
      I1 = NBLK (1, 8, NUMX)
      N4 = 9 - I1
      NUM4 = NUMX(I1:8)
C
C   If this is the main program, make sure that at least one MPR temporary
C   is defined.
C
      IF (ISTP .EQ. 1) THEN
        NAM = 'MPM1'
        IX = ITAB (2, 9, NAM)
      ENDIF
C
C   Insert declarations variables that do not yet have valid declarations.
C   These include, for example, the temporaries generated by GETMP.
C
      DO 100 I = MINT + 1, NVAR
        KDM = KDIM(I)
        KTP = KTYP(I)
        LV = LVAR(I)
        NAM = VAR(I)
        IF (KDEC(I) .EQ. 0) THEN
          IF (KTP .EQ. 1) THEN
            WRITE (6, 1) NAM(1:LV)
 1          FORMAT (6X,'INTEGER ',A)
          ELSEIF (KTP .EQ. 2) THEN
            WRITE (6, 2) NAM(1:LV)
 2          FORMAT (6X,'REAL ',A)
          ELSEIF (KTP .EQ. 3) THEN
            WRITE (6, 3) NAM(1:LV)
 3          FORMAT (6X,'DOUBLE PRECISION ',A)
          ELSEIF (KTP .EQ. 4) THEN
            WRITE (6, 4) NAM(1:LV)
 4          FORMAT (6X,'COMPLEX ',A)
          ELSEIF (KTP .EQ. 5) THEN
            WRITE (6, 5) NAM(1:LV)
 5          FORMAT (6X,'DOUBLE COMPLEX ',A)
          ELSEIF (KTP .EQ. 6) THEN
            WRITE (6, 6) NAM(1:LV), NUM3(1:N3)
 6          FORMAT (6X,'CHARACTER*1 ',A,'(',A,')')
          ELSEIF (KTP .EQ. 7) THEN
            WRITE (6, 7) NAM(1:LV)
 7          FORMAT (6X, 'LOGICAL ',A)
C
C   For MP dimensioned variables, only declare the type as real.
C
          ELSEIF (KDM .GT. 0) THEN
            WRITE (6, 8) NAM(1:LV)
 8          FORMAT (6X,'REAL ',A)
C
C   For MP scalar variables, declare as real with the appropriate dimension.
C
          ELSEIF (KTP .EQ. 8 .OR. KTP .EQ. 9) THEN
            WRITE (6, 9) NAM(1:LV), NUM1(1:N1)
 9          FORMAT (6X,'REAL ',A,'(',A,')')
          ELSEIF (KTP .EQ. 10) THEN
            WRITE (6, 9) NAM(1:LV), NUM2(1:N2)
          ELSEIF (KTP .EQ. 11) THEN
            WRITE (6, 10) NUM4(1:N4), NAM(1:LV)
 10         FORMAT (6X,'CHARACTER*',A,' ',A)
          ENDIF
        ENDIF
C
C   If the variable is a parameter, save it.
C
        IF (KDM .EQ. -3) WRITE (6, 11) NAM(1:LV)
 11     FORMAT (6X,'SAVE ',A)
 100  CONTINUE
C
C   Insert declarations for MPNWQ, MPNW4, MPL02, MPL10 and MPPIC if any is
C   required in this subprogram.
C
      IF (ISTP .EQ. 1 .OR. KCON(1) .NE. 0 .OR. KCON(3) .NE. 0 .OR.      
     $  KCON(4) .NE. 0 .OR. KCON(5) .NE. 0)                             
     $  WRITE (6, 12) (NUM1(1:N1), I = 1, 3)
 12   FORMAT (6X,'INTEGER MPNWQ, MPNW4'/6X,'REAL MPL02, MPL10, MPPIC'/  
     $  6X,'COMMON /MPTCON/ MPNWQ, MPNW4, MPL02(',A,'), MPL10(',A,      
     $  '), MPPIC(',A,')')
C
C   Insert declaration for MPEPS if it is required.
C
      IF (KCON(2) .NE. 0) WRITE (6, 13)
 13   FORMAT (6X,'REAL MPEPS(8)')
C
C   If the scratch space directive is in effect, insert allocation.
C
      IF (ISTP .EQ. 1 .AND. MSS .NE. 0) WRITE (6, 14) MSS
 14   FORMAT (6X,'REAL MPSS'/6X,'COMMON /MPCOM3/ MPSS(',I8,')')
C
C   If the precision level is very high, insert allocation for DP scratch.
C
      IF (MXP .GE. 1016) WRITE (6, 15) MXP + 8
 15   FORMAT (6X,'DOUBLE PRECISION MPDS'/                               
     $  6X,'COMMON /MPMCOM4/ MPDS(',I8,')')
C
C   If any MP parameters have been defined, define a flag.
C
      IF (MPA .GT. 0) WRITE (6, 16)
 16   FORMAT (6X,'INTEGER MPPAR'/6X,'SAVE MPPAR'/6X,'DATA MPPAR /0/')
C
C   This is the end of the declaration section.
C
      WRITE (6, 17)
 17   FORMAT ('C')
C
C   Check if this is the main program.
C
      IF (ISTP .EQ. 1) THEN
C
C   Insert calls to set the precision level and scratch space.
C
        WRITE (6, 18) MXP
 18     FORMAT (6X,'CALL MPSETP (''NW'', ',I6,')')
        IF (MSS .NE. 0) WRITE (6, 19) MSS
 19     FORMAT (6X,'CALL MPSETP (''IMS'', ',I8,')')
C
C   Insert code to compute MPNWQ, MPNW4, MPL02, MPL10 and MPPIC.
C
        WRITE (6, 20) MXP, MXP + 4
 20     FORMAT (                                                        
     $    6X,'MPNWQ = ',I6/                                             
     $    6X,'MPNW4 = ',I6/                                             
     $    6X,'CALL MPDMC (2.D0, 0, MPM1)'/                              
     $    6X,'CALL MPLOG (MPM1, MPL02, MPL02)'/                         
     $    6X,'CALL MPDMC (10.D0, 0, MPM1)'/                             
     $    6X,'CALL MPLOG (MPM1, MPL02, MPL10)'/                         
     $    6X,'CALL MPPI (MPPIC)')
      ENDIF
C
C   Set value for MPEPS if required.
C
C   SGI f77 4.0 miscompiles this line.  The next (equivalent) line is OK.
C       IF (KCON(2) .NE. 0) WRITE (6, 21) (EPS(I)(1:LEP(I)), I = 1, 2)
C
      IF (KCON(2) .NE. 0) WRITE (6, 21) EPS(1)(1:LEP(1)),               
     $    EPS(2)(1:LEP(2))
 21   FORMAT (6X,'CALL MPDMC (',A,', ',A,', MPEPS)')
C
C   If MP parameters have been defined, insert code here.
C
      IF (MPA .GT. 0) THEN
        WRITE (6, 22)
 22     FORMAT (6X,'IF (MPPAR .EQ. 0) THEN')
C
 110    READ (12, '(A)', END = 120) LIN
        L1 = LNBLK (LIN)
        WRITE (6, '(A)') LIN(1:L1)
        GOTO 110
C
 120    WRITE (6, 23)
 23     FORMAT (6X,'MPPAR = 1'/6X,'ENDIF')
      ENDIF
C
      WRITE (6, 24)
 24   FORMAT ('CMP<')
C
      RETURN
      END
C
      SUBROUTINE INTRIN (LU, ITP1, L1, ARG1, NAR, ITAR, LAR, ARG, ITPX, 
     $  LX, ARGX)
C
C   This generates code for MP intrinsic functions.  The function name is ARG1,
C   with type ITP1 and length L1.  NAR is the number of arguments.  The
C   argument list is input in ARG, with types in ITAR and lengths in LAR.
C   The result is placed in ARGX, with type in ITPX and length in LX.
C   LU is the unit number for output code.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*80 ARG1, ARG(MAR), ARGX, ARGZ
      CHARACTER*16 NAM
      DIMENSION ITAR(MAR), LAR(MAR)
      CHARACTER*4 GETMP, TMP1, TMP2, TMP3, TMP4, TMP5
C*
C      write (lu, *) 'enter intrin, nar, arg1 =', nar,
C     $  ' %'//arg1(1:l1)//'%'
C      write (lu, '(2i4,2x,a)') (i, itar(i), arg(i)(1:lar(i)), i = 1, nar)
C*
      LL = MIN (L1, 16)
      NAM = ARG1(1:LL)
      IX = ITAB (0, 0, NAM)
      KTP = KTYP(IX)
C
C   For functions with an argument-dependent result type, the type of the
C   result is the type of the first argument, except for ABS with a MPC
C   argument and NINT.
C
      IF (KTP .NE. -1) THEN
        ITPX = KTP
      ELSEIF (IX .EQ. 11 .AND. ITAR(1) .EQ. 10) THEN
        ITPX = 9
      ELSEIF (IX .EQ. 39) THEN
        ITPX = 8
      ELSE
        ITPX = ITAR(1)
      ENDIF
      LX = 4
      ARGX = GETMP (ITPX)
C
      GOTO (                                                            
     $  100, 110, 120, 440, 130, 140, 150, 160, 450, 170,               
     $  180, 190, 200, 210, 220, 440, 450, 450, 230, 450,               
     $  450, 240, 450, 250, 260, 270, 280, 290, 300, 310,               
     $  320, 330, 340, 350, 360, 370, 380, 390, 400, 410,               
     $   420, 430, 460, 460) IX - 10
C
C   It is ABS.
C
 100  IF (NAR .NE. 1) GOTO 450
      LA1 = LAR(1)
      IF (ITAR(1) .NE. 10) THEN
        WRITE (LU, 1) ARG(1)(1:LA1), ARGX(1:4)
 1      FORMAT (6X,'CALL MPEQ (',A,', ',A,')')
        WRITE (LU, 2) ARGX(1:4), ARGX(1:4)
 2      FORMAT (6X,A,'(1) = ABS (',A,'(1))')
      ELSE
        TMP1 = GETMP (9)
        TMP2 = GETMP (9)
        TMP3 = GETMP (9)
        TMP4 = GETMP (9)
        WRITE (LU, 3) ARG(1)(1:LA1), TMP1, TMP2
 3      FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')')
        WRITE (LU, 4) TMP1, TMP1, TMP3
 4      FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,')')
        WRITE (LU, 4) TMP2, TMP2, TMP4
        WRITE (LU, 5) TMP3, TMP4, TMP1
 5      FORMAT (6X,'CALL MPADD (',A,', ',A,', ',A,')')
        WRITE (LU, 6) TMP1, ARGX(1:4)
 6      FORMAT (6X,'CALL MPSQRT (',A,', ',A,')')
        CALL RLTMP (TMP1)
        CALL RLTMP (TMP2)
        CALL RLTMP (TMP3)
        CALL RLTMP (TMP4)
      ENDIF
      GOTO 470
C
C   It is ACOS.
C
 110  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      TMP2 = GETMP (9)
      TMP3 = GETMP (9)
      WRITE (LU, 7) TMP1
 7    FORMAT (6X,'CALL MPDMC (1.D0, 0, ',A,')')
      WRITE (LU, 4) ARG(1)(1:LA1), ARG(1)(1:LA1), TMP2
      WRITE (LU, 8) TMP1, TMP2, TMP3
 8    FORMAT (6X,'CALL MPSUB (',A,', ',A,', ',A,')')
      WRITE (LU, 6) TMP3, TMP1
      WRITE (LU, 9) ARG(1)(1:LA1), TMP1, ARGX(1:4)
 9    FORMAT (6X,'CALL MPANG (',A,', ',A,', MPPIC, ',A,')')
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      CALL RLTMP (TMP3)
      GOTO 470
C
C   It is AINT.
C
 120  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 10) ARG(1)(1:LA1), ARGX(1:4), TMP1
 10   FORMAT (6X,'CALL MPINFR (',A,', ',A,', ',A,')')
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is ANINT.
C
 130  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      LA1 = LAR(1)
      WRITE (LU, 11) ARG(1)(1:LA1), ARGX(1:4)
 11   FORMAT (6X,'CALL MPNINT (',A,', ',A,')')
      GOTO 470
C
C   It is ASIN.
C
 140  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      TMP2 = GETMP (9)
      TMP3 = GETMP (9)
      WRITE (LU, 7) TMP1
      WRITE (LU, 4) ARG(1)(1:LA1), ARG(1)(1:LA1), TMP2
      WRITE (LU, 8) TMP1, TMP2, TMP3
      WRITE (LU, 6) TMP3, TMP1
      WRITE (LU, 9) TMP1, ARG(1)(1:LA1), ARGX(1:4)
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      CALL RLTMP (TMP3)
      GOTO 470
C
C   It is ATAN.
C
 150  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 7) TMP1
      WRITE (LU, 9) TMP1, ARG(1)(1:LA1), ARGX(1:4)
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is ATAN2.
C
 160  IF (NAR .NE. 2 .OR. ITAR(1) .NE. 9 .OR. ITAR(2) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      LA2 = LAR(2)
      WRITE (LU, 9) ARG(2)(1:LA2), ARG(1)(1:LA1), ARGX(1:4)
      GOTO 470
C
C   It is CMPLX (convert MPC to CO).
C
 170  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450
      WRITE (LU, 12)
 12   FORMAT ('CMP*'/'CMP*  Note: The result of CMPLX with an MP',      
     $  ' argument has type CO.'/'CMP*  If an MPC result is',           
     $  ' required, use DPCMPL or an assignment statement.'/'CMP*')
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      TMP2 = GETMP (9)
      TMP3 = GETMP (3)
      TMP4 = GETMP (3)
      TMP5 = GETMP (1)
      WRITE (LU, 3) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 13) TMP1, TMP3, TMP5
 13   FORMAT (6X,'CALL MPMDC (',A,', ',A,', ',A,')')
      WRITE (LU, 14) TMP3, TMP3, TMP5
 14   FORMAT (6X,A,' = ',A,' * 2.D0 ** ',A)
      WRITE (LU, 13) TMP2, TMP4, TMP5
      WRITE (LU, 14) TMP4, TMP4, TMP5
      WRITE (LU, 15) ARGX(1:4), TMP3, TMP4
 15   FORMAT (6X,A,' = DCMPLX (',A,', ',A,')')
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      CALL RLTMP (TMP3)
      CALL RLTMP (TMP4)
      CALL RLTMP (TMP5)
      GOTO 470
C
C   It is CONJG.
C
 180  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450
      LA1 = LAR(1)
      WRITE (LU, 16) ARG(1)(1:LA1), ARGX(1:4)
 16   FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')')
      WRITE (LU, 17) ARGX(1:4), ARGX(1:4)
 17   FORMAT (6X,A,'(MPNWQ+5) = - ',A,'(MPNWQ+5)')
      GOTO 470
C
C   It is COS.
C
 190  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 18) ARG(1)(1:LA1), ARGX(1:4), TMP1
 18   FORMAT (6X,'CALL MPCSSN (',A,', MPPIC, ',A,', ',A,')')
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is COSH.
C
 200  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(3) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 19) ARG(1)(1:LA1), ARGX(1:4), TMP1
 19   FORMAT (6X,'CALL MPCSSH (',A,', MPL02, ',A,', ',A,')')
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is DBLE (convert MPI or MPR to DP).
C
 210  IF (NAR .NE. 1) GOTO 450
      WRITE (LU, 20)
 20   FORMAT ('CMP*'/'CMP*  Note: The result of DBLE with an MP',       
     $  ' argument has type DP.'/'CMP*  If an MPR result is',           
     $  ' required, use DPREAL or an assignment statement.'/'CMP*')
      LA1 = LAR(1)
      TMP1 = GETMP (3)
      TMP2 = GETMP (1)
      WRITE (LU, 13) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 14) ARGX(1:4), TMP1, TMP2
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      GOTO 470
C
C   It is DCMPLX (convert MPC to DC).
C
 220  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450
      WRITE (LU, 21)
 21   FORMAT ('CMP*'/'CMP*  Note: The result of DCMPLX with an MP',     
     $  ' argument has type DC.'/'CMP*  If an MPC result is',           
     $  ' required, use DPCMPL or an assignment statement.'/'CMP*')
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      TMP2 = GETMP (9)
      TMP3 = GETMP (3)
      TMP4 = GETMP (3)
      TMP5 = GETMP (1)
      WRITE (LU, 3) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 13) TMP1, TMP3, TMP5
      WRITE (LU, 14) TMP3, TMP3, TMP5
      WRITE (LU, 13) TMP2, TMP4, TMP5
      WRITE (LU, 14) TMP4, TMP4, TMP5
      WRITE (LU, 15) ARGX(1:4), TMP3, TMP4
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      CALL RLTMP (TMP3)
      CALL RLTMP (TMP4)
      CALL RLTMP (TMP5)
      GOTO 470
C
C   It is EXP.
C
 230  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(3) = 1
      LA1 = LAR(1)
      WRITE (LU, 22) ARG(1)(1:LA1), ARGX(1:4)
 22   FORMAT (6X,'CALL MPEXP (',A,', MPL02, ',A,')')
      GOTO 470
C
C   It is INT (convert MPI or MPR to IN).
C
 240  IF (NAR .NE. 1) GOTO 450
      WRITE (LU, 23)
 23   FORMAT ('CMP*'/'CMP*  Note: The result of INT with an MP',        
     $  ' argument has type IN.'/'CMP*  If an MPI result is',           
     $  ' required, use MPINT or an assignment statement.'/'CMP*')
      LA1 = LAR(1)
      TMP1 = GETMP (3)
      TMP2 = GETMP (1)
      WRITE (LU, 13) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 14) ARGX(1:4), TMP1, TMP2
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      GOTO 470
C
C   It is LOG.
C
 250  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(3) = 1
      LA1 = LAR(1)
      WRITE (LU, 24) ARG(1)(1:LA1), ARGX(1:4)
 24   FORMAT (6X,'CALL MPLOG (',A,', MPL02, ',A,')')
      GOTO 470
C
C   It is LOG10.
C
 260  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(4) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 24) ARG(1)(1:LA1), TMP1
      WRITE (LU, 25) TMP1, 'MPL10', ARGX(1:4)
 25   FORMAT (6X,'CALL MPDIV (',A,', ',A,', ',A,')')
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is MAX.
C
 270  IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10)    
     $  GOTO 450
      LA1 = LAR(1)
      LA2 = LAR(2)
      TMP1 = GETMP (1)
      WRITE (LU, 26) ARG(1)(1:LA1), ARG(2)(1:LA2), TMP1
 26   FORMAT (6X,'CALL MPCPR (',A,', ',A,', ',A,')')
      WRITE (LU, 27) TMP1, ARG(1)(1:LA1), ARGX(1:4), ARG(2)(1:LA2),     
     $  ARGX(1:4)
 27   FORMAT (6X,'IF (',A,' .GE. 0) THEN'/                              
     $  8X,'CALL MPEQ (',A,', ',A,')'/6X,'ELSE'/                        
     $  8X,'CALL MPEQ (',A,', ',A,')'/6X,'ENDIF')
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is MIN.
C
 280  IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10)    
     $  GOTO 450
      LA1 = LAR(1)
      LA2 = LAR(2)
      TMP1 = GETMP (1)
      WRITE (LU, 26) ARG(1)(1:LA1), ARG(2)(1:LA2), TMP1
      WRITE (LU, 27) TMP1, ARG(2)(1:LA2), ARGX(1:4), ARG(1)(1:LA1),     
     $  ARGX(1:4)
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is MOD.
C
 290  IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10)    
     $  GOTO 450
      LA1 = LAR(1)
      LA2 = LAR(2)
      TMP1 = GETMP (9)
      TMP2 = GETMP (8)
      TMP3 = GETMP (9)
      WRITE (LU, 25) ARG(1)(1:LA1), ARG(2)(1:LA2), TMP1
      WRITE (LU, 10) TMP1, TMP2, TMP3
      WRITE (LU, 4) ARG(2)(1:LA2), TMP2, TMP1
      WRITE (LU, 8) ARG(1)(1:LA1), TMP1, ARGX(1:4)
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      CALL RLTMP (TMP3)
      GOTO 470
C
C   It is NINT.
C
 300  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      LA1 = LAR(1)
      WRITE (LU, 11) ARG(1)(1:LA1), ARGX(1:4)
      GOTO 470
C
C   It is REAL (convert MPI or MPR to SP).
C
 310  IF (NAR .NE. 1) GOTO 450
      WRITE (LU, 28)
 28   FORMAT ('CMP*'/'CMP*  Note: The result of REAL with an MP',       
     $  ' argument has type SP.'/'CMP*  If an MPR result is',           
     $  ' required, use DPREAL or an assignment statement.'/'CMP*')
      LA1 = LAR(1)
      TMP1 = GETMP (3)
      TMP2 = GETMP (1)
      WRITE (LU, 13) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 14) ARGX(1:4), TMP1, TMP2
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      GOTO 470
C
C   It is SIGN.
C
 320  IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10)    
     $  GOTO 450
      LA1 = LAR(1)
      LA2 = LAR(2)
      TMP1 = GETMP (9)
      WRITE (LU, 1) ARG(1)(1:LA1), ARGX(1:4)
      WRITE (LU, 1) ARG(2)(1:LA2), TMP1
      WRITE (LU, 29) TMP1, ARGX(1:4), ARGX(1:4), ARGX(1:4), ARGX(1:4)
 29   FORMAT (6X,'IF (',A,'(1) .GE. 0.) THEN'/                          
     $  6X,A,'(1) = ABS (',A,'(1))'/6X,'ELSE'/                          
     $  6X,A,'(1) = - ABS (',A,'(1))'/6X,'ENDIF')
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is SIN.
C
 330  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 18) ARG(1)(1:LA1), TMP1, ARGX(1:4)
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is SINH.
C
 340  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(3) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 19) ARG(1)(1:LA1), TMP1, ARGX(1:4)
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is SQRT.
C
 350  IF (NAR .NE. 1 .OR. ITAR(1) .EQ. 8) GOTO 450
      LA1 = LAR(1)
      IF (ITAR(1) .EQ. 9) THEN
        WRITE (LU, 6) ARG(1)(1:LA1), ARGX(1:4)
      ELSEIF (ITAR(1) .EQ. 10) THEN
        WRITE (LU, 30) ARG(1)(1:LA1), ARGX(1:4)
 30     FORMAT (6X,'CALL MPCSQR (MPNW4, ',A,', ',A,')')
      ENDIF
      GOTO 470
C
C   It is TAN.
C
 360  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(5) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      TMP2 = GETMP (9)
      WRITE (LU, 18) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 25) TMP2, TMP1, ARGX(1:4)
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      GOTO 470
C
C   It is TANH.
C
 370  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      KCON(3) = 1
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      TMP2 = GETMP (9)
      WRITE (LU, 19) ARG(1)(1:LA1), TMP1, TMP2
      WRITE (LU, 25) TMP2, TMP1, ARGX(1:4)
      CALL RLTMP (TMP1)
      CALL RLTMP (TMP2)
      GOTO 470
C
C   It is MPINT.
C
 380  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 10) ARG(1)(1:LA1), ARGX(1:4), TMP1
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is DPCMPL.
C
 390  IF (NAR .NE. 2 .OR. ITAR(1) .NE. 9 .OR. ITAR(2) .NE. 9) GOTO 450
      LA1 = LAR(1)
      LA2 = LAR(2)
      WRITE (LU, 31) ARG(1)(1:LA1), ARG(2)(1:LA2), ARGX(1:4)
 31   FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
      GOTO 470
C
C   It is DPIMAG.
C
 400  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450
      LA1 = LAR(1)
      TMP1 = GETMP (9)
      WRITE (LU, 3) ARG(1)(1:LA1), TMP1, ARGX(1:4)
      CALL RLTMP (TMP1)
      GOTO 470
C
C   It is DPREAL.
C
 410  IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450
      LA1 = LAR(1)
      WRITE (LU, 1) ARG(1)(1:LA1), ARGX(1:4)
      GOTO 470
C
C   It is DPNRT.
C
 420  IF (NAR .NE. 2 .OR. ITAR(1) .NE. 9 .OR. ITAR(2) .NE. 1) GOTO 450
      LA1 = LAR(1)
      LA2 = LAR(2)
      WRITE (LU, 32) ARG(1)(1:LA1), ARG(2)(1:LA2), ARGX(1:4)
 32   FORMAT (6X,'CALL MPNRT (',A,', ',A,', ',A,')')
      GOTO 470
C
C   It is DPRAND.
C
 430  IF (NAR .NE. 0) GOTO 450
      WRITE (LU, 33) ARGX(1:4)
 33   FORMAT (6X,'CALL MPRAND (',A,')')
      GOTO 470
C
 440  CALL ERRMES (64, 0)
      WRITE (6, 34) ARG1(1:L1)
 34   FORMAT ('This intrinsic function is not defined with this MP',    
     $  ' argument type: ',A)
      CALL ABRT
C
 450  CALL ERRMES (65, 0)
      WRITE (6, 35) ARG1(1:L1)
 35   FORMAT ('This intrinsic function has an improper argument list: ',
     $  A)
      CALL ABRT
C
 460  CALL ERRMES (66, 0)
      WRITE (6, 36) ARG1(1:L1)
 36   FORMAT ('This subroutine name may not be used as a function: ',A)
      CALL ABRT
C
 470  CONTINUE
C*
C      write (lu, *) 'exit intrin  itpx, argx =', itpx,
C     $  ' %'//argx(1:lx)//'%'
C*
      RETURN
      END
C
      FUNCTION IPFSB (K1, LN)
C
C   This checks to see if the statement is a program, subroutine, function
C   or block data statement. K1 and LN are the indices of the first and last
C   non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*16 LINQ, NAM, UCASE
C
      J1 = K1
      LQ = MIN (J1 + 15, LN)
      LINQ = UCASE (LINE(J1:LQ))
      IF (LINQ(1:7) .EQ. 'PROGRAM') THEN
        IF (IEX .NE. 0) GOTO 100
        ISTP = 1
        IPFSB = 1
        J1 = NBLK (J1 + 7, LN, LINE)
        FNAM = LINE(J1:LN)
        LSAR = 0
        CALL OUTLIN (1, LN, LINE)
      ELSEIF (LINQ(1:10) .EQ. 'SUBROUTINE') THEN
        IF (IEX .NE. 0) GOTO 100
        ISTP = 2
        IPFSB = 1
        J1 = NBLK (J1 + 10, LN, LINE)
        J3 = INDX (J1, LN, '(', LINE)
        IF (J3 .NE. 0) THEN
          J2 = J3 - 1
        ELSE
          J2 = LN
        ENDIF
        FNAM = LINE(J1:J2)
        IF (J3 .NE. 0) THEN
          LSAR = LN - J3 - 1
          SARG(1:LSAR) = LINE(J3+1:LN-1)
        ELSE
          LSAR = 0
          SARG(1:1) = ' '
        ENDIF
        CALL OUTLIN (1, LN, LINE)
      ELSEIF (LINQ(1:8) .EQ. 'FUNCTION') THEN
        IF (IEX .NE. 0) GOTO 100
        ISTP = 3
        JS = J1
        J1 = NBLK (J1 + 8, LN, LINE)
        J3 = INDX (J1, LN, '(', LINE)
        IF (J3 .EQ. 0) CALL ERRMES (67, 1)
        J2 = J3 - 1
        FNAM = LINE(J1:J2)
        IX = ITAB (0, 0, FNAM)
        LSAR = LN - J3 - 1
        SARG(1:LSAR) = LINE(J3+1:LN-1)
C
C   If the function name is MP, then change to subroutine statement.
C
        IF (IX .GT. MINT .AND. KTYP(IX) .GE. 8) THEN
          KDIM(IX) = -2
          CALL OUTLIN (2, LN, LINE)
          LINA(1:JS-1) = LINE(1:JS-1)
          LINA(JS:JS+9) = 'SUBROUTINE'
          LINA(JS+10:LN+1) = LINE(JS+8:LN-1)
          LINA(LN+2:LN+9) = ', MPFVX)'
          NAM = 'MPFVX'
          IX = ITAB (2, KTYP(IX), NAM)
          LA = LN + 9
          CALL OUTLIN (1, LA, LINA)
          WRITE (11, 1)
 1        FORMAT ('CMP<')
        ELSE
          CALL OUTLIN (1, LN, LINE)
        ENDIF
        IPFSB = 1
      ELSEIF (LINQ(1:10) .EQ. 'BLOCK DATA') THEN
        IF (IEX .NE. 0) GOTO 100
        ISTP = 4
        IPFSB = 1
        CALL OUTLIN (1, LN, LINE)
      ELSE
        IPFSB = 0
      ENDIF
      GOTO 120
C
 100  CALL ERRMES (68, 0)
      WRITE (6, 2)
 2    FORMAT ('A declarative statement may not appear after an',        
     $  ' executable statement.')
      CALL ABRT
C
 110  CALL ERRMES (69, 0)
      WRITE (6, 3)
 3    FORMAT ('Too many program units in this file.')
      CALL ABRT
C
 120  RETURN
      END
C
      FUNCTION ISCAN (K1, LN, LINA)
C
C   This scans LINE between positions K1 and LN for variable names and
C   enters new ones into the table.  The result is 1 if a MP constant or
C   special constant name is found, 2 if a MP variable is found, and 0
C   otherwise.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*16 NAM
      CHARACTER*1 CJ
C
      J1 = K1
      ISCAN = 0
C
C   Extract the next character from the line.
C
 100  IF (J1 .GT. LN) GOTO 130
      J1 = NBLK (J1, LN, LINA)
      CJ = LINA(J1:J1)
C
C   Check if it is the start of a numeric constant.
C
      IS1 = INDEX (DIG, CJ)
      IF ((CJ .EQ. '-' .OR. CJ .EQ. '.') .AND. J1 .LT. LN) THEN
        J2 = NBLK (J1 + 1, LN, LINA)
        IS2 = INDEX (DIG, LINA(J2:J2))
      ELSE
        IS2 = 0
      ENDIF
C
      IF (IS1 .NE. 0 .OR. IS2 .NE. 0) THEN
        ITP = NUMCON (J1, J2, LN, LINA)
        J1 = J2 + 1
        GOTO 100
C
C   Check if it the start of a name.
C
      ELSEIF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN
C
        DO 110 J = J1, LN
          CJ = LINA(J:J)
          IF (INDEX (DEL, CJ) .NE. 0) GOTO 120
 110    CONTINUE
C
        J = LN + 1
 120    I2 = J - 1
        NAM = LINA(J1:I2)
        IX = ITAB (1, 0, NAM)
        IF (IX .EQ. 0) THEN
          J1 = I2 + 1
          GOTO 100
        ENDIF
        ITP = KTYP(IX)
        IF (ITP .LT. 8) KDEC(IX) = 1
C
C   Check if the variable is a special constant.
C
        IF (IX .GE. 1 .AND. IX .LE. 5) THEN
          ISCAN = MAX (ISCAN, 1)
C
C   Check if the variable is MP.
C
        ELSEIF (ITP .GE. 8) THEN
          ISCAN = 2
        ENDIF
        J1 = I2 + 1
        GOTO 100
C
C   Check if it is the start of a logical constant.
C
      ELSEIF (CJ .EQ. '.') THEN
        I1 = INDX (J1 + 1, LN, '.', LINA)
        IF (I1 .EQ. 0) CALL ERRMES (70, 1)
        J1 = I1 + 1
        GOTO 100
C
C   Check if it is the start of a character constant.
C
      ELSEIF (CJ .EQ. '"') THEN
        I1 = INDX (J1 + 1, LN, '"', LINA)
        IF (I1 .EQ. 0) CALL ERRMES (71, 1)
        J1 = I1 + 1
        GOTO 100
      ELSEIF (CJ .EQ. "'") THEN
        I1 = INDX (J1 + 1, LN, "'", LINA)
        IF (I1 .EQ. 0) CALL ERRMES (72, 1)
        J1 = I1 + 1
        GOTO 100
      ENDIF
C
C   Check if it is one of the miscellaneous symbols.
C
      I1 = INDEX (DEL, CJ)
      IF (I1 .EQ. 0) THEN
        CALL ERRMES (73, 0)
        WRITE (6, 1) CJ
 1      FORMAT ('Illegal character: ',A)
        CALL ABRT
      ENDIF
      J1 = J1 + 1
      GOTO 100
C
 130  CONTINUE
      RETURN
      END
C
      FUNCTION ITAB (IC, ITP, NAM)
C
C   This routine searches for NAM in the variable table and returns its index
C   if found.  If it is not found, the action depends on the value of IC as
C   follows:
C     IC
C     0   Name is not entered in table and zero is returned.
C     1   New names are entered in table.  Four letter names starting with DP
C         or MP are NOT allowed.  The entry in KTYP is set to ITP if ITP is
C         nonzero, otherwise to the implicit type.
C     2   New names are entered in table.  Four letter names starting with DP
C         or MP are allowed.  The entry in KTYP is set to ITP if ITP is
C         nonzero, otherwise to the implicit type.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*16 NAM, NAMX, UCASE
      CHARACTER*1 CJ
C
C   Set NAMX = NAM with upper case alphabetics and check table.
C
      NAMX = UCASE (NAM)
C
      DO 100 I = 1, NVAR
        IF (VAR(I) .EQ. NAMX) THEN
          ITAB = I
          GOTO 120
        ENDIF
 100  CONTINUE
C
C   NAMX is not in table.
C
      IF (IC .EQ. 0) THEN
        ITAB = 0
        GOTO 120
      ENDIF
C
C   Check if NAMX is a common Fortran keyword -- if so, don't enter in table.
C
      DO 110 I = 1, NKY
        IF (NAMX .EQ. KEYW(I)) THEN
          ITAB = 0
          GOTO 120
        ENDIF
 110  CONTINUE
C
C   Check if it is a four-letter name starting with DP or MP.
C
      L1 = LNBLK (NAMX)
      IF (IC .EQ. 1 .AND. L1 .EQ. 4) THEN
        IF (NAMX(1:2) .EQ. 'DP' .OR. NAMX(1:2) .EQ. 'MP') THEN
          CALL ERRMES (74, 0)
          WRITE (6, 1)
 1        FORMAT ('Four-letter names starting with DP or MP are not',   
     $      ' allowed.')
          CALL ABRT
        ENDIF
      ENDIF
C
C   Add NAMX to table.
C
      NVAR = NVAR + 1
      IF (NVAR .GT. MVAR) THEN
        CALL ERRMES (75, 0)
        WRITE (6, 2)
 2      FORMAT ('Subprogram has too many variables.')
        CALL ABRT
      ENDIF
C
      VAR(NVAR) = NAMX
      KDEC(NVAR) = 0
      KDIM(NVAR) = 0
      LVAR(NVAR) = L1
C
C   If ITP is greater than zero, set the type of the new variable to ITP.
C   If ITP is zero, set the type to the implicit type.  The type is stored
C   in the array KTYP.  Whether explicit or implicit is stored in MPLC.
C
      IF (ITP .GT. 0) THEN
        KTYP(NVAR) = ITP
        MPLC(NVAR) = 0
      ELSE
        CJ = NAMX(1:1)
        I1 = INDEX (ALPU, CJ)
        IF (I1 .EQ. 0) CALL ERRMES (76, 1)
        KTYP(NVAR) = IMPL(I1)
        MPLC(NVAR) = 1
      ENDIF
      ITAB = NVAR
C
 120  RETURN
      END
C
      FUNCTION LNBLK (LIN)
      CHARACTER*(*) LIN
C
C   This finds the index of the last non-blank character in LIN.
C
      LN = LEN (LIN)
C
      DO 100 I = LN, 1, -1
        IF (LIN(I:I) .NE. ' ') GOTO 110
 100  CONTINUE
C
      I = 0
 110  LNBLK = I
C
      RETURN
      END
C
      FUNCTION MATCH (IC, K1, LA, LINA)
C
C   This finds the location (up to LA) in LINA of the right parenthesis that
C   matches the left parenthesis at location K1 - 1.  If IC is nonzero, a comma
C   will also will be accepted as a terminator.  Parentheses or commas in
C   character constants are ignored.
C
      CHARACTER*1600 LINA
      CHARACTER*1 CJ
C
      J1 = K1
      IP = 0
      MATCH = 0
C
 100  IF (J1 .GT. LA) GOTO 110
      J1 = NBLK (J1, LA, LINA)
      IF (J1 .EQ. 0) GOTO 110
      CJ = LINA(J1:J1)
      IF (CJ .EQ. ')' .OR. (CJ .EQ. ',' .AND. IC .NE. 0 .AND.           
     $  IP .EQ. 0)) THEN
        IF (IP .EQ. 0) THEN
          MATCH = J1
          GOTO 110
        ELSE
          IP = IP - 1
          J1 = J1 + 1
          GOTO 100
        ENDIF
      ELSEIF (CJ .EQ. '(') THEN
        IP = IP + 1
        J1 = J1 + 1
        GOTO 100
      ELSEIF (CJ .EQ. '"') THEN
        J1 = INDX (J1 + 1, LA, '"', LINA)
        IF (J1 .EQ. 0) CALL ERRMES (77, 1)
        J1 = J1 + 1
        GOTO 100
      ELSEIF (CJ .EQ. "'") THEN
        J1 = INDX (J1 + 1, LA, "'", LINA)
        IF (J1 .EQ. 0) CALL ERRMES (78, 1)
        J1 = J1 + 1
        GOTO 100
      ELSE
        J1 = J1 + 1
        GOTO 100
      ENDIF
C
 110  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE MPDEC (LN)
C
C   This checks to see if a comment is a MP directive.  LN is the index of
C   the last non-blank character.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
C>   Set CON to be the Log_10 BDX, where BDX is the radix in MPFUN.
C    For IEEE and other systems for which BDX = 2^24, CON = 7.224719896D0.
C    For Cray systems and others for which BDX = 2^22, CON = 6.622659905D0.
C
      DOUBLE PRECISION CON, CL2, T1
      PARAMETER (CON = 7.224719896D0, RLT = 3.321928095D0)
      CHARACTER*16 LINQ, NUMX, NUMY, UCASE
C
      J1 = NBLK (5, LN, LINE)
C
      LQ = MIN (J1 + 15, LN)
      LINQ = UCASE (LINE(J1:LQ))
      IF (LINQ(1:15) .EQ. 'PRECISION LEVEL') THEN
        IF (MXP .NE. 0 .OR. ISTP .NE. 0) GOTO 110
        IF (IEX .NE. 0) GOTO 140
        NUMX = LINE(J1+15:LN)
        READ (NUMX, '(BN,I16)', ERR = 120) K
        IF (K .LE. 0) GOTO 120
        MXP = (K + 7) / CON
        MPP = CON * MXP
        T1 = RLT * (7 - K)
        N1 = T1 - 1.D0
        T1 = 2.D0 ** (T1 - N1)
        WRITE (NUMY, '(1PD16.8)') T1
        I1 = NBLK (1, 16, NUMY)
        LEP(1) = 17 - I1
        EPS(1) = NUMY(I1:16)
        WRITE (NUMY, '(I10)') N1
        I1 = NBLK (1, 10, NUMY)
        LEP(2) = 11 - I1
        EPS(2) = NUMY(I1:10)
      ELSEIF (LINQ(1:13) .EQ. 'SCRATCH SPACE') THEN
        IF (MXP .EQ. 0) GOTO 100
        IF (MSS .NE. 0 .OR. ISTP .NE. 0) GOTO 110
        IF (IEX .NE. 0) GOTO 140
        NUMX = LINE(J1+13:LN)
        READ (NUMX , '(BN,I16)', ERR = 120) K
        IF (K .LE. 0) GOTO 120
        MSS = K
      ELSEIF (LINQ(1:8) .EQ. 'IMPLICIT') THEN
        IF (MXP .EQ. 0) GOTO 100
        IF (ISTP .EQ. 0) GOTO 110
        IF (IEX .NE. 0) GOTO 140
        K1 = NBLK (J1 + 8, LN, LINE)
        CALL IMPLIC (K1, LN)
        MPT = 1
      ELSEIF (LINQ(1:10) .EQ. 'TYPE ERROR') THEN
        IF (MXP .EQ. 0) GOTO 100
        IF (IEX .NE. 0) GOTO 140
        J1 = NBLK (J1 + 10, LN, LINE)
        LQ = MIN (J1 + 15, LN)
        LINQ = UCASE (LINE(J1:LQ))
        IF (LINQ(1:2) .EQ. 'ON') THEN
          ITE = 1
        ELSEIF (LINQ(1:3) .EQ. 'OFF') THEN
          ITE = 0
        ELSE
          CALL ERRMES (79, 0)
        ENDIF
      ELSEIF (LINQ(1:10) .EQ. 'MIXED MODE') THEN
        IF (MXP .EQ. 0) GOTO 100
        IF (IEX .NE. 0) GOTO 140
        J1 = NBLK (J1 + 10, LN, LINE)
        LQ = MIN (J1 + 15, LN)
        LINQ = UCASE (LINE(J1:LQ))
        IF (LINQ(1:4) .EQ. 'SAFE') THEN
          IMM = 1
        ELSEIF (LINQ(1:4) .EQ. 'FAST') THEN
          IMM = 0
        ELSE
          CALL ERRMES (80, 0)
        ENDIF
      ELSEIF (LINQ(1:16) .EQ. 'OUTPUT PRECISION') THEN
        IF (MXP .EQ. 0) GOTO 100
        IF (IEX .NE. 0) GOTO 140
        NUMX = LINE(J1+16:LN)
        READ (NUMX, '(BN,I16)', ERR = 120) K
        IF (K .LE. 0) GOTO 120
        MPP = K
      ELSEIF (LINQ(1:7) .EQ. 'EPSILON') THEN
        IF (MXP .EQ. 0) GOTO 100
        IF (IEX .NE. 0) GOTO 140
        K1 = NBLK (J1 + 7, LN, LINE)
        I1 = MAX (INDX (K1, LN, 'E', LINE), INDX (K1, LN, 'e', LINE))
        IF (I1 .EQ. 0) CALL ERRMES (81, 1)
        NUMX = LINE(K1:I1-1)
        READ (NUMX, '(F16.0)') T1
        NUMX = LINE(I1+1:LN)
        READ (NUMX, '(BN,I16)') N1
        IF (T1 .LE. 0 .OR. N1 .GE. 0) CALL ERRMES (82, 1)
        T1 = RLT * (N1 + LOG10 (T1))
        N1 = T1 - 1.D0
        T1 = 2.D0 ** (T1 - N1)
        WRITE (NUMY, '(1PD16.8)') T1
        I1 = NBLK (1, 16, NUMY)
        LEP(1) = 17 - I1
        EPS(1) = NUMY(I1:16)
        WRITE (NUMY, '(I10)') N1
        I1 = NBLK (1, 10, NUMY)
        LEP(2) = 11 - I1
        EPS(2) = NUMY(I1:10)
      ELSE
C
C   Check for MP type declarative.
C
        IT = NTYPE (J1, LN)
        IF (IT .GE. 8) THEN
          IF (MXP .EQ. 0) GOTO 100
          IF (IEX .NE. 0) GOTO 140
          CALL TYPE (IT, J1, LN)
          MPT = 1
          IF (IT .EQ. 10) KCON(1) = 1
        ELSE
          GOTO 130
        ENDIF
      ENDIF
      GOTO 150
C
 100  CALL ERRMES (83, 0)
      WRITE (6, 1)
 1    FORMAT ('Precision level has not yet been declared.')
      CALL ABRT
C
 110  CALL ERRMES (84, 0)
      WRITE (6, 2)
 2    FORMAT ('Improper placement of MP directive.')
      CALL ABRT
C
 120  CALL ERRMES (85, 0)
      WRITE (6, 3)
 3    FORMAT ('Improper integer constant.')
      CALL ABRT
C
 130  CALL ERRMES (86, 0)
      WRITE (6, 4)
 4    FORMAT ('Unrecognized CMP+ directive.')
      CALL ABRT
C
 140  CALL ERRMES (87, 0)
      WRITE (6, 5)
 5    FORMAT ('A declarative statement may not appear after an',        
     $  ' executable statement.')
      CALL ABRT
C
 150  RETURN
      END
C
      FUNCTION NBLK (K1, K2, LIN)
C
C   This finds the index of the first non-blank character in LIN between
C   positions K1 and K2.  LIN may be of any character type.
C
      CHARACTER*(*) LIN
C
      DO 100 I = K1, K2
        IF (LIN(I:I) .NE. ' ') GOTO 110
 100  CONTINUE
C
      I = 0
 110  NBLK = I
C
      RETURN
      END
C
      FUNCTION NTYPE (K1, K2)
C
C   Identifies type declarations in type statements or implicit statements
C   and repositions pointer one past end of declarative.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*16 LINQ, UCASE
C
      LQ = MIN (K1 + 15, K2)
      LINQ = UCASE (LINE(K1:LQ))
      IF (LINQ(1:7) .EQ. 'INTEGER') THEN
        NTYPE = 1
        K1 = NBLK (K1 + 7, K2, LINE)
        IF (LINE(K1:K1) .EQ. '*') K1 = 1 + NBLK (K1 + 1, K2, LINE)
      ELSEIF (LINQ(1:5) .EQ. 'REAL ' .OR. LINQ(1:5) .EQ. 'REAL*') THEN
        NTYPE = 2
        K1 = NBLK (K1 + 4, K2, LINE)
        IF (LINE(K1:K1) .EQ. '*') THEN
          K1 = NBLK (K1 + 1, K2, LINE)
          IF (LINE(K1:K1) .EQ. '8') NTYPE = 3
          K1 = K1 + 1
        ENDIF
      ELSEIF (LINQ(1:6) .EQ. 'DOUBLE') THEN
        NTYPE = 3
        K1 = NBLK (K1 + 6, K2, LINE)
        LQ = MIN (K1 + 15, K2)
        LINQ = UCASE (LINE(K1:LQ))
        IF (LINQ(1:9) .EQ. 'PRECISION') THEN
          K1 = K1 + 9
        ELSEIF (LINQ(1:7) .EQ. 'COMPLEX') THEN
          NTYPE = 5
          K1 = K1 + 7
        ENDIF
      ELSEIF (LINQ(1:7) .EQ. 'COMPLEX') THEN
        NTYPE = 4
        K1 = NBLK (K1 + 7, K2, LINE)
        IF (LINE(K1:K1) .EQ. '*') THEN
          K1 = NBLK (K1 + 1, K2, LINE)
          IF (LINE(K1:K1+1) .EQ. '16') THEN
            NTYPE = 5
            K1 = K1 + 2
          ELSE
            K1 = K1 + 1
          ENDIF
        ENDIF
      ELSEIF (LINQ(1:9) .EQ. 'CHARACTER') THEN
        NTYPE = 6
        K1 = NBLK (K1 + 9, K2, LINE)
        IF (LINE(K1:K1) .EQ. '*') THEN
          K1 = NBLK (K1 + 1, K2, LINE)
          J3 = INDX (K1, K2, ' ', LINE)
          IF (J3 .NE. 0) THEN
            K1 = J3
          ELSE
            K1 = K2 + 1
          ENDIF
        ENDIF
      ELSEIF (LINQ(1:7) .EQ. 'LOGICAL') THEN
        NTYPE = 7
        K1 = NBLK (K1 + 7, K2, LINE)
        IF (LINE(K1:K1) .EQ. '*') K1 = 1 + NBLK (K1 + 1, K2, LINE)
      ELSEIF (LINQ(1:14) .EQ. 'MULTIP INTEGER') THEN
        NTYPE = 8
        K1 = NBLK (K1 + 14, K2, LINE)
      ELSEIF (LINQ(1:11) .EQ. 'MULTIP REAL') THEN
        NTYPE = 9
        K1 = NBLK (K1 + 11, K2, LINE)
      ELSEIF (LINQ(1:14) .EQ. 'MULTIP COMPLEX') THEN
        NTYPE = 10
        K1 = NBLK (K1 + 14, K2, LINE)
      ELSE
        NTYPE = 0
      ENDIF
C
      RETURN
      END
C
      FUNCTION NUMCON (K1, K2, LA, LINA)
C
C   This parses numeric constants, returning the type of the constant.
C   K1 is the index of the start of the constant, and K2 is the index of
C   the end (an output value).  LA is the index of the last non-blank
C   character in LINA.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*1 CJ
C
C   IB =  1 if the previous character was a blank, 0 otherwise.
C   ID =  1 if a digit has occurred, 0 otherwise.  Reset to 0 after D or E.
C   IP =  1 if a period has occurred, 0 otherwise.
C   IS =  1 if a sign has occurred, 0 otherwise.  Reset to 0 after D or E.
C   IT =  The type number of the constant (1, 2, 3 or 9).
C   IX =  1 if a D or E has occurred, 0 otherwise.
C
      IB = 0
      ID = 0
      IP = 0
      IS = 0
      IT = 1
      IX = 0
C
      DO 100 J = K1, LA
        CJ = LINA(J:J)
        IF (INDEX (DIG, CJ) .NE. 0) THEN
          ID = 1
          GOTO 100
        ELSEIF (CJ .EQ. '.') THEN
          IF (IP .NE. 0 .OR. IX .NE. 0 .OR. J .EQ. IB + 1) GOTO 110
          IP = 1
          IT = 2
          GOTO 100
        ELSEIF (CJ .EQ. 'D' .OR. CJ .EQ. 'd') THEN
          IF (IX .EQ. 1) CALL ERRMES (88, 1)
          ID = 0
          IS = 0
          IT = 3
          IX = 1
          GOTO 100
        ELSEIF (CJ .EQ. 'E' .OR. CJ .EQ. 'e') THEN
          IF (IX .EQ. 1) CALL ERRMES (89, 1)
          ID = 0
          IS = 0
          IT = 2
          IX = 1
          GOTO 100
        ELSEIF (CJ .EQ. '+' .OR. CJ .EQ. '-') THEN
          IF (ID .NE. 0 .OR. IS .NE. 0) GOTO 110
          IF (IP .NE. 0 .AND. IX .EQ. 0) CALL ERRMES (90, 1)
          IS = 1
          GOTO 100
        ELSEIF (CJ .EQ. ' ') THEN
          IB = J
          GOTO 100
        ELSE
          GOTO 110
        ENDIF
 100  CONTINUE
C
      J = LA + 1
C
C   Numeric constant has been parsed.  Trim any trailing blanks.
C
 110  K2 = J - 1
 120  IF (K2 .GE. K1 .AND. LINA(K2:K2) .EQ. ' ') THEN
        K2 = K2 - 1
        GOTO 120
      ENDIF
      NUMCON = IT
C
      RETURN
      END
C
      SUBROUTINE OUTLIN (IC, LA, LINA)
C
C   This outputs Fortran statements.  If IC is 0, LINA is a comment line up
C   to 80 characters long.  If IC is 1, LINA is a possibly multiline Fortran
C   statement.  If IC is 2, LINA is a possibly multiline Fortran statement that
C   will be output with 'CMP>' at the start of each line.  If IC is 3, LINA is
C   a possibly multiline Fortran statement that is to be output on unit 8
C   instead of 7.
C
      CHARACTER*1600 LINA
C
      IF (IC .EQ. 0) THEN
        I1 = MAX (LA, 1)
        WRITE (11, 1) LINA(1:I1)
 1      FORMAT (A)
      ELSEIF (IC .EQ. 1) THEN
        I1 = MIN (LA, 72)
        WRITE (11, 1) LINA(1:I1)
C
        DO 100 I = 73, LA, 66
          I1 = MIN (I + 65, LA)
          WRITE (11, 2) LINA(I:I1)
 2        FORMAT (5X,'$',A)
 100    CONTINUE
C
      ELSEIF (IC .EQ. 2) THEN
        I1 = MIN (LA, 72)
        WRITE (11, 3) LINA(7:I1)
 3      FORMAT ('CMP>    ',A)
C
        DO 110 I = 73, LA, 66
          I1 = MIN (I + 65, LA)
          WRITE (11, 4) LINA(I:I1)
 4        FORMAT ('CMP>   $',A)
 110    CONTINUE
C
      ELSEIF (IC .EQ. 3) THEN
        I1 = MIN (LA, 72)
        WRITE (12, 1) LINA(1:I1)
C
        DO 120 I = 73, LA, 66
          I1 = MIN (I + 65, LA)
          WRITE (12, 2) LINA(I:I1)
 120    CONTINUE
C
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE PARAM (K1, LN)
C
C   This processes parameter statements.  K1 is the index of the first
C   character after 'PARAMETER'.  LN is the index of the last non-blank
C   character.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*80 ARG(MAR), ARGX
      DIMENSION ITAR(MAR), LAR(MAR)
C
C   Use FIXSUB to change names of special constants.
C
      K2 = LN
      CALL FIXSUB (K1, K2, LN)
C
C   Use ARLIST to process each separate expression.
C
      J1 = NBLK (K1, LN, LINE)
      IF (LINE(J1:J1) .NE. '(' .OR. LINE(LN:LN) .NE. ')')               
     $  CALL ERRMES (91, 1)
      LA = LN - J1 - 1
      LINA(1:LA) = LINE(J1+1:LN-1)
      CALL ARLIST (12, LA, LINA, NAR, ITAR, LAR, ARG)
      IF (NAR .EQ. 0) CALL ERRMES (92, 1)
      MPA = MPA + NAR
C
C   Make sure that all expressions were assignments.
C
      DO 100 I = 1, NAR
        IF (LAR(I) .NE. 0) CALL ERRMES (93, 1)
 100  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE RDWR (IRW, K1, K2, LN)
C
C   This processes read and write statements, depending on whether IRW is
C   1 or 2.  K1 and K2 and the indices of the parentheses.  LN is the index
C   of the last non-blank character.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA
      CHARACTER*80 ARG(MAR), ARGK
      CHARACTER*16 UNIT, NAM
      CHARACTER*8 NUMX, NUMY
      DIMENSION ITAR(MAR), LAR(MAR)
      CHARACTER*4 TMP1, TMP2, TMP3, GETMP
C
C   Place the output precision parameter into a character variable.
C
      WRITE (NUMY, '(I8)') MPP
      I1 = NBLK (1, 8, NUMY)
      LX = 9 - I1
      NUMX = NUMY(I1:8)
C
C   Determine unit number.
C
      I1 = INDX (K1, LN, ',', LINE)
      IF (I1 .NE. 0 .AND. I1 .LT. K2) THEN
        I2 = I1
      ELSE
        I2 = K2
      ENDIF
      LUN = I2 - K1 - 1
      UNIT(1:LUN) = LINE(K1+1:I2-1)
C
C   Check if there is a * for the format.
C
      IF (I2 .LT. K2) THEN
        I2 = NBLK (I2 + 1, K2, LINE)
        IF (LINE(I2:K2-1) .NE. '*') THEN
          CALL ERRMES (94, 0)
          WRITE (6, 1)
 1        FORMAT ('This form of read/write statement is not allowed',   
     $      ' with MP variables.')
          CALL ABRT
        ENDIF
      ELSE
C
C   There is no star or format number -- this is a binary I/O statement.
C   Check to make sure there are no parentheses.
C
        I1 = INDX (K2 + 1, LN, '(', LINE)
        IF (I1 .NE. 0) THEN
          CALL ERRMES (95, 0)
          WRITE (6, 2)
 2        FORMAT ('Only entire arrays may be output with binary MP',    
     $      ' I/O.')
          CALL ABRT
        ENDIF
        CALL OUTLIN (1, LN, LINE)
        GOTO 120
      ENDIF
C
C   Form a list of the arguments.
C
      J1 = NBLK (K2 + 1, LN, LINE)
      LA = LN - J1 + 1
      LINA(1:LA) = LINE(J1:LN)
      CALL ARLIST (11, LA, LINA, NAR, ITAR, LAR, ARG)
C
C   Process the statement.
C
      DO 100 K = 1, NAR
        ARGK = ARG(K)
        LK = LAR(K)
        ITK = ITAR(K)
C
C   Set NAM to be the argument without subscripts.
C
        I1 = INDEX (ARGK(1:LK), '(')
        IF (I1 .EQ. 0) THEN
          I2 = LK
        ELSE
          I2 = I1 - 1
        ENDIF
        I2 = MIN (I2, 16)
        NAM = ARGK(1:I2)
C
C   Check if the argument is a constant or a variable.
C
        IF (MAX (INDEX (ALPL, NAM(1:1)), INDEX (ALPU, NAM(1:1))) .GT. 0)
     $    THEN
C
C   Check if the variable has subscripts and if it is dimensioned.
C
          IX = ITAB (0, 0, NAM)
          IF (IX .EQ. 0) THEN
            CALL ERRMES (96, 0)
            WRITE (6, 3) NAM
 3          FORMAT ('This Fortran keyword may not appear in a',         
     $        ' read/write statement: ',A)
            CALL ABRT
          ELSEIF (I1 .EQ. 0 .AND. KDIM(IX) .NE. 0 .AND.                 
     $        KDIM(IX) .NE. -3) THEN
            CALL ERRMES (97, 0)
            WRITE (6, 4) NAM
 4          FORMAT ('Dimensioned variables must be subscripted in this',
     $        ' form of read/write: ',A)
            CALL ABRT
          ENDIF
        ENDIF
C
C   Check if it is read or a write.
C
        IF (IRW .EQ. 1) THEN
          IF (ITK .LT. 8) THEN
C
C   Read an ordinary non-MP variable.
C
            WRITE (11, 5) UNIT(1:LUN), ARGK(1:LK)
 5          FORMAT (6X,'READ (',A,', *) ',A)
          ELSEIF (ITK .NE. 10) THEN
C
C   Read a MPI or MPR variable, possibly on multiple lines.
C
            TMP1 = GETMP (6)
            WRITE (11, 6) UNIT(1:LUN), ARGK(1:LK), TMP1
 6          FORMAT (6X,'CALL MPINP (',A,', ',A,', ',A,')')
          ELSE
C
C   Read a MPC variable.
C
            TMP1 = GETMP (6)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            WRITE (11, 6) UNIT(1:LUN), TMP2, TMP1
            WRITE (11, 6) UNIT(1:LUN), TMP3, TMP1
            WRITE (11, 7) TMP2, TMP3, ARGK(1:LK)
 7          FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')')
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ENDIF
        ELSE
          IF (ITK .EQ. 1) THEN
C
C   Write an integer variable.
C
            WRITE (11, 8) UNIT(1:LUN), ARGK(1:LK)
 8          FORMAT (6X,'WRITE (',A,', ''(I12)'') ',A)
          ELSEIF (ITK .GE. 2 .AND. ITK .LE. 5) THEN
C
C   Write an SP, DP, CO or DC variable.
C
            WRITE (11, 9) UNIT(1:LUN), ARGK(1:LK)
 9          FORMAT (6X,'WRITE (',A,', ''(1P2D25.15)'') ',A)
          ELSEIF (ITK .EQ. 6) THEN
C
C   Write a character variable.
C
            WRITE (11, 10) UNIT(1:LUN), ARGK(1:LK)
 10         FORMAT (6X,'WRITE (',A,', ''(A)'') ',A)
          ELSEIF (ITK .EQ. 7) THEN
C
C   Write a logical variable.
C
            WRITE (11, 11) UNIT(1:LUN), ARGK(1:LK)
 11         FORMAT (6X,'WRITE (',A,', ''(L4)'') ',A)
          ELSEIF (ITK .NE. 10) THEN
C
C   Write a MPI or MPR variable.
C
            TMP1 = GETMP (6)
            WRITE (11, 12) UNIT(1:LUN), ARG(K)(1:LAR(K)), NUMX(1:LX),   
     $        TMP1
 12         FORMAT (6X,'CALL MPOUT (',A,', ',A,', ',A,', ',A,')')
          ELSE
C
C   Read a MPC variable.
C
            TMP1 = GETMP (6)
            TMP2 = GETMP (9)
            TMP3 = GETMP (9)
            WRITE (11, 13) ARGK(1:LK), TMP2, TMP3
 13         FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')')
            WRITE (11, 12) UNIT(1:LUN), TMP2, NUMX(1:LX), TMP1
            WRITE (11, 12) UNIT(1:LUN), TMP3, NUMX(1:LX), TMP1
            CALL RLTMP (TMP2)
            CALL RLTMP (TMP3)
          ENDIF
        ENDIF
 100  CONTINUE
C
C   Release any temporaries among the arguments.
C
      DO 110 I = 1, NAR
        LI = LAR(I)
        IF (LI .EQ. 4) THEN
          IF (ARG(I)(1:2) .EQ. 'MP') THEN
            TMP1 = ARG(I)(1:4)
            CALL RLTMP (TMP1)
          ENDIF
        ENDIF
 110  CONTINUE
C
      GOTO 120
C
 120  RETURN
      END
C
      SUBROUTINE RLTMP (TMP)
C
C   This releases temporary variable TMP for future use.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*4 TMP
      CHARACTER*1 CX
C
      READ (TMP, 1, ERR = 110) CX, K
 1    FORMAT (2X,A1,I1)
C
      DO 100 I = 1, NTYP
        IF (CTM(I) .EQ. CX) GOTO 120
 100  CONTINUE
C
 110  CALL ERRMES (98, 0)
      WRITE (6, 2) TMP
 2    FORMAT ('RLTMP could not find temporary variable in table : ',A/  
     $  'Please contact the author.')
      CALL ABRT
C
 120  ITMP(K,I) = 0
C
      RETURN
      END
C
      SUBROUTINE TYPE (ITP, K1, LN)
C
C   This processes type statements by delimiting variable names, inserting in
C   table if required (with types set to ITP) and placing any previously
C   declared MP variables in a separate statement, with dimensions corrected.
C   If ITP = 20, this is a flag that the statement being processed is an
C   external directive, and no types are set.  K1 and LN are the indices of the
C   first (after the type name) and last non-blank characters in the statement.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
      CHARACTER*1600 LINA, LINB
      CHARACTER*16 NAM
      CHARACTER*1 CJ
      CHARACTER*8 DIM1, DIM2, DIMY
C
C  Output the original line as a comment, unless (1) this is a MP directive or
C  (2) this is a non-MP type statement and no MP type directives have yet
C  appeared in this routine.
C
      IF (ITP .LT. 8 .AND. MPT .NE. 0) CALL OUTLIN (2, LN, LINE)
C
C   Form the start of LINA and LINB.
C
      KA = 12
      NA = 0
      LINA(1:KA-1) = '      REAL '
      KB = K1
      NB = 0
      LINB(1:KB-1) = LINE(1:KB-1)
      LINB(KB:KB) = ' '
      KB = KB + 1
C
C   Place the MP dimension into the character variables DIM1 and DIM2.
C
      WRITE (DIMY, '(I8)') MXP + 4
      I1 = NBLK (1, 8, DIMY)
      LD1 = 9 - I1
      DIM1 = DIMY(I1:8)
      WRITE (DIMY, '(I8)') 2 * MXP + 8
      I1 = NBLK (1, 8, DIMY)
      LD2 = 9 - I1
      DIM2 = DIMY(I1:8)
      J1 = K1
C
C   Extract the next character from the line.
C
 100  IF (J1 .GT. LN) GOTO 130
      J1 = NBLK (J1, LN, LINE)
      CJ = LINE(J1:J1)
C
C   Check if it the start of a name.
C
      IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN
C
        DO 110 J = J1, LN
          CJ = LINE(J:J)
          IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) GOTO 110
          IF (INDEX (DIG, CJ) .NE. 0) GOTO 110
          IF (INDEX (DEL, CJ) .NE. 0) GOTO 120
          CALL ERRMES (99, 1)
 110    CONTINUE
C
        J = LN + 1
 120    J2 = J - 1
        NAM = LINE(J1:J2)
C
C   Add entry to variable table.  With a few exceptions, it should not already
C   be in the table.  Exceptions: the function name, variables in the argument
C   list, variables in previous MP and conventional explicit type statements,
C   the special constants and the special functions.
C
        IX = ITAB (0, 0, NAM)
        IF (IX .NE. 0 .AND. (ITP .GE. 8 .OR. ITP .LT. 8 .AND.           
     $    MPLC(IX) .EQ. 1)) THEN
          CALL ERRMES (100, 0)
          WRITE (6, 1) NAM
 1        FORMAT ('This reserved or previously defined name may not',   
     $      ' appear in a type'/'statement: ',A)
          CALL ABRT
        ENDIF
        IX = ITAB (1, ITP, NAM)
        IF (IX .EQ. 0) THEN
          CALL ERRMES (101, 0)
          WRITE (6, 2) NAM
 2        FORMAT ('This Fortran keyword may not appear in a type',      
     $      ' statement: ',A)
          CALL ABRT
        ENDIF
        KTP = KTYP(IX)
C
C   If this is a CMP+ directive, there should be no dimensions.
C
        IF (ITP .GE. 8) THEN
          I1 = INDEX (LINE(J2:LN), '(')
          IF (I1 .NE. 0) THEN
            CALL ERRMES (102, 0)
            WRITE (6, 3)
 3          FORMAT ('MP type directives may not specify dimensions.')
            CALL ABRT
          ENDIF
          J1 = J2 + 1
          GOTO 100
        ENDIF
C
C   Check if this is a MP variable with a dimension.  If so, copy it to LINA.
C   If it is a MP variable without a dimension, copy it to neither line.
C
        IF (KTP .GE. 8) THEN
          IF (J2 .LT. LN) THEN
            J3 = NBLK (J2 + 1, LN, LINE)
            CJ = LINE(J3:J3)
            IF (CJ .EQ. '(') THEN
              KDEC(IX) = 1
              NA = NA + 1
              LINA(KA:KA+J2-J1) = LINE(J1:J2)
              KA = KA + J2 - J1 + 1
              J1 = J3
C
C   Insert MP dimension as the first dimension.
C
              LINA(KA:KA) = '('
              IF (KTP .LT. 10) THEN
                LINA(KA+1:KA+LD1) = DIM1(1:LD1)
                KA = KA + LD1 + 1
              ELSE
                LINA(KA+1:KA+LD2) = DIM2(1:LD2)
                KA = KA + LD2 + 1
              ENDIF
              KDIM(IX) = 1
              LINA(KA:KA) = ','
              KA = KA + 1
              J2 = MATCH (0, J1 + 1, LN, LINE)
              IF (J2 .EQ. 0) CALL ERRMES (103, 1)
              I1 = ISCAN (J1, J2, LINE)
              IF (I1 .NE. 0) THEN
                CALL ERRMES (104, 0)
                WRITE (6, 4) NAM
 4              FORMAT ('The MP dimension on this variable is not',     
     $            ' allowed: ',A)
                CALL ABRT
              ENDIF
              LINA(KA:KA+J2-J1-1) = LINE(J1+1:J2)
              KA = KA + J2 - J1
              LINA(KA:KA+1) = ', '
              KA = KA + 2
            ENDIF
          ENDIF
C
C   Otherwise this is an ordinary variable -- copy to LINB.
C
        ELSE
          KDEC(IX) = 1
          NB = NB + 1
          LINB(KB:KB+J2-J1) = LINE(J1:J2)
          KB = KB + J2 - J1 + 1
          IF (J1 .LT. LN) THEN
            J3 = NBLK (J2 + 1, LN, LINE)
            CJ = LINE(J3:J3)
            IF (CJ .EQ. '(') THEN
              KDIM(IX) = 1
              LINB(KB:KB) = '('
              KB = KB + 1
              J1 = J3
              J2 = MATCH (0, J1 + 1, LN, LINE)
              I1 = ISCAN (J1, J2, LINE)
              IF (I1 .NE. 0) THEN
                CALL ERRMES (105, 0)
                WRITE (6, 4) NAM
                CALL ABRT
              ENDIF
              LINB(KB:KB+J2-J1-1) = LINE(J1+1:J2)
              KB = KB + J2 - J1
            ENDIF
          ENDIF
          LINB(KB:KB+1) = ', '
          KB = KB + 2
        ENDIF
        J1 = J2 + 1
        GOTO 100
C
C   The only other character that should appear here is a comma.
C
      ELSEIF (CJ .EQ. ',') THEN
        J1 = J1 + 1
        GOTO 100
      ELSE
        CALL ERRMES (106, 1)
      ENDIF
C
C   Output LINA and LINB, provided there is something to output.
C
 130  IF (NA .GT. 0) CALL OUTLIN (1, KA - 3, LINA)
      IF (NB .GT. 0) CALL OUTLIN (1, KB - 3, LINB)
      IF (ITP .LT. 8 .AND. MPT .NE. 0) WRITE (11, 5)
 5    FORMAT ('CMP<')
C
      RETURN
      END
C
      FUNCTION UCASE (NAM)
C
C   This routine returns the character string NAM with upper case alphabetics.
C+
      PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, 
     $  NKY = 45, NOP = 14, NSF = 50, NTYP = 10)
      CHARACTER*1600 LINE, SARG
      CHARACTER*26 ALPL, ALPU
      CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR
      CHARACTER*10 DEL, DIG
      CHARACTER*8 CTP, LOPR, UOPR
      CHARACTER*1 CTM
      COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, 
     $  MPT, MSS, MXP, NSUB, NVAR
      COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP),        
     $  KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB),  
     $  LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB)
      COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG
      COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), 
     $  SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR)
C+
C
      CHARACTER*16 NAMX, UCASE
      CHARACTER*(*) NAM
      CHARACTER*1 CJ
C
      NAMX = ' '
      LQ = LEN (NAM)
C
      DO 100 J = 1, LQ
        CJ = NAM(J:J)
        I1 = INDEX (ALPL, CJ)
        IF (I1 .GT. 0) THEN
          NAMX(J:J) = ALPU(I1:I1)
        ELSE
          NAMX(J:J) = CJ
        ENDIF
 100  CONTINUE
C
      UCASE = NAMX
      RETURN
      END
